src/ness/ness_guide.f

Fortran project SIMRES, source module src/ness/ness_guide.f.

Source module last modified on Sun, 27 Mar 2005, 23:28;
HTML image of Fortran source automatically generated by for2html on Mon, 23 May 2005, 21:29.


#//////////////////////////////////////////////////////////////////////
#////                                                              //// 
#////  NEutron Scattering Simulation - v.2.0, (c) J.Saroun, 2004   ////
#////                                                              //// 
#//////////////////////////////////////////////////////////////////////
#////
#////  Subroutines describing objects - GUIDE or BENDER
#////  
#////                          
#//////////////////////////////////////////////////////////////////////

#---------------------------------------------------------------------
      SUBROUTINE GUIDE_INIT(obj)
#----------------------------------------------------------------------
      implicit none
      INCLUDE 'structures.inc'
      
      real*8 zl
      record /BENDER/ obj
      integer*4 i

1     format(a,$)      
#      write(*,1) 'GUIDE_INIT '//OBJ.FRAME.NAME(1:10)
      call SLIT_INIT(obj.frame)

# limit for number of slits = 127
      if (obj.nlh.gt.127) obj.nlh=127
      if (obj.nlv.gt.127) obj.nlv=127
# set A(I) = angles for lamellae
# set L(I) = positions of lamellae at the entry 
      if(obj.frame.size(3).gt.0) then
      do i=0,obj.nlh
         zl=i*1.d0/obj.nlh - 0.5d0
       obj.ah(i)=zl*(obj.w2-obj.frame.size(1))/obj.frame.size(3)
       obj.lh(i)=zl*obj.frame.size(1)
      enddo
      do i=0,obj.nlv
         zl=i*1.d0/obj.nlv - 0.5d0
       obj.av(i)=(obj.h2-obj.frame.size(2))/obj.frame.size(3)*zl
       obj.lv(i)=zl*obj.frame.size(2)
      enddo
      endif
#      write(*,*) '... done. ',OBJ.FRAME.SIZE(3)
            
      end
      
#---------------------------------------------------------------------
      real*8 FUNCTION GUIDE_LAM(obj,id,il,z,ior)
# function describing lamella profile
# ID   ... derivative
# IL   ... lamella index 
# Z    ... distance from guide entry
# IOR  ... horizontal (1) or vertical (2) 
#----------------------------------------------------------------------     
      implicit none
      INCLUDE 'structures.inc'
      record /BENDER/ obj
      
      real*8 a,f,x0
      real*8 z
      integer*4 id,il,ior          
      
      if (ior.eq.2) then    ! vertical slit
        f=obj.cv
        a=obj.av(il)
        x0=obj.lv(il)
      else                  ! horizontal slit
        f=obj.ch
        a=obj.ah(il)
        x0=obj.lh(il)
      endif
      
# zero deriv.      
      if (id.le.0) then
        GUIDE_LAM=x0+a*z+0.5*f*z**2
# 1st deriv.      
      else if (id.eq.1) then
        GUIDE_LAM=a+f*z
# 2nd deriv.      
      else if (id.eq.2) then
        GUIDE_LAM=f
      else
        GUIDE_LAM=0.d0
      endif
      
      end

#----------------------------------------------------------------------------
      real*8 FUNCTION GUIDE_CROSS(kx,kz,x,z,alpha,ro)
# return path length along z-coordinate to a cross-point with parabolic surface 
# if there are 2 solutions, take the minimum one which is > 0
# return 10^30 if there is no solution >0
# alpha  .. tan(angle between lamella and guide axis)
# ro     .. curvature
# x,z    .. starting point (z // guide axis)
# kx,kz  .. ray direction
# kz is assumed positive and >> kx
#----------------------------------------------------------------------------
      implicit none
      real*8 kx,kz,x,z,alpha,ro     
      real*8 lz,a,b,c
#10    FORMAT(a10,1x,6(1x,G11.4),4(1x,I4),2(1x,G10.4))
#      write(*,10) 'cross',kx,kz,x,z,alpha,ro
      a=0.5*ro*kz**2
      b=alpha*kz-kx+ro*kz*z
      c=alpha*z+0.5*ro*z**2-x
      call QUADREQ(a,b,c,lz)      
      GUIDE_CROSS=lz*kz           
      end

