src/ness/ness_eguide.f

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

Source module last modified on Tue, 29 Mar 2005, 23:56;
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, 2005   ////
#////                                                              //// 
#//////////////////////////////////////////////////////////////////////
#////
#////  Subroutines describing objects - ELLIPTIC GUIDE
#////  
#////                          
#//////////////////////////////////////////////////////////////////////

#---------------------------------------------------------------------
      SUBROUTINE EGUIDE_INIT(obj)
#----------------------------------------------------------------------
      implicit none
      INCLUDE 'structures.inc'
      
      real*4 EGUIDE_A
      real*8 f,zl,dif,h1,h2,v1,v2,w
      record /BENDER/ obj
      integer*4 i
      
      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
      
# HORIZONTAL      
# elliptic profile is determined by the dimensions
      h1=obj.frame.size(1)
      h2=obj.w2
      if (h2.eq.h1.or.obj.ch.eq.0) then   !  no ellipsa, flat walls
         obj.ch=0.d0
      else if (h2.gt.h1) then
       dif=sqrt(h2**2-h1**2)
       obj.ch=-obj.frame.size(3)*h2/dif
      else 
       dif=sqrt(h1**2-h2**2)
       obj.ch=obj.frame.size(3)*h1/dif
      endif  

      f=obj.ch
      if (f.eq.0) then  ! flat lamellas, AH & LH are angles & positions, respectively
        do i=0,obj.nlh
           zl=i*1.d0/obj.nlh - 0.5d0
         obj.ah(i)=zl*(h2-h1)/obj.frame.size(3)
         obj.lh(i)=zl*h1
        enddo
      else   ! elliptic lamellas, AH & LH are parameters & lengths, respectively
      w=max(h1,h2)
        do i=0,obj.nlh
           obj.ah(i)=EGUIDE_A(i,obj.nlh,w)
           obj.lh(i)=obj.frame.size(3)
        enddo
      endif
      
# VERTICAL      
# elliptic profile is determined by the dimensions
      v1=obj.frame.size(2)
      v2=obj.h2
      if (v2.eq.v1.or.obj.cv.eq.0) then   !  no parabola, flat walls
       obj.cv=0.d0
      else if (v2.gt.v1) then
       dif=sqrt(v2**2-v1**2)
       obj.cv=-obj.frame.size(3)*v2/dif
      else
       dif=sqrt(v1**2-v2**2)
       obj.cv=obj.frame.size(3)*v1/dif
      endif     
      f=obj.cv
      if (f.eq.0) then  ! flat lamellas, AH & LH are angles & positions, respectively
        do i=0,obj.nlv
           zl=i*1.e0/obj.nlv - 0.5d0
         obj.av(i)=zl*(v2-v1)/obj.frame.size(3)
         obj.lv(i)=zl*v1
        enddo
      else   ! elliptic lamellas, AH & LH are parameters & lengths, respectively
      w=max(v1,v2)
        do i=0,obj.nlv
           obj.av(i)=EGUIDE_A(i,obj.nlv,w)
           obj.lv(i)=obj.frame.size(3)
        enddo
      endif
      
      end

#---------------------------------------------------------------------
      real*8 FUNCTION EGUIDE_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,b,zz,aa,x0
      real*8 z
      integer*4 id,il,ior          
#//  a is the ellipse main axis // z (or slope for a planar lamellla)
#//  b is the ellipse smaller axis 
      
      if (ior.eq.2) then    ! vertical slit
        a=obj.cv
        b=obj.av(il)
        x0=obj.lv(il)
      else                  ! horizontal slit
        a=obj.ch
        b=obj.ah(il)
        x0=obj.lh(il)
      endif
      
      if (a.lt.0) then      ! focal point before the guide entry
        zz=z-obj.frame.size(3)         
      else     ! focal point behind the guide
        zz=z
      endif
      aa=a**2-zz**2
      
      if(a.ne.0) then
         if(aa.le.0) then
           EGUIDE_LAM=0.d0
         return
         else
           aa=sqrt(aa)
         endif
      endif       

# zero deriv.      
      if (id.le.0) then
        if (a.eq.0) then
        EGUIDE_LAM=x0+b*z
      else
          EGUIDE_LAM=b/abs(a)*aa
      endif  
# 1st deriv.      
      else if (id.eq.1) then
        if (a.eq.0) then
        EGUIDE_LAM=b
      else
          EGUIDE_LAM=-b/abs(a)/aa*zz
      endif  
# 2nd deriv.      
      else if (id.eq.2) then
        if (a.eq.0) then
        EGUIDE_LAM=0.d0
      else
          EGUIDE_LAM=-b*abs(a)/aa/aa**2
      endif  
      else
        EGUIDE_LAM=0.d0
      endif
      
      end

      
#-------------------------------------------------------------------------------
      real*4 FUNCTION EGUIDE_A(il,nl,w)
# ellipsa parameter for il-th lamella = smaller axis 
# il ... lamella index, counted from right, right side il=0
# w  ... small axis of the outer profile 
# nl ... number of slits (number of lamellae + 1)
# sign(A) determines which side from the guide center: right/bottom(<0) or left/top(>0) 
#--------------------------------------------------------------------------------
      implicit none
      real*8 w
      integer*4 il,nl
            
      EGUIDE_A=w*(il*1.e0/nl-0.5e0)
      
      end
      

#----------------------------------------------------------------------------
      real*8 FUNCTION EGUIDE_CROSS(kx,kz,x,z,b,a,lmax,glen)
