src/ness/nesobj_slit.f

Fortran project RESTRAX, source module src/ness/nesobj_slit.f.

Source module last modified on Wed, 13 Jul 2005, 16:20;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#//////////////////////////////////////////////////////////////////////
#////                                                              //// 
#////  NEutron Scattering Simulation - v.2.0, (c) J.Saroun, 1999   ////
#////                                                              //// 
#//////////////////////////////////////////////////////////////////////
#////
#////  **** Subroutines for object: SLIT ****
#////  
#////  SLIT is parent type for all NESS components
#////  (i) routines must be defined in any descendant
#////  
#////    ** I/O routines **
#////i    SUBROUTINE SLIT_CMD(OBJ)
#////i    SUBROUTINE SLIT_WRITE(OBJ,IU)
#////i    INTEGER*4 FUNCTION SLIT_READ(OBJ,IU,IERR)
#////i    INTEGER*4 FUNCTION SLIT_SET(OBJ,source)
#////i    CHARACTER*(*) FUNCTION SLIT_GET(OBJ,iwhat)
#////  
#////    ** M.C. routines **
#////i    SUBROUTINE SLIT_INIT(OBJ)
#////i    LOGICAL*4 FUNCTION SLIT_GO(OBJ,NEUI,NEUF)
#////
#////    LOGICAL*4 FUNCTION INSIDE(OBJ,R)
#////    SUBROUTINE SLIT_PRE(OBJ,R0,K0,R,K)
#////    SUBROUTINE SLIT_POST(OBJ,R0,K0,R,K)
#////    SUBROUTINE SLIT_PRE1(OBJ,R0,K0,R,K)
#////    SUBROUTINE SLIT_POST1(OBJ,R0,K0,R,K)
#////  
#//////////////////////////////////////////////////////////////////////


#******************* I/O routines *********************
         

#     ------------------------------------------------
      SUBROUTINE SLIT_WRITE(obj,iu)
#     write all setup to IU      
#     ------------------------------------------------
      implicit none
      INCLUDE 'nesobj_slit.inc'
      record /SLIT/ obj
      character*128 SLIT_GET
      integer*4 iu,i

1     format(a)
      write(iu,1)  '['//t_slit// ']'
      do i=1,nlist
         call WRITELINE(slitcomm(i)// '  '//SLIT_GET(obj,i),iu)
      enddo 
      write(iu,1)  'END '//obj.name 
      end
      
#     ----------------------------------------------------
      integer*4 FUNCTION SLIT_READ(obj,iu,ierr)
#     read all setup from IU (input must end with 'END' command)
#     Returns number of read lines, error code is in IERR
#     ----------------------------------------------------
      implicit none
      INCLUDE 'nesobj_slit.inc'
      record /SLIT/ obj
      character*128 source
      integer*4 SLIT_SET
      integer*4 iu,ierr,iline

1     format(a)
      ierr=0
      iline=0
      source= ' '
      do while (source(1:3).ne. 'END'.and.ierr.eq.0)
        read(iu,1,err=100,iostat=ierr) source
        ierr=SLIT_SET(obj,source)
        call MKUPCASE(source(1:3))
        if (ierr.eq.0) iline=iline+1
      enddo 
100   SLIT_READ=iline

      end
      

#     ------------------------------------------------
      integer*4 FUNCTION SLIT_SET(obj,source)
#     ------------------------------------------------
      implicit none

      INCLUDE 'const.inc'      
      INCLUDE 'nesobj_slit.inc'
      
      record /SLIT/ obj,dum
      character*(*) source
      character*128 values
      integer*4 i,j,ORDCOM,ierr,s,l
      ierr=0
#*** find first parameter as variable name
      s=1
1     format(a)
      call FINDPAR(source,1,s,l)
      SLIT_SET=0
      if (l.le.0) return    ! ignore empty string      
      values=source(s+l:len(source))
      i=ORDCOM(source(s:s+l-1),slitcomm,nlist)
      if(i.gt.0.and.i.le.6) then
        dum=obj
        call BOUNDS(values,s,l)
        values=values(s:s+l-1)
        if (i.eq.1) then          
          read(values,1,err=100,iostat=ierr) obj.name      
        else if (i.eq.2) then
          read(values,*,err=100,iostat=ierr) (obj.size(j),j=1,3)
        else if (i.eq.3) then
          read(values,*,err=100,iostat=ierr) obj.shape
        else if (i.eq.4) then
          read(values,*,err=100,iostat=ierr) obj.dist,obj.axi,
     *    obj.axv
          obj.axi=obj.axi/rad
          obj.axv=obj.axv/rad 
        else if (i.eq.5) then
          read(values,*,err=100,iostat=ierr) (obj.gon(j),j=1,3)
          do j=1,3
             obj.gon(j)=obj.gon(j)/rad
          enddo   
        else if (i.eq.6) then
          read(values,*,err=100,iostat=ierr) (obj.sta(j),j=1,3)
        endif
      endif     ! ignores any other string not recognized as variable 
      if (ierr.ne.0) then
         obj=dum
         ierr=-1      !  IO warning
      endif   
      SLIT_SET=ierr
      return
      
100   SLIT_SET=-2     !  IO error
      obj=dum
      end
      

#     ------------------------------------------------
      character*(*) FUNCTION SLIT_GET(obj,iwhat)
#     ------------------------------------------------
      implicit none
      INCLUDE 'const.inc'      
      INCLUDE 'nesobj_slit.inc'
      
      record /SLIT/ obj
      character*128 target
      integer*4 j,iwhat

1      format(a)
2      format(3(g13.5,1x))
3      format(i5) 

      target= ' '
      if (iwhat.gt.0.and.iwhat.le.6) then
        if (iwhat.eq.1) then
           write(target,1) obj.name      
        else if (iwhat.eq.2) then
           write(target,2) (obj.size(j),j=1,3)
        else if (iwhat.eq.3) then
           write(target,3) obj.shape
        else if (iwhat.eq.4) then
           write(target,2) obj.dist, obj.axi/deg,obj.axv/deg
        else if (iwhat.eq.5) then
           write(target,2) (obj.gon(j)/deg,j=1,3)
        else if (iwhat.eq.6) then
           write(target,2) (obj.sta(j),j=1,3)
        endif
      else
           SLIT_GET= ' '
      endif         
      SLIT_GET=target
      end
      
#********************* M.C. routines **************************

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

        INCLUDE 'nesobj_slit.inc'
      
      record /SLIT/ obj
      real*8 r(3)
      logical*4 log1
      
      if (obj.shape.eq.3) then                      ! rectangle
         log1=(
     1     (abs(r(1)).le.obj.size(1)/2.).and.
     2     (abs(r(2)).le.obj.size(2)/2.).and.
     3     (abs(r(3)).le.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).le.1).and.
     3     (abs(r(3)).le.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).le.1).and.
     3     (abs(r(2)).le.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).le.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 'nesobj_slit.inc'
      record /SLIT/ obj
      real*8 sta(3),pos(3),r(3,3),r1(3,3),r2(3,3),r3(3,3),aux(3,3)
        real*8 dum   ! ,DETERM
        logical*4 map0(3)
        integer*4 i,j
        data map0 /.true.,.true.,.true./

