src/ness/ness_pguide.f

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

Source module last modified on Tue, 29 Mar 2005, 23:55;
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 - PARABOLIC GUIDE
#////  
#////                          
#//////////////////////////////////////////////////////////////////////

#---------------------------------------------------------------------
      SUBROUTINE PGUIDE_INIT(obj)
#----------------------------------------------------------------------
      implicit none
      INCLUDE 'structures.inc'
      
      real*4 PGUIDE_A
      real*4 xx
      real*8 f,zl,dif,a,h1,h2,v1,v2
      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      
# parabolic 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 parabola, flat walls
         obj.ch=0.d0
      else if (h2.gt.h1) then
       dif=h2**2-h1**2
       a=dif/4.d0/obj.frame.size(3)
       obj.ch=a-h1**2*obj.frame.size(3)/dif
      else if (h2.lt.h1) then
       dif=h1**2-h2**2
       a=dif/4.d0/obj.frame.size(3)
       obj.ch=h2**2*obj.frame.size(3)/dif-a
      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*(obj.w2-obj.frame.size(1))/obj.frame.size(3)
         obj.lh(i)=zl*obj.frame.size(1)
        enddo
      else   ! parabolic lamellas, AH & LH are parameters & lengths, respectively
      if (f.gt.0) f=f+obj.frame.size(3)
        do i=0,obj.nlh
           obj.ah(i)=PGUIDE_A(i,obj.nlh,obj.frame.size(1),f)
        enddo
        if (obj.typ.eq.3.and.obj.nlh.gt.1) then   ! set optimum lengths of lamellae
          do i=0,obj.nlh
          xx=abs(i-0.5*obj.nlh)
          if (xx.eq.0) then
             obj.lh(i)=obj.frame.size(3)
          else
             obj.lh(i)=min(2.0*abs(obj.ch)/xx,obj.frame.size(3))
          endif   
#      write(*,*) 'lam: ',I,'  ',OBJ.LH(I),'  ',
#     &      XX*OBJ.FRAME.SIZE(1)/OBJ.NLH
          enddo
      else
          do i=0,obj.nlh
           obj.lh(i)=obj.frame.size(3)
          enddo   
      endif  
      endif
      
# VERTICAL      
# parabolic 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=v2**2-v1**2
       a=dif/4.d0/obj.frame.size(3)
       obj.cv=a-v1**2*obj.frame.size(3)/dif
      else if (v2.lt.v1) then
       dif=v1**2-v2**2
       a=dif/4.d0/obj.frame.size(3)
       obj.cv=v2**2*obj.frame.size(3)/dif-a
      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.d0/obj.nlv - 0.5d0
         obj.av(i)=zl*(obj.h2-obj.frame.size(2))/obj.frame.size(3)
         obj.lv(i)=zl*obj.frame.size(2)
        enddo
      else   ! parabolic lamellas, AH & LH are parameters & lengths, respectively
      if (f.gt.0) f=f+obj.frame.size(3)
        do i=0,obj.nlv
           obj.av(i)=PGUIDE_A(i,obj.nlv,obj.frame.size(2),f)
        enddo
        if (obj.typ.eq.3.and.obj.nlv.gt.1) then   ! set optimum lengths of lamellae
          do i=0,obj.nlv
          xx=abs(i-0.5*obj.nlv)
          if (xx.eq.0) then
             obj.lv(i)=obj.frame.size(3)
          else
             obj.lv(i)=min(2.0*abs(obj.cv)/xx,obj.frame.size(3))
          endif   
          enddo
      else
          do i=0,obj.nlv
           obj.lv(i)=obj.frame.size(3)
          enddo   
      endif  
      endif
      
      end

#---------------------------------------------------------------------
      real*8 FUNCTION PGUIDE_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,zz,aa,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
      
      if (f.lt.0) then      ! focal point before the guide
        zz=z-f+abs(a)         
      else if (f.gt.0) then    ! focal point behind the guide
        zz=-z+f+obj.frame.size(3)+abs(a)
      else
        zz=0
      endif
      aa=sign(1.d0,a)*sqrt(abs(a))
            
      if (zz.le.0.d0.and.f.ne.0) then
        PGUIDE_LAM=0.d0
      return
      endif       

