src/ness/nesobj_bender.f

Fortran project RESTRAX, source module src/ness/nesobj_bender.f.

Source module last modified on Wed, 13 Jul 2005, 16:20;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#//////////////////////////////////////////////////////////////////////
#////                                                              //// 
#////  NEutron Scattering Simulation - v.2.0, (c) J.Saroun, 1999   ////
#////                                                              //// 
#//////////////////////////////////////////////////////////////////////
#////
#////  Subroutines describing objects - BENDER
#////  
#////  * LOGICAL*4 FUNCTION BENDER_PASS(OBJ,R,IH,IV,exit)
#////  * LOGICAL*4 FUNCTION CONTACT(X0,Z0,alpha,RO,kx,kz,T)
#////  * REAL*8 FUNCTION BENDER_REF(ID,OBJ,Q,S)
#////  * SUBROUTINE BENDER_INIT(OBJ)
#////  * LOGICAL*4 FUNCTION BENDER_GO(OBJ,NEUI,NEUF)
#////  
#//////////////////////////////////////////////////////////////////////



#
      logical*4 FUNCTION BENDER_PASS(obj,r,ih,iv,exit)
#
#       returns slit coordinates
#
        implicit none
        INCLUDE 'nesobj_bender.inc'
        integer*4 ih,iv,exit
        logical*4 log1
        real*8 r(3),jh,jv,w,h
        record /BENDER/ obj

        if (exit.eq.1) then 
           w=obj.w2
           h=obj.h2
        else
           w=obj.frame.size(1)
           h=obj.frame.size(2)
        endif 
        jh=(r(1)/w+0.5)*obj.nlh
        jv=(r(2)/h+0.5)*obj.nlv
        ih=nint(jh-0.5)
        iv=nint(jv-0.5)
        log1=((abs(jh-nint(jh))*w/obj.nlh.ge.obj.dlh/2.).and.
     1        (abs(jv-nint(jv))*h/obj.nlv.ge.obj.dlv/2.).and.
     1        (jh.gt.0.).and.
     1        (jv.gt.0.).and.
     1        (jh.lt.obj.nlh).and.
     1        (jv.lt.obj.nlv))
              
        BENDER_PASS=log1
#
#           write(*,*) 'PASS : ',JH,IH,OBJ.FRAME.COUNT
#
#
#
#        endif
        end  

        
#
      logical*4 FUNCTION CONTACT(x0,z0,alpha,ro,kx,kz,t)
#
#       to reach it
#       X0,Z0 ... initial coordinates of the neutron with respect
#                 to the lamella front end
#       alpha ... lamella inclination angle (without curvature)
#       R0    ... lamella curvature
#       kx,kz ... transversal and longitudinal components of neutron 
#                 k vector
#
        implicit none
        logical*4 log1, QUADREQ
        real*8 x0,z0,alpha,ro,kx,kz,t,a,b,c

        a=0.5*ro*kz**2
        b=alpha*kz-kx+ro*kz*z0
        c=alpha*z0+0.5*ro*z0**2-x0
        log1=QUADREQ(a,b,c,t)
        CONTACT=log1
        end



#
      real*8 FUNCTION BENDER_REF(id,obj,q,s)
#
#       ID identifies which surface is touched
#       ID=0  left 
#       ID=1  right 
#       ID=2  top 
#       ID=3  bottom 
#
        implicit none
        INCLUDE 'const.inc'      
        INCLUDE 'nesobj_bender.inc'
        
        integer*4 iz,id,nr
        real*8 q,s,z,dq,q1,gamma,r   
     
        record /BENDER/ obj
           
        if (id.eq.0) then 
          if (s.ge.0) then
            gamma=obj.ghlu
            r=obj.rhlu
            nr=obj.nhlu
          else  
            gamma=obj.ghld
            r=obj.rhld
            nr=obj.nhld
          endif 
        else if (id.eq.1) then 
          if (s.ge.0) then
            gamma=obj.ghru
            r=obj.rhru
            nr=obj.nhru
          else  
            gamma=obj.ghrd
            r=obj.rhrd
            nr=obj.nhrd
          endif 
        else if (id.eq.2) then 
            gamma=obj.gvt
            r=obj.rvt
            nr=obj.nvt
        else if (id.eq.3) then 
            gamma=obj.gvb
            r=obj.rvb
            nr=obj.nvb
        else
            gamma=0.   
            r=0. 
        endif    
        
        if (gamma.le.0.or.q.le.0) then
           BENDER_REF=0
           return
        endif   
        
      if(nr.le.0.or.nr.gt.5) then
              if (q.lt.2*pi*gamma) then                            
                 BENDER_REF=r
              else
                 BENDER_REF=0                 
              endif 
        else
              q1=q/2/pi/gammani
              dq=m_alpha(2,nr)-m_alpha(1,nr)
              z=(q1-m_alpha(1,nr))/dq
                             
              iz=int(z)+1
              if(z.lt.0.or.z.ge.m_n(nr).or.iz.ge.m_n(nr)) then 
                 BENDER_REF=0                 
              else if (s.ge.0) then
               BENDER_REF=m_ref1(iz,nr)+(z-iz+1)*
     1                (m_ref1(iz+1,nr)-m_ref1(iz,nr))  
              else if (s.lt.0) then
               BENDER_REF=m_ref2(iz,nr)+(z-iz+1)*
     1                (m_ref2(iz+1,nr)-m_ref2(iz,nr))
              else     
                 BENDER_REF=0 
              endif 
        endif        
        
      end
      