#---------------------------------------------------------------------
      SUBROUTINE GUIDE_CON(obj,r,k,ih,iv,ic,dt,q)
# find next contact with a slit side
# moves to the next contact point, or to the exit
# turns K, i.e. returns new K=K+Q !
# *** INPUT:
# IH,IV   ... slit indices
# R(3)    ... neutron coordinate
# K(3)    ... neutron k-vector
# *** RETURN:
# Q     .. reflection vector (magnitude)
# DT    .. time to reach the next contact point
# IC    .. which wall,  right(1), left(2), bottom (3) or top(4)
# IC=0  .. no contact, pass through
#----------------------------------------------------------------------     
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      record /BENDER/ obj
      real*8 r(3),k(3),q,dt
      integer*4 ih,iv,ic
      real*8 GUIDE_CROSS,GUIDE_LAM
      real*8 kx,kz,x,z,a,f
      real*8 lz(4),ang,t0,n(3)
      integer*4 i
      real*8 oscd,osca
      common /oscbend/ oscd,osca

10    format(a10,1x,6(1x,g11.4),4(1x,i4),2(1x,g10.4))
     
      z=r(3)
      kz=k(3)
      
      t0=obj.frame.size(3)-z
# HORIZONTAL RIGHT:
      f=obj.ch
      kx=k(1)
      a=obj.ah(ih)-osca
      x=r(1)-obj.dlh/2.d0-obj.lh(ih)-oscd-r(3)*osca
      lz(2)=GUIDE_CROSS(kx,kz,x,z,a,f)
# HORIZONTAL LEFT:
      a=obj.ah(ih+1)-osca
      x=r(1)+obj.dlh/2.d0-obj.lh(ih+1)-oscd-r(3)*osca
      lz(1)=GUIDE_CROSS(kx,kz,x,z,a,f)
# VERTICAL BOTTOM:
      f=obj.cv
      kx=k(2)
      a=obj.av(iv)
      x=r(2)-obj.dlv/2.d0-obj.lv(iv)
      lz(4)=GUIDE_CROSS(kx,kz,x,z,a,f)
# VERTICAL TOP:
      a=obj.av(iv+1)
      x=r(2)+obj.dlv/2.d0-obj.lv(iv+1)
      lz(3)=GUIDE_CROSS(kx,kz,x,z,a,f)
      
#      write(*,10) 'times: ',LZ,T0
      
      dt=min(lz(1),lz(2),lz(3),lz(4),t0)
      
      ic=0
      do i=1,4
        if (dt.eq.lz(i)) ic=i
      enddo 
      if (ic.eq.0) then  ! no contact, passed through
        dt=t0
      q=0.d0
      goto 50 
      endif

# get the surface normal vector
      do i=1,3
        n(i)=0.d0
      enddo    
      if (ic.eq.2) then
        ang=GUIDE_LAM(obj,1,ih,z+dt,1)
      n(3)=-ang/sqrt((1.d0+ang**2))
      n(1)=sqrt(1.d0-n(3)**2)
      else if (ic.eq.1) then
        ang=GUIDE_LAM(obj,1,ih+1,z+dt,1)
      n(3)=ang/sqrt((1.d0+ang**2))
      n(1)=-sqrt(1.d0-n(3)**2)
      else if (ic.eq.4) then
        ang=GUIDE_LAM(obj,1,iv,z+dt,2)
      n(3)=-ang/sqrt((1.d0+ang**2))
      n(2)=sqrt(1.d0-n(3)**2)
      else if (ic.eq.3) then
        ang=GUIDE_LAM(obj,1,iv+1,z+dt,2)    
      n(3)=ang/sqrt((1.d0+ang**2))
      n(2)=-sqrt(1.d0-n(3)**2)
      endif 

#      write(*,10) 'angles: ',ANG,N
      
# scattering vector:
      q=0.d0
      do i=1,3
        q=q-k(i)*n(i)
      enddo