# zero deriv.      
      if (id.le.0) then
        if (f.eq.0) then
        PGUIDE_LAM=x0+a*z
      else
          PGUIDE_LAM=2.d0*aa*sqrt(zz)
      endif  
# 1st deriv.      
      else if (id.eq.1) then
        if (f.eq.0) then
        PGUIDE_LAM=a
      else
          PGUIDE_LAM=-aa*sign(1.d0,f)/sqrt(zz)
      endif  
# 2nd deriv.      
      else if (id.eq.2) then
        if (f.eq.0) then
        PGUIDE_LAM=0.d0
      else
          PGUIDE_LAM=-aa/sqrt(zz)/zz/2.d0
      endif  
      else
        PGUIDE_LAM=0.d0
      endif
      
      end

      
#-------------------------------------------------------------------------------
      real*4 FUNCTION PGUIDE_A(il,nl,w,f)
# parabola parameter for il-th lamella
# il ... lamella index, counted from right, right side il=0
# f  ... focal distance
# w  ... width of the entry 
# 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 f,w,z
      real*4 xx
      integer*4 il,nl
            
      xx=w*(il*1.e0/nl-0.5d0)
      if (abs(xx).le.1.e-10) then
         PGUIDE_A=0.d0
      else
         PGUIDE_A=sign(1.e0,xx)*(sqrt(f**2+xx**2)-abs(f))/2.e0
      endif
      z=sign(1.e0,xx)*(sqrt(f**2+xx**2)-abs(f))/2.e0
      
      end
      

#----------------------------------------------------------------------------
      real*8 FUNCTION PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
# 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 < result < lmax
# a      .. parabola parameter
# f      .. focal distance from guide entry (origin of z coordinate) 
# lmax   .. limit distance (lamella length)
# x,z    .. starting point (z // guide axis)
# kx,kz  .. ray direction
# kz is assumed positive and >> kx
#----------------------------------------------------------------------------
      implicit none
      real*8 eps
      parameter (eps=1.d-7)
      real*8 kx,kz,x,z,a,f,lmax     
      real*8 lz,y1,y2,tang,s,aa,dtm

#10    FORMAT(a10,1x,8(1x,G13.7))
#      write(*,10) 'cross',kx,kz,x,z,a,f,lmax
            
      if (abs(kx).lt.1.d-6*kz) then   ! beam along z
        if (a.gt.eps) then
          lz=f+sign(1.d0,f)*(a-x**2/a/4.d0)-z
      else
        lz=1.d30
      endif
      else 
        tang=kz/kx
        dtm=a*(1+tang**2) + sign(1.d0,f)*(x*tang+f-z)
      if (dtm.lt.0.d0) then
         lz=1.d30
      else   
           s=2*sign(1.d0,f)*sign(1.d0,kx)
           aa=sqrt(a)   
           y1=(s*aa*(-aa*abs(tang)+sqrt(dtm))-x)*tang
           y2=(s*aa*(-aa*abs(tang)-sqrt(dtm))-x)*tang
#      write(*,10) 'cross',Y1,Y2,dtm
           if(y1.le.eps.and.y2.le.eps) then
            lz=1.d30
           else 
              if (y1.gt.eps.and.y2.gt.eps) then
                 lz=min(y1,y2)
              else 
                 lz=max(y1,y2)
              endif             
           endif   
      endif  
      endif
#      write(*,10) 'cross',Y1,Y2,LZ,lmax
#      pause
      if (lz.gt.lmax) lz=1.d30
      PGUIDE_CROSS=lz
            
      end


#---------------------------------------------------------------------
      SUBROUTINE PGUIDE_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 PGUIDE_CROSS,GUIDE_CROSS,PGUIDE_LAM
      real*8 kx,kz,x,z,a,f,lmax
      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
# 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=abs(obj.ah(ih))
         x=r(1)-obj.dlh/2.d0
       if (f.gt.0) f=f+obj.frame.size(3)               
         if (f.lt.0) lmax=obj.lh(ih)-z
       lz(2)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
      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=abs(obj.ah(ih+1))
         x=r(1)+obj.dlh/2.d0
         if (f.lt.0) lmax=obj.lh(ih+1)-z
         lz(1)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
      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=abs(obj.av(iv))
         x=r(2)-obj.dlv/2.d0
         if (f.gt.0) f=f+obj.frame.size(3)      
         if (f.lt.0) lmax=obj.lv(iv)-z
         lz(4)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
      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=abs(obj.av(iv+1))
         x=r(2)+obj.dlv/2.d0
         if (f.lt.0) lmax=obj.lv(iv+1)-z
         lz(3)=PGUIDE_CROSS(kx,kz,x,z,a,f,lmax)
      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=PGUIDE_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=PGUIDE_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=PGUIDE_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=PGUIDE_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: ',
