src/ness/ness_obj.f

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

Source module last modified on Sat, 21 May 2005, 15:30;
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 - SLIT, SOURCE, DETECTOR
#////  
#////                          
#//////////////////////////////////////////////////////////////////////


#
      logical*4 FUNCTION INSIDE(obj,r)
#
#
      implicit none

      INCLUDE 'structures.inc'
      
      record /SLIT/ obj
      real*8 r(3)
      logical*4 log1

      if (obj.shape.eq.3) then                      ! rectangle
         log1=(
     1     (abs(r(1)).lt.obj.size(1)/2.).and.
     2     (abs(r(2)).lt.obj.size(2)/2.).and.
     3     (abs(r(3)).lt.obj.size(3)/2.))      

      else if (obj.shape.eq.2) then                 ! disc
         log1=(
     1     (((r(1)*2./obj.size(1))**2+
     2     (r(2)*2./obj.size(2))**2).lt.1).and.
     3     (abs(r(3)).lt.obj.size(3)/2.)) 
     

      else if (obj.shape.eq.1) then                 ! cylinder
         log1=(
     1     (((r(1)*2./obj.size(1))**2+
     2     (r(3)*2./obj.size(3))**2).lt.1).and.
     3     (abs(r(2)).lt.obj.size(2)/2.))      
                 

      else if (obj.shape.eq.0) then                 ! ellipsoid
         log1=(
     1     ((r(1)*2./obj.size(1))**2+
     2      (r(2)*2./obj.size(2))**2+
     3      (r(3)*2./obj.size(3))**2).lt.1)

      else 
         log1=.false.
      end if
        
      INSIDE=log1
      
# shape = 0 ... ellipsoid
#         1 ... vertical cylinder (axis//y)
#         2 ... disc plate (axis//z)
#         3 ... rectangular     

      return 
      end


      
#
      SUBROUTINE SLIT_INIT(obj)
#
      implicit none

        INCLUDE 'structures.inc'
      
      
      record /SLIT/ obj
      real*8 sta(3),pos(3),r(3,3),r0(3,3),r1(3,3),
     1         r2(3,3),r3(3,3)   
        integer*4 i,j
        
#
      pos(1)=0    ! position of the own axis vs. the preceding one
      pos(2)=0                     
      pos(3)=obj.dist   

#/// POS = position of the object(=SLIT) vs. axis of the preceding object
#
      do 10 i=1,3
        pos(i)=obj.sta(i)+pos(i)  
          sta(i)=obj.sta(i)
10      continue
      obj.count=0
           
# rot. matrix for AXI 
      do 20 i=1,3
      do 20 j=1,3
       if (i.eq.j) then
          r2(i,j)=1
       else
          r2(i,j)=0   
       endif   
20      continue
        r2(1,1)=cos(obj.axi)
        r2(3,3)=cos(obj.axi)
        r2(1,3)=-sin(obj.axi)
        r2(3,1)=+sin(obj.axi)
        
# rot. matrix for AXV 
      do 25 i=1,3
      do 25 j=1,3
       if (i.eq.j) then
          r1(i,j)=1
       else
          r1(i,j)=0   
       endif   
25      continue
        r1(2,2)=cos(obj.axv)
        r1(3,3)=cos(obj.axv)
        r1(2,3)=+sin(obj.axv)
        r1(3,2)=-sin(obj.axv)

# rotation matrix (R) for current axis with respect to the previous one        
        call M3XM3(1,r1,r2,r)    
        
        
# rot. matrix for GON(1)  around axis 2
      do 30 i=1,3
      do 30 j=1,3
       if (i.eq.j) then
          r1(i,j)=1
       else
          r1(i,j)=0   
       endif   
30      continue
        r1(1,1)=cos(obj.gon(1))
        r1(3,3)=cos(obj.gon(1))
        r1(1,3)=-sin(obj.gon(1))
        r1(3,1)=+sin(obj.gon(1))
        
# rot. matrix for GON(2)  around axis 1 
      do 40 i=1,3
      do 40 j=1,3
       if (i.eq.j) then
          r2(i,j)=1
       else
          r2(i,j)=0   
       endif   