#     -------------------------------
      SUBROUTINE BENDER_INIT(obj)
#
      implicit none
      INCLUDE 'nesobj_bender.inc'
      record /BENDER/ obj
      
      call SLIT_INIT(obj.frame)
      obj.typ=0
      if (obj.curv.ne.0) then 
         obj.typ=obj.typ+1
      endif   
      if (obj.ghlu.ne.0.or.
     *     obj.ghld.ne.0.or.
     *     obj.ghru.ne.0.or.
     *     obj.ghrd.ne.0.or.
     *     obj.gvt.ne.0.or.
     *     obj.gvb.ne.0) then 
        obj.typ=obj.typ+2
      endif
      end  
      

#xxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCx

#
      logical*4 FUNCTION BENDER_GO(obj,neui,neuf)
#
      implicit none

      INCLUDE 'const.inc'      
      INCLUDE 'nesobj_bender.inc'
      
      record /BENDER/ obj
      record /NEUTRON/ neui,neuf
      logical*4 log1, BENDER_PASS,CONTACT
      real*8 BENDER_REF
      integer*4 ih,iv,ih1,iv1,i
      real*8 v(3),k(3),r(3),r2(3)
      real*8 al,ar,at,ab,tl,tr,tt,tb,zl,zr,zt,zb,xl,xr,xt,xb
      real*8 kk,dum,beta0,delta0,p,pp,dt,t,q,tini,dphi
#      LOGICAL*4 FLAG
#      CHARACTER*14 dname
#      CHARACTER*1 CH    
# 100    format('tra',I3,a4,'.dat')
  101    format(1x,7(g10.3,2x),a1)
# 102    format(1x,5(E10.3,2x),2x,a10)
# 103    format(1x,3(E10.3,2x),2x,I4,2x,a10)

      
      neuf=neui         
      call SLIT_PRE(obj.frame,neui.r,neui.k,v,k)
      neuf.t=neui.t-v(3)/hovm/k(3)
      tini=neuf.t  ! initial time
      pp=1.
      beta0=0.
      log1=.true.
      do 10 i=1,2
10       r(i)=v(i)-v(3)/k(3)*k(i)
      r(3)=0.
      
      if (obj.frame.size(3).le.0) goto 210   ! collimator ignored

#///  check the pass through the entry

#      FLAG=(OBJ.FRAME.NAME(1:4).EQ.'col4'.AND.
#     *      OBJ.FRAME.COUNT.GT.1000.AND.OBJ.FRAME.COUNT.LT.1011) 
#      FLAG=.FALSE.    
#      IF(FLAG) then
#        write(*,101) (NEUI.R(i),i=1,3),(NEUI.K(i),i=1,3)
#        write(*,101) (V(i),i=1,3),(K(i),i=1,3),NEUI.P 
#        write(*,101) (R(i),i=1,3)
#       write(*,*) BENDER_PASS(OBJ,R,IH,IV,0), IH,IV
#      ENDIF 

      if (.not.BENDER_PASS(obj,r,ih,iv,0)) goto 300      
            
      beta0=obj.curv*obj.frame.size(3)


#      CH='I'
#      write(*,103) (R(I),I=1,3),OBJ.FRAME.COUNT,
#    1 OBJ.FRAME.NAME 
#        write(dname,100) OBJ.FRAME.COUNT,OBJ.FRAME.NAME
#        if (dname(4:4).eq.' ') dname(4:4)='0'
#        if (dname(5:5).eq.' ') dname(5:5)='0'
#
#        write(15,101) (R(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH 



# **** normal collimator  ****
      if (obj.typ.eq.0) then
        dt=obj.frame.size(3)/k(3)  ! time of flight
        do i=1,2
        r2(i)=r(i)+dt*k(i)
        enddo     
        r2(3)=obj.frame.size(3)
        log1=(log1.and.BENDER_PASS(obj,r2,ih1,iv1,1)) 