# return path length along z-coordinate to a cross-point with elliptic surface 
# if there are 2 solutions, take the minimum one which is > 0
# return 10^30 if there is no solution 0 < result < lmax
# b      .. smaller ellipsa axis
# a      .. main ellipsa axis 
# lmax   .. limit distance (lamella length)
# x,z    .. starting point (z // guide axis)
# kx,kz  .. ray direction
# glen   .. guide length
# kz is assumed positive and >> kx
#----------------------------------------------------------------------------
      implicit none
      real*8 eps
      parameter (eps=1.d-7)
      real*8 kx,kz,x,z,b,a,lmax,zz,glen   
      real*8 lz,y1,y2,dtm,dnom,t0
            
      if (a.lt.0) then      ! focal point before the guide entry
        zz=z-glen
      else     ! focal point behind the guide
        zz=z
      endif
      
      dnom=(kx*a)**2 + (kz*b)**2
      dtm=(a*b)**2*(dnom-(kx*zz-kz*x)**2)
      t0=x*kx*a**2 + zz*kz*b**2
      if (dtm.lt.0.d0) then  ! no solution
        lz=1.d30
      else   
        y1=(-t0+sqrt(dtm))/dnom
        y2=(-t0-sqrt(dtm))/dnom
        if(y1.le.eps.and.y2.le.eps) then  ! no positive solution
         lz=1.d30
        else 
          if (y1.gt.eps.and.y2.gt.eps) then  ! both positive, take the smaller one
            lz=min(y1,y2)
          else  ! take the positive one
            lz=max(y1,y2)
          endif             
        endif   
      endif  
      if (lz.gt.lmax) lz=1.d30  ! no reflection behind the guide
      EGUIDE_CROSS=lz*kz
            
      end


#---------------------------------------------------------------------
      SUBROUTINE EGUIDE_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,  left(1), right(2), top(3), bottom (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 EGUIDE_CROSS,GUIDE_CROSS,EGUIDE_LAM
      real*8 kx,kz,x,z,a,f,lmax,glen
      real*8 lz(4),ang,t0,n(3)
      integer*4 i
      real*8 oscd,osca
      common /oscbend/ oscd,osca
 

#10    FORMAT(a11,1x,6(1x,G11.5),2(1x,I4),2(1x,G10.4))
#      write(*,10) 'CON START: ',R,K,IH,IV,OBJ.CH
      z=r(3)
      kz=k(3)
      
      t0=obj.frame.size(3)-z  ! time to the guide end
      glen=obj.frame.size(3)
# HORIZONTAL RIGHT:
      f=obj.ch
      kx=k(1)
      lmax=t0
      if (f.eq.0) then
         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)
      else
         a=obj.ah(ih)
         x=r(1)-obj.dlh/2.d0
       lz(2)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
      endif
# HORIZONTAL LEFT:
      if (f.eq.0) then
         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)
      else
         a=obj.ah(ih+1)
         x=r(1)+obj.dlh/2.d0
         lz(1)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
      endif
# VERTICAL BOTTOM:
      f=obj.cv
      kx=k(2)
      lmax=t0
      if (f.eq.0) then
         a=obj.av(iv)
         x=r(2)-obj.dlv/2.d0-obj.lv(iv)
         lz(4)=GUIDE_CROSS(kx,kz,x,z,a,f)
      else
         a=obj.av(iv)
         x=r(2)-obj.dlv/2.d0
         lz(4)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
      endif
# VERTICAL TOP:
      if (f.eq.0) then
         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)
      else
         a=obj.av(iv+1)
         x=r(2)+obj.dlv/2.d0
         lz(3)=EGUIDE_CROSS(kx,kz,x,z,a,f,lmax,glen)
      endif
      
#      write(*,10) 'kz*times: ',LZ(1),LZ(2)
      
      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=EGUIDE_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=EGUIDE_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=EGUIDE_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=EGUIDE_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
      
#      write(*,10) 'lamellae: ',
#     & EGUIDE_LAM(OBJ,0,IH,R(3),1)+OBJ.DLH/2.D0,
#     & EGUIDE_LAM(OBJ,0,IH+1,R(3),1)-OBJ.DLH/2.D0
#      write(*,10) ' CON HIT: ',R,K,IC,OBJ.FRAME.COUNT,DT,Q
#      pause
      
      end
      
#----------------------------------------------------
      SUBROUTINE EGUIDE_GO(obj,r,k,p,t,s)
# GO procedure for elliptic guide (TYP=4)      
# INPUT:   assume R,K at the entry in local coordinates, i.e. R(3)=0 !
# RETURN:  R,K at the exit in local coordinates, P=P*transmission, T=T+passage time
#
      implicit none

      INCLUDE 'structures.inc'
      
      real*8 eps
      parameter (eps=1.d-7)
      record /BENDER/ obj
      real*8 r(3),k(3),p,t,s
      logical*4 BENDER_PASS
      real*8 BENDER_REF      
      integer*4 ih,iv,ic,i
      real*8 dum,kk,pp,tt,dt,q
10    format(a11,1x,6(1x,g11.5),2(1x,i4),2(1x,g10.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
#  iterate through reflections
1     call EGUIDE_CON(obj,r,k,ih,iv,ic,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
     
# 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
#      write(*,10) 'EXIT: ',R,K,I,OBJ.FRAME.COUNT,TT
      return

100   continue
      p=0.d0
#      write(*,10) 'STOP: '
      
      end