40      continue
        r2(2,2)=cos(obj.gon(2))
        r2(3,3)=cos(obj.gon(2))
        r2(2,3)=+sin(obj.gon(2))
        r2(3,2)=-sin(obj.gon(2))        
        
# rot. matrix for GON(3)  around axis 2 again 
      do 50 i=1,3
      do 50 j=1,3
       if (i.eq.j) then
          r3(i,j)=1
       else
          r3(i,j)=0   
       endif   
50      continue
        r3(1,1)=cos(obj.gon(3))
        r3(3,3)=cos(obj.gon(3))
        r3(1,3)=-sin(obj.gon(3))
        r3(3,1)=+sin(obj.gon(3))

#/// two transformaton matrices are created:
#/// object vs. axis coordinates (ROT1)
#/// object vs. axis of the preceding object (ROT)
    
        call M3XM3(1,r2,r1,r0)
        call M3XM3(1,r3,r0,obj.rot1)
        call M3XM3(1,obj.rot1,r,obj.rot)        
        
      do 60 i=1,3
        obj.map(i)=.true.
        if (1-abs(obj.rot(i,i)).lt.1.0d-8) obj.map(i)=0
        obj.map1(i)=.true.
        if (1-abs(obj.rot1(i,i)).lt.1.0d-8) obj.map1(i)=0
60      continue

# /// transform POS and STA to the object coordinates:
 
      call M3XV3(1,obj.map1,obj.rot1,pos,obj.pos)  
      call M3XV3(1,obj.map1,obj.rot1,sta,obj.sta)                     

      return
      end

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

        INCLUDE 'const.inc'
        INCLUDE 'structures.inc'

      record /SLIT/ obj
      record /NEUTRON/ neui,neuf
      logical*4 log1,INSIDE
      real*8 v(3),k(3),r(3)
        integer*4 i
                 
        log1=(neui.p.gt.0.d0)

#/// At the begining, NEUI.R,K is in the axis coordinates of the
#

#/// NEUI.K and NEUI.R must be transformed to the object coordinates
#/// (including rotation and linear shift specified by GON(3) and STA(3):
        
        call SLIT_PRE1(obj,neui.r,neui.k,v,k)

#/// move neutron to the centre of the OBJ:
      neuf.t=neui.t-v(3)/hovm/k(3)
      do 10 i=1,2
10    r(i)=v(i)-v(3)/k(3)*k(i)
        r(3)=0.
    
      if (INSIDE(obj,r)) then
      
#/// At the and, NEUF.K and NEUF.R must be in the axis coordinates 
#/// of the object (i.e. without rotation and shift by GON(3) and STA(3))
#             CALL SLIT_POST1(OBJ,R,K,NEUF.R,NEUF.K)
            do i=1,3
               neuf.r(i)=r(i)
               neuf.k(i)=k(i)
            end do                     
          neuf.p=neui.p
          neuf.s=neui.s
          obj.count=obj.count+1
      else 
          log1=.false.
          neuf.p=0
      end if
      SLIT_GO=log1
         
      return
      end 

# //////////////////  End of definition - SLIT  ///////////////////



#
      SUBROUTINE SLIT_POST(obj,r0,k0,r,k)
#
      implicit none

        INCLUDE 'structures.inc'
      
      record /SLIT/ obj
      real*8 r0(3),k0(3),r(3),k(3),v(3)
      
      call V3AV3(1,r0,obj.sta,v)
        call M3XV3(-1,obj.map1,obj.rot1,v,r)
        call M3XV3(-1,obj.map1,obj.rot1,k0,k)

      
      return
      end   

#
      SUBROUTINE SLIT_POST1(obj,r0,k0,r,k)
#
#       Use it if you are sure that STA=(0,0,0) and
#       ROT1(2,2)=1 (=> ROT(i,2)=0)
#
      implicit none

        INCLUDE 'structures.inc'
      
      record /SLIT/ obj
      real*8 r0(3),k0(3),r(3),k(3)
      
        r(1)=obj.rot1(1,1)*r0(1)+obj.rot1(3,1)*r0(3)
        r(2)=r0(2)
        r(3)=obj.rot1(1,3)*r0(1)+obj.rot1(3,3)*r0(3)
        k(1)=obj.rot1(1,1)*k0(1)+obj.rot1(3,1)*k0(3)
        k(2)=k0(2)
        k(3)=obj.rot1(1,3)*k0(1)+obj.rot1(3,3)*k0(3)        
      return
      end   