#        IF(FLAG) THEN
#          write(*,101) (R2(i),i=1,3),(K(i),i=1,3),NEUI.P 
#          IF (LOG1) write(*,*) BENDER_PASS(OBJ,R,IH,IV,0), IH,IV
#          CALL GETSTATE
#          pause
#        ENDIF  
        if (log1.and.(ih1.eq.ih).and.(iv1.eq.iv)) then
#
#         write(15,101) (R2(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH 
#           write(*,*) dname 
#           pause          
          do i=1,3
          r(i)=r2(i)    ! move to colimator exit
          enddo 
          neuf.t=neuf.t+dt/hovm  
          goto 210      ! free passage 
        else
#         CLOSE(15) 
          goto 300      ! no passage
        endif 
      endif

# ****  neutron guide  ****
      
      kk=sqrt(k(1)**2+k(2)**2+k(3)**2)

#  left      
      zl=(ih+1)*1./obj.nlh-0.5
      xl=zl*obj.frame.size(1)-0.5*obj.dlh
      al=(obj.w2-obj.frame.size(1))/obj.frame.size(3)*zl
#  right      
      zr=ih*1./obj.nlh-0.5
      xr=zr*obj.frame.size(1)+0.5*obj.dlh
      ar=(obj.w2-obj.frame.size(1))/obj.frame.size(3)*zr
#  top      
      zt=(iv+1)/obj.nlv-0.5
      xt=zt*obj.frame.size(2)-0.5*obj.dlv
      at=(obj.h2-obj.frame.size(2))/obj.frame.size(3)*zt
#  bottom      
      zb=iv*1./obj.nlv-0.5
      xb=zb*obj.frame.size(2)+0.5*obj.dlv
      ab=(obj.h2-obj.frame.size(2))/obj.frame.size(3)*zb
      

#***** beginning of the guide tracing cycle
50    continue
      
      if (CONTACT(r(1)-xl,r(3),al,obj.curv,k(1),k(3),t)) then
         tl=t 
      else
         tl=1.d35
      endif     
      
      if (CONTACT(r(1)-xr,r(3),ar,obj.curv,k(1),k(3),t)) then
         tr=t 
      else
         tr=1.d35
      endif
           
      if (CONTACT(r(2)-xt,r(3),at,0.d0,k(2),k(3),t)) then
         tt=t 
      else
         tt=1.d35
      endif
          
      if (CONTACT(r(2)-xb,r(3),ab,0.d0,k(2),k(3),t)) then
         tb=t 
      else
         tb=1.d35
      endif
               
      dt=min(tl,tr,tt,tb)
      
      if(dt.eq.1.d35) then
         dt=0.
      endif    
       
# go to a point of reflection             
      do i=1,3
         r2(i)=r(i)   ! remember old position !
      enddo   

      do i=1,3
           r(i)=r(i)+k(i)*dt   ! go to the contact point
      enddo 

      if (r(3).gt.obj.frame.size(3)) then   ! bender exit
         dt=(obj.frame.size(3)-r2(3))/k(3)
       do i=1,3
               r(i)=r2(i)+dt*k(i)
         enddo 
       neuf.t=neuf.t+dt/hovm  
#
#        write(15,101) (R(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH 
         goto 199  
      endif 
      
      neuf.t=neuf.t+dt/hovm        
#     CH='X'       
      if (dt.eq.tl) then
        q=k(1)-(al+r(3)*obj.curv)*kk
          p=BENDER_REF(0,obj,q,neui.s)
        if (p.gt.0) k(1)=k(1)-2*q  
#
      else if (dt.eq.tr) then
        q=-k(1)+(ar+r(3)*obj.curv)*kk
          p=BENDER_REF(1,obj,q,neui.s)
        if (p.gt.0) k(1)=k(1)+2*q 
#
      else if (dt.eq.tt) then
        q=k(2)-at*kk
          p=BENDER_REF(2,obj,q,neui.s)
        if (p.gt.0) k(2)=k(2)-2*q 
#
      else if (dt.eq.tb) then
        q=-k(2)+ab*kk
          p=BENDER_REF(3,obj,q,neui.s)
        if (p.gt.0) k(2)=k(2)+2*q 
#
      endif
      pp=pp*p
      if (pp.lt.1.d-4) pp=0
      if (pp.gt.0) then
        dum=sqrt(k(1)**2+k(2)**2+k(3)**2)
        do i=1,3
          k(i)=k(i)*kk/dum
        enddo
#       write(15,101) (R(i),i=1,3),(K(i),i=1,3),NEUI.P*PP,CH 
      goto 50
      endif 


      
#      CLOSE(15)
#      if (PP.GT.0) then
#         write(*,*) dname, 'error' 
#         pause
#      endif

      goto 300
     
199   continue
#      CLOSE(15)
#      if (PP.GT.0) then
#         write(*,*) dname 
#         pause
#      endif