# 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))

#/// 3 transformaton matrices were created:
#/// axis vs. preceding axis (R)
#/// object vs. axis  (OBJ.ROT1=R3*R2*R1)
#/// object vs. preceding axis (OBJ.ROT=ROT1*R)
    
        call M3XM3(1,r2,r1,aux)
        call M3XM3(1,r3,aux,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)=.false.
        obj.map1(i)=.true.
        if (1-abs(obj.rot1(i,i)).lt.1.0d-8) obj.map1(i)=.false.
60      continue

        
        do i=1,3
          pos(i)=obj.sta(i)
          sta(i)=obj.sta(i)
        enddo
        pos(3)= obj.sta(3)+obj.dist  


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

      
      obj.count=0    ! counter reset to zero

        dum=0
        obj.simple=.false.
        do i=1,3
          dum=dum+abs(obj.sta(i))
          dum=dum+abs(obj.gon(i))
        enddo  
        if(dum+abs(obj.axv).eq.0) obj.simple=.true. 

#        write(*,*) OBJ.NAME
#        write(*,*) POS
#        write(*,*) OBJ.POS
#        write(*,*) DETERM(R,3,AUX)
#        write(*,*) DETERM(OBJ.ROT,3,AUX),DETERM(OBJ.ROT1,3,AUX)
#        write(*,*) DETERM(R1,3,AUX),DETERM(R2,3,AUX),DETERM(R3,3,AUX)        
#        pause


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

        INCLUDE 'const.inc'      
        INCLUDE 'nesobj_slit.inc'

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

#/// 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):
        
        neuf=neui         
        call SLIT_PRE(obj,neui.r,neui.k,v,k)

#/// move neutron to the centre of the SLIT:
      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_POST(obj,r,k,neuf.r,neuf.k)
          obj.count=obj.count+1
      else 
          log1=.false.
          neuf.p=0
      end if

      SLIT_GO=log1
         
      return
      end 
      
#

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

       INCLUDE 'nesobj_slit.inc'
      
      record /SLIT/ obj
      real*8 r0(3),k0(3),r(3),k(3),v(3)
#/// Neutron variables are originaly expressed in previous axis coordinates.
#

      if (.not.obj.simple) then
#
            call M3xV3_M(1,obj.map,obj.rot,r0,v)
        call M3xV3_M(1,obj.map,obj.rot,k0,k)
        call V3AV3(-1,v,obj.pos,r)
      else
          r(1)=obj.rot(1,1)*r0(1)+obj.rot(1,3)*r0(3)-obj.pos(1)
          r(2)=r0(2)
          r(3)=obj.rot(3,1)*r0(1)+obj.rot(3,3)*r0(3)-obj.pos(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)         
      endif

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

        INCLUDE 'nesobj_slit.inc'
      
      record /SLIT/ obj
      real*8 r0(3),k0(3),r(3),k(3),v(3)
      integer*4 i
#
      if (.not.obj.simple) then
        call V3AV3(1,r0,obj.sta,v)
          call M3xV3_M(-1,obj.map1,obj.rot1,v,r)
          call M3xV3_M(-1,obj.map1,obj.rot1,k0,k)
      else
        do i=1,3
          k(i)=k0(i)
          r(i)=r0(i)
        enddo
      endif
      return
      end