# move to the point of reflection:
50    do i=1,3
        r(i)=r(i)+k(i)/k(3)*dt
      enddo   
# turn K-vector:
      do i=1,3
        k(i)=k(i)+2.d0*q*n(i)
      enddo   
#
      dt=dt/kz/hovm
      
      end
      

#----------------------------------------------------
      SUBROUTINE GUIDE_GO(obj,r,k,p,t,s)
# GO procedure for a guide with flat walls (TYP=1)      
# INPUT:   assume R,K at the entry in local coordinates !
# RETURN:  R,K at the exit in local coordinates, P=P*transmission, T=T+passage time
#
      implicit none

      INCLUDE 'structures.inc'
      
      record /BENDER/ obj
      real*8 r(3),k(3),p,t,s
      logical*4  BENDER_PASS
      real*8 BENDER_REF      
      integer*4 ih,iv,i,ic
      real*8 dum,kk,pp,tt,dt,q,co,si,beta,delta,r2(3),k2(3)

#10    FORMAT(a10,1x,6(1x,G11.4),4(1x,I4),2(1x,G10.4))
#11    FORMAT(a10,1x,8(1x,G11.4))
            
#  check passage through the entry
      if (.not.BENDER_PASS(obj,r,ih,iv)) goto 100                  

      kk=sqrt(k(1)**2+k(2)**2+k(3)**2)
      pp=1.d0
      tt=0.d0
      i=0
#      write(*,10) 'start',R,K

#  iterate through reflections
1     call GUIDE_CON(obj,r,k,ih,iv,ic,dt,q)
#      write(*,10) 'bounce',R,K,IH,IV,IC,I,DT,Q
      tt=tt+dt
# debug: prevent infinite loops      
      i=i+1
      if (i.gt.100000) then
         write(*,*) obj.frame.name,obj.frame.count
       write(*,*)  'too many iterations through bender, i=',i
         stop
      endif      
      if (ic.gt.0) then
         pp=pp*BENDER_REF(ic-1,obj,q,s)
       if (pp.lt.1.d-4) goto 100
       goto 1
      endif

#  HORIZONTAL correction for beam deflection
      beta=obj.ch*obj.frame.size(3)
      if (beta.ne.0) then  
         delta=0.5*obj.ch*obj.frame.size(3)**2
       si=beta/sqrt(1.d0+beta**2)    
       co=sqrt(1.d0-si**2)
       r2(1)=(r(1)-delta)*co-(r(3)-obj.frame.size(3))*si
         r2(2)=r(2)
         r2(3)=(r(3)-obj.frame.size(3))*co+(r(1)-delta)*si
       k2(1)=k(1)*co-k(3)*si
         k2(2)=k(2)
         k2(3)=k(3)*co+k(1)*si
         do i=1,3
           r(i)=r2(i)
           k(i)=k2(i)
         end do 
       r(3)=r(3)+obj.frame.size(3)
      endif

#  VERTICAL correction for beam deflection
      beta=obj.cv*obj.frame.size(3)
      if (beta.ne.0) then  
         delta=0.5*obj.cv*obj.frame.size(3)**2
       si=beta/sqrt(1.d0+beta**2)    
       co=sqrt(1.d0-si**2)
       r2(2)=(r(2)-delta)*co-(r(3)-obj.frame.size(3))*si
         r2(1)=r(1)
         r2(3)=(r(3)-obj.frame.size(3))*co+(r(2)-delta)*si
       k2(2)=k(2)*co-k(3)*si
         k2(1)=k(1)
         k2(3)=k(3)*co+k(2)*si
         do i=1,3
           r(i)=r2(i)
           k(i)=k2(i)
         end do 
       r(3)=r(3)+obj.frame.size(3)
      endif
      
#      write(*,11) 'OK',R,K,PP,TT
#      pause
     
# renormalize K due to numerical errors
      dum=sqrt(k(1)**2+k(2)**2+k(3)**2)
      do i=1,3
        k(i)=k(i)*kk/dum
      enddo
      p=p*pp
      t=t+tt
      return

100   continue
#      write(*,11) 'failed',R,K,PP,TT
#      pause
      p=0.d0
      
      end