200   continue
      if (beta0.ne.0) then   !  correction for beam deflection
         delta0=0.5*obj.curv*obj.frame.size(3)**2        
         r2(1)=r(1)-r(3)*beta0+delta0
         r2(3)=r(3)+r(1)*beta0
         k(1)=k(1)-k(3)*beta0
         k(3)=k(3)+k(1)*beta0
         dum=sqrt(k(1)**2+k(2)**2+k(3)**2)
         do i=1,3                         ! renormalize k
              k(i)=k(i)*kk/dum
              r(i)=r2(i)
         enddo                 
      endif
210   call SLIT_POST(obj.frame,r,k,neuf.r,neuf.k)      
      neuf.p=neui.p*pp
      obj.frame.count=obj.frame.count+1 
      if(abs(obj.bint).gt.0.) then
        dphi=gammal*obj.bint/obj.frame.size(3)*(neuf.t-tini)*1d-3
        neuf.phi=neuf.phi+dphi  
      endif
      BENDER_GO=.true.
      return

300   continue
      BENDER_GO=.false.
      neuf.p=0
      
      return
      end        

#
      integer*4 FUNCTION READ_MIRROR(qc)
# read reflectivity data for supemirror (used in BENDER by NESS)
# *** J.S. 8/3/1999     
#---------------------------------------------------------------      
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'nesobj_bender.inc'
      integer*4 ierr,indx,i,j   
      real*8 mni,z,qc
      character*3 suffix
      character*9 fname
      character*128 mirfile


      mni=qc/gammani 
      READ_MIRROR=0 
      if(mni.lt.0) goto 200    ! clear all
      if(mni.eq.0) goto 100
      z=log10(mni)
      if (z.lt.-1.or.z.ge.1) goto 100   ! must be 0.1 <= mNi < 10
1     format(f3.1)
      write(suffix,1,err=2) mni
2     fname= 'mirror'//suffix      

      i=1
      do while(i.le.m_nmax.and.m_name(i).ne.suffix.and.m_n(i).gt.0)
         i=i+1
      enddo
      if (i.gt.m_nmax) goto 99
      if  (m_name(i).eq.suffix) then
         READ_MIRROR=i
         return
      endif
      indx=i                       
#      OPEN(22,FILE=FNAME,STATUS='OLD',ERR=100)
      call OPENRESFILE(fname, ' ',22,0,2,mirfile,ierr)
      if(ierr.ne.0) goto 100
      read(22,*,iostat=ierr,end=30,err=100)
      i=0
      do while(ierr.eq.0.and.(i.lt.128))
          read(22,*,iostat=ierr,end=30,err=30)  
     *      m_alpha(i+1,indx), m_ref1(i+1,indx),m_ref2(i+1,indx)
          i=i+1          
      enddo 
30    close(22)
      m_n(indx)=i
      m_name(indx)=suffix
3     format( 'reflectivity (',i1, ') read: ',a9, ' ,',i3, ' lines.')   
      write(sout,3) indx,fname,i
      READ_MIRROR=indx
      return

99    write(smes,*)  'Error: Lookup table for mirrors is full!'
      READ_MIRROR=-1
      return

100   READ_MIRROR=0
      return

200   do j=1,m_nmax
        do i=1,128
            m_alpha(i,j)=i
            m_ref1(i,j)=0
            m_ref2(i,j)=0
        enddo
        m_n(j)=0
        m_name(j)= ' '
      enddo
      READ_MIRROR=0
      end


      
#//////////////////  End of definition - BENDER  ///////////////////

#---------------------------------------------------
      SUBROUTINE BENDER_WRITE(iu,obj)
#     Writes parameters of OBJ to unit U
#--------------------------------------------------
      implicit none

      INCLUDE 'nesobj_bender.inc'
      integer*4 iu
      record /BENDER/ obj

2     format( ' nlh,nlv : ',2(2x,i4))
3     format( ' w2,h2 : ',2(2x,f8.1))
4     format( ' crit. angles : ',6(2x,e12.3))
5     format( ' 1/R  : ',e12.3)
6     format( ' dlh,dlv : ',2(2x,f8.3))
7     format( ' reflectivities : ',6(2x,f8.3))
8     format( ' int(B) : ',g12.5)

      call SLIT_WRITE(obj.frame,iu)
      write(iu,*)
      write(iu,3) obj.w2, obj.h2
      write(iu,2) obj.nlh,obj.nlv 
      write(iu,6) obj.dlh,obj.dlv 
      write(iu,4) obj.ghlu,obj.ghld,obj.ghru,obj.ghrd,
     1            obj.gvt,obj.gvb
      write(iu,7) obj.rhlu,obj.rhld,obj.rhru,obj.rhrd,
     1            obj.rvt,obj.rvb   
      write(iu,5) obj.curv   
      write(iu,8) obj.bint   
      return
      end