src/ness/ness_collimator.f

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

Source module last modified on Wed, 30 Mar 2005, 10:16;
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, 2000   ////
#////                                                              //// 
#//////////////////////////////////////////////////////////////////////
#////
#////  Subroutines describing objects - ALL COLLIMATOR TYPES
#////  Envelope for collimator segments of any kind:
#////  TUBE, SOLLER , GUIDE/BENDER, PARABOLIC GUIDE
#////                          
#//////////////////////////////////////////////////////////////////////

#------------------------------------
      SUBROUTINE BENDER_INIT(obj)
#
      implicit none
      
      INCLUDE 'structures.inc'
      record /BENDER/ obj
      
      if (obj.typ.eq.2.or.obj.typ.eq.3) then
         call PGUIDE_INIT(obj)
      else if (obj.typ.eq.4) then
         call EGUIDE_INIT(obj)
      else
         call GUIDE_INIT(obj)
      endif

      end        

#---------------------------------------------------------------------
      real*8 FUNCTION BENDER_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
      integer*4 id,il,ior
      real*8 PGUIDE_LAM,EGUIDE_LAM,GUIDE_LAM,z
      
      if (obj.typ.eq.2.or.obj.typ.eq.3) then
         BENDER_LAM=PGUIDE_LAM(obj,id,il,z,ior)
      else if (obj.typ.eq.4) then
         BENDER_LAM=EGUIDE_LAM(obj,id,il,z,ior)
      else
         BENDER_LAM=GUIDE_LAM(obj,id,il,z,ior)
      endif
      end


#-------------------------------------------------------------------
      SUBROUTINE QUADREQ(a,b,c,x)
# Solve quadratic equation A*X^2 + B*X + C = 0
# Try to find a solution > EPS=1E-10
# 1) no solution .. return 10^30
# 2) 1 solution  .. return this
# 3) 2 solutions .. return the smaller one
#-------------------------------------------------------------------
      implicit none
      real*8 eps
      parameter (eps=1.d-8)
      real*8 a,b,c,x,x1,x2,det

      if (a.eq.0) then          
        if (abs(b).lt.eps) then 
          goto 20
        else
          x=-c/b
          goto 30
        endif
      else          
        det=b**2-4*a*c
        if (det.eq.0.) then
           x=-b/2./a
           goto 30
        else if (det.lt.0.) then
           goto 20
        else
           det=sqrt(det) 
           x1=(-b+det)/2./a
           x2=(-b-det)/2./a
           if (x1.gt.eps.and.x2.gt.eps) then
              x=min(x1,x2)
           else if (x1.gt.eps) then
              x=x1
           else if (x2.gt.eps) then
              x=x2
           else 
              goto 20
           endif
        endif
      endif 
                  
30    if (x.lt.eps) goto 20
      return  

20    x=1.d30

      end
      
#--------------------------------------------------------
      logical*4 FUNCTION BENDER_PASS(obj,r,ih,iv)
# Checks, whether neutron fits inside any slit and 
# returns slit indices
#
      implicit none
      INCLUDE 'structures.inc'
      integer*4 ih,iv
      logical*4 log1
      real*8 BENDER_LAM
      real*8 r(3),jh,jv,w,h
      record /BENDER/ obj
      real*8 oscd,osca
      common /oscbend/ oscd,osca

1     format(a10,1x,i4,1x,i4,1x,6(g11.4))

      w=2.d0*abs(BENDER_LAM(obj,0,0,r(3),1))
      h=2.d0*abs(BENDER_LAM(obj,0,0,r(3),2))


      jh=((r(1)-oscd-r(3)*osca)/w+0.5)*obj.nlh
      jv=(r(2)/h+0.5)*obj.nlv
      ih=nint(jh-0.5)
      iv=nint(jv-0.5)
#      write(*,1) 'pass',IH,IV,R,jh,jv,-OSCD-R(3)*OSCA
      
      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
      end  


#---------------------------------------------------
      real*8 FUNCTION BENDER_REF(id,obj,q,s)
# returns reflectivity for given momentum transfer Q
# ID identifies which surface is touched
# ID=0  left 
# ID=1  right 
# ID=2  top 
# ID=3  bottom 
#
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      
      integer*4 id
      record /BENDER/ obj
      real*8 q,s
      integer*4 iz,nr
      real*8 z,dq,q1,gamma,r   
      integer*4 m_n(5)
      character*3 m_name(5)
      real*8 m_alpha(128,5), m_ref1(128,5),m_ref2(128,5)            
      common /mirror/ m_alpha,m_ref1,m_ref2,m_n,m_name    

# get critical angle, reflectivity and index to lookup table
      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    
        
# no reflection for Q<0 or gamma=0
      if (gamma.le.0.or.q.lt.0) then
          BENDER_REF=0
          return
      endif   
        