#     & PGUIDE_LAM(OBJ,0,IH,R(3),1)+OBJ.DLH/2.D0,
#     & PGUIDE_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 PGUIDE_GO(obj,r,k,p,t,s)
# GO procedure for parabolic guide (TYP=2)      
# 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
      real*8 lx,xx,fx,sx,sk,ld,z,detm,dth,dtv
      
#      LOGICAL*4 rep
#      rep=(OBJ.FRAME.NAME(1:5).EQ.'guide'.AND.OBJ.FRAME.count.GT.10000)
#      rep=(rep.AND..NOT.OBJ.FRAME.NAME(1:6).EQ.'guide_')
#10    FORMAT(a10,1x,6(1x,G13.7),3(1x,I4),2(1x,G10.4))
#11    FORMAT(a10,1x,8(1x,G13.7))
#      if (rep) write(*,10) 'guide entry ',OBJ.CH,R
      
      if (obj.typ.eq.3.and.(obj.ch.gt.0.or.obj.cv.gt.0)) then
        ld=obj.frame.size(3)-r(3)  ! distance to the guide exit        
# try horizontal
        if (obj.ch.gt.0.and.obj.nlh.gt.2) then  ! focus is behind exit
          xx=r(1)
        sx=sign(1.d0,xx)
        sk=sign(1.d0,k(1))
        fx=2.d0*obj.ch*obj.frame.size(1)/obj.nlh
        lx=obj.frame.size(3)
        if(abs(xx).gt.eps) lx=min(fx/abs(xx),lx)  ! "optimum" lamella length
#      if (rep) write(*,10) 'lam1 ',xx,fx,lx
          if (lx.lt.ld) then
          z=ld/k(3)-xx/k(1)
          detm=z**2+4.d0*(ld*xx-fx*sx)/k(1)/k(3)
            dth=(z+sx*sk*sqrt(detm))/2.d0    ! positive solution of quadratic equation
        else
          dth=0.d0
        endif
      else
        dth=0.d0
      endif
# try vertical
        if (obj.cv.gt.0.and.obj.nlv.gt.2) then  ! focus is behind exit
          xx=r(2)
        sx=sign(1.d0,xx)
        sk=sign(1.d0,k(2))
        fx=2.d0*obj.cv*obj.frame.size(2)/obj.nlv
        lx=obj.frame.size(3)
        if(abs(xx).gt.eps) lx=min(fx/abs(xx),lx)  ! "optimum" lamella length
          if (lx.lt.ld) then
          z=ld/k(3)-xx/k(2)
          detm=z**2 + 4.d0*(ld*xx-fx*sx)/k(2)/k(3)
            dtv=(z+sx*sk*sqrt(detm))/2.d0    ! positive solution of quadratic equation
        else
          dtv=0.d0
        endif
      else
        dtv=0.d0
      endif
      dt=min(dth,dtv)
#
      if (dt.gt.0) then
        do i=1,3
          r(i)=r(i)+k(i)*dt
        enddo
        t=t+dt
      endif
      endif
#      if (rep) write(*,10) 'lam2 ',DTH,DTV,DT
                   
#      if (rep) write(*,10) 'start',R,K
#  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
#      if (rep) write(*,10) 'start',R,K

#  iterate through reflections
1     call PGUIDE_CON(obj,r,k,ih,iv,ic,dt,q)
#      if (rep) write(*,10) 'bounce',R,K,IH,IV,IC,DT,Q
      tt=tt+dt
# debug: prevent infinite loops      
#      I=I+1
#      IF (I.GT.100000) THEN
#
#         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

#      if (rep) write(*,11) 'OK',R,K,PP,TT
#      if (rep) 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
#      if (rep) write(*,10) 'failed',R,K,IH,IV
#      if (rep) pause
      p=0.d0
      
      end