#
      SUBROUTINE SLIT_PRE(obj,r0,k0,r,k)
#
      implicit none

        INCLUDE 'structures.inc'
      
      record /SLIT/ obj
      real*8 r0(3),k0(3),r(3),k(3),v(3)
      
      call M3XV3(1,obj.map,obj.rot,r0,v)
      call M3XV3(1,obj.map,obj.rot,k0,k)
      call V3AV3(-1,v,obj.pos,r)

      return
      end

#
      SUBROUTINE SLIT_PRE1(obj,r0,k0,r,k)
#
#       Use it if you are sure that POS(2)=0 and
#
#
      implicit none

        INCLUDE 'structures.inc'
      
      record /SLIT/ obj
      real*8 r0(3),k0(3),r(3),k(3)
        
        r(1)=obj.rot(1,1)*r0(1)+obj.rot(1,3)*r0(3)
        r(2)=r0(2)
        r(3)=obj.rot(3,1)*r0(1)+obj.rot(3,3)*r0(3)
        k(1)=obj.rot(1,1)*k0(1)+obj.rot(1,3)*k0(3)
        k(2)=k0(2)
        k(3)=obj.rot(3,1)*k0(1)+obj.rot(3,3)*k0(3)         
      r(1)=r(1)-obj.pos(1)
      r(3)=r(3)-obj.pos(3)
      
      return
      end



# ////////////////// Definition of the SLIT object ///////////////////



#--------------------------------------------------
      logical*4 FUNCTION DETECT_GO(det,neui,neuf)
# just a rectangular detector area, or, 
# if DET.ALPHA>0 => ARRAY of cyllindrical detectors      
#
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      logical*4 log1, SLIT_GO,SAM_BOARDER 
      real*8 kk,r(3),v(3),k(3),t1,t2,lam,z
      real*8 p(0:64),ksi(0:64)
      real*4 RAN1,rn,rn1
      integer*4 i,j
      record /DETECTOR/ det
      record /NEUTRON/ neui,neuf

      if(det.alpha.eq.0) then
       log1=SLIT_GO(det.frame,neui,neuf)
      else 
         rn=RAN1()
         rn1=RAN1()
         call SLIT_PRE(det.frame,neui.r,neui.k,v,k)    
         kk=sqrt(k(1)**2+k(2)**2+k(3)**2)
         lam=2*pi/kk                 
         p(0)=0.d0
         ksi(0)=0.d0
         do i=2,3
           r(i)=v(i)
         enddo               
         do j=1,det.nd
           r(1)=v(1)+(det.frame.size(1)+det.space)*
     &               (j-(det.nd+1.d0)/2.d0)
           if (SAM_BOARDER(det.frame,r,k,t1,t2)) then
             ksi(j)=(t2-t1)*(rn+0.5)
             p(j)=p(j-1)+(1.d0-exp(-det.alpha*lam*ksi(j)*kk)) 
           else 
             p(j)=p(j-1)
             ksi(j)=0.
           endif
         enddo
         if (p(det.nd).lt.1.e-10) goto 99            
         z=p(det.nd)*(rn1+0.5)
         j=0
         do while (p(j).le.z.and.j.lt.det.nd) 
           j=j+1
         enddo                     
         do i=1,3
           r(i)=v(i)+(t1+ksi(j))*k(i)
         end do  
         call SLIT_POST(det.frame,r,k,neuf.r,neuf.k)
         neuf.t=neui.t+(t1+ksi(j))/hovm
         neuf.p=neui.p*p(det.nd)
         neuf.s=neui.s
         log1=(neuf.p.gt.0.d0)
         if(log1) det.frame.count=det.frame.count+1
      endif
      DETECT_GO=log1
      return
        
99    DETECT_GO=.false.       
      end