# no lookup table, just step function for 0 < Q < 2*pi*gamma
      if (nr.le.0.or.nr.gt.5) then
          if (q.ge.0.and.q.lt.2*pi*gamma) then                            
             BENDER_REF=r
          else
             BENDER_REF=0                 
          endif 
      else
          q1=q/2/pi/gammani
          dq=(m_alpha(m_n(nr),nr)-m_alpha(1,nr))/(m_n(nr)-1)
          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)* 
     &            (m_ref1(iz+1,nr)-m_ref1(iz,nr))  
          else if (s.lt.0) then
             BENDER_REF=m_ref2(iz,nr)+(z-iz+1)*
     &            (m_ref2(iz+1,nr)-m_ref2(iz,nr))
          else     
             BENDER_REF=0 
          endif 
      endif                         
      end
      
#----------------------------------------------------
      logical*4 FUNCTION BENDER_GO(obj,neui,neuf)
#
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      
      record /BENDER/ obj
      record /NEUTRON/ neui,neuf
      integer*4 i
      real*8 v(3),k(3),r(3),p,t
      real*4 RAN1
      real*8 dj,oscd,osca
      common /oscbend/ oscd,osca
1     format(a10,2x,i8,2x,10(1x,g12.6))
      
#      dbgref=(OBJ.FRAME.NAME(1:5).EQ.'col2 ')
# Convert to local coordinate system and move to the entry
      call SLIT_PRE(obj.frame,neui.r,neui.k,v,k)
      
#      if (dbgref) write(*,1) OBJ.FRAME.NAME,OBJ.FRAME.COUNT,V,K

      do i=1,2
         r(i)=v(i)-v(3)/k(3)*k(i)
      enddo
      r(3)=0.
      p=1.d0
      t=-v(3)/hovm/k(3)
      
      if (obj.typ.lt.0.or.obj.frame.size(3).le.0) goto 700   ! collimator ignored
      
# Make a random shift to simulate oscillating collimator
      oscd=0
      osca=0
      if (obj.oscilate.gt.0) then         
         dj=(RAN1()-0.5)/obj.nlh 
       osca=dj*(obj.w2-obj.frame.size(1))/obj.frame.size(3)
       oscd=dj*obj.frame.size(1)
      endif 
      
      if (obj.typ.eq.0) then
         call SOLLER_GO(obj,r,k,p,t,neui.s)
      else if (obj.typ.eq.1) then
         call GUIDE_GO(obj,r,k,p,t,neui.s)
      else if (obj.typ.eq.2.or.obj.typ.eq.3) then
         call PGUIDE_GO(obj,r,k,p,t,neui.s)
      else if (obj.typ.eq.4) then
         call EGUIDE_GO(obj,r,k,p,t,neui.s)
      else 
         goto 300
      endif      
      if (p.le.0.d0) goto 300
      
700   do i=1,3
         neuf.r(i)=r(i)
         neuf.k(i)=k(i)
      end do          
      neuf.p=neui.p*p
      neuf.t=neui.t+t
      neuf.s=neui.s
      obj.frame.count=obj.frame.count+1      
      BENDER_GO=.true.
      
#      if (dbgref) write(*,1) OBJ.FRAME.NAME,OBJ.FRAME.COUNT,
#     &  NEUF.R,NEUF.K,NEUF.P
#      if (dbgref) pause
      return

300   neuf.p=0 
#      if (dbgref) write(*,1) OBJ.FRAME.NAME,OBJ.FRAME.COUNT,NEUF.P
#      if (dbgref) pause
      BENDER_GO=.false.
      end        

#--------------------------------------------------------------
      SUBROUTINE SOLLER_GO(obj,r,k,p,t)
# GO procedure for a simple collimator (non reflecting, TYP=0)      
# 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 'const.inc'
      INCLUDE 'structures.inc'
      
      record /BENDER/ obj
      real*8 r(3),k(3),p,t
      logical*4 log1, BENDER_PASS
      integer*4 ih,iv,ih1,iv1,i
#1     FORMAT(a10,1x,I4,1x,I4,1x,6(G11.4))

#  check passage through the entry
      log1=BENDER_PASS(obj,r,ih,iv)
#      write(*,1) OBJ.FRAME.NAME,IH,IV,R,K
      
      if (.not.log1) goto 100                  
#  move to the exit
      do i=1,2
       r(i)=r(i)+obj.frame.size(3)/k(3)*k(i)
      enddo        
      r(3)=obj.frame.size(3)
      t=t+r(3)/hovm/k(3)
#  check passage through the same slit at the exit
      log1=(log1.and.BENDER_PASS(obj,r,ih1,iv1))       
#      write(*,1) OBJ.FRAME.NAME,IH1,IV1,R,K
      if ((.not.log1).or.(ih1.ne.ih).or.(iv1.ne.iv)) goto 100
      return
      
# no passage
100   p=0.d0
#      pause
      end