src/ness/ness_frw.f

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

Source module last modified on Mon, 23 May 2005, 17:53;
HTML image of Fortran source automatically generated by for2html on Mon, 23 May 2005, 21:29.


                  
#---------------------------------------------------------------
      logical FUNCTION TAS1_GO2()
#     trace primary TAS spectrometer from the source
#---------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
      logical BENDER_GO,CRYST_GO2,SOURCE_GO
      logical log  ! ,SAM_BOARDER
#      REAL*8 T1,T2
      common /neuif/ neui,neuf,neui1,neuf1

      log=.true.
#      LOG=SAM_BOARDER(SAM,NEUI.R,NEUI.K,T1,T2)
      neui1=neui
#      LOG=(LOG.AND.NEUI1.P.GT.0) 
      if(log) log=(log.and.SOURCE_GO(sou,neui1,neu1))
      if(log) log=(log.and.BENDER_GO(gdea,neu1,neu))
      if(log) log=(log.and.BENDER_GO(guide,neu,neu1))
      if(log) log=(log.and.BENDER_GO(sol1,neu1,neu))
      if(log) log=(log.and.CRYST_GO2(mon,neu,neu1))
      if (mon.nh.eq.0) then
          neui=neu1
          TAS1_GO2=log
          return
      endif            
      if(log) log=(log.and.BENDER_GO(sol2a,neu1,neu))
      if(log) log=(log.and.BENDER_GO(sol2,neu,neui))
      if(flipm.eq.1) neui.s=-neui.s 
      TAS1_GO2=log
      end  

#---------------------------------------------------------------
      logical FUNCTION FLUX_GO2()
#     simulate incident flux, start at the source
#---------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu
      logical SLIT_GO,TAS1_GO2
      logical log
      common /neuif/ neui,neuf,neui1,neuf1
        
      log= TAS1_GO2() 
      if (mon.nh.eq.0) then
          FLUX_GO2=log
          return
      endif            
      neu=neui
      if(log) log=(log.and.SLIT_GO(sam,neu,neui)) 
      FLUX_GO2=log
      end  

#---------------------------------------------------------------        
      logical FUNCTION DIFF_GO2()
#     trace from the source to the detector with pwd. sample
#---------------------------------------------------------------
      implicit none      

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1 
      logical BENDER_GO,SLIT_GO,TAS1_GO2,PWD_GO
      logical log          
      common /neuif/ neui,neuf,neui1,neuf1
      
      log=TAS1_GO2()
      if(log) log=(log.and.PWD_GO(sam,neui,neuf,stp.q*stp.ss)) 
      neu1=neuf
      if(flipa.eq.1) neu1.s=-neu1.s 
      if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
      if(log) log=(log.and.SLIT_GO(det,neu,neuf1))      
      DIFF_GO2=log
      end

#---------------------------------------------------------------        
      logical FUNCTION MONIT_GO2()
#     trace from the source to the monitor at position IMONIT
#---------------------------------------------------------------
      implicit none      

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      
      record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1 
      logical BENDER_GO,SLIT_GO,CRYST_GO2,SOURCE_GO,VAN_GO,VAN_TRANS
      logical log 
      integer*4 m   
      real*8 ll,k0
      integer*4 i
      common /neuif/ neui,neuf,neui1,neuf1

      log=.true.
      neui1=neui
      log=(neui1.p.gt.0) 
      m=imonit
      if(log) log=(log.and.SOURCE_GO(sou,neui1,neu1))
      if (m.eq.0) goto 101      
      if(log) log=(log.and.BENDER_GO(gdea,neu1,neu))
      if (m.eq.1) goto 100
      if(log) log=(log.and.BENDER_GO(guide,neu,neu1))
      if (m.eq.2) goto 101
      if(log) log=(log.and.BENDER_GO(sol1,neu1,neu))
      if (m.eq.3) goto 100
      if (.not.log) goto 111    
      if(log) log=(log.and.CRYST_GO2(mon,neu,neu1))
      if (m.eq.4) goto 101
      if(log) log=(log.and.BENDER_GO(sol2a,neu1,neu))
      if (m.eq.5) goto 100
      if(log) log=(log.and.BENDER_GO(sol2,neu,neui))
      if (m.eq.6) then
         neu1=neui
         goto 101
      endif   
      if(flipm.eq.1) neui.s=-neui.s 
      if(m.eq.7) then
        if(log) log=(log.and.VAN_TRANS(sam,neui,neuf)) 
        ll=(sol3.frame.dist-neuf.r(3))
        do i=1,2
          neuf.r(i)=neuf.r(i)+ll*neuf.k(i)/neuf.k(3)        
        enddo
        neu=neuf
        goto 100
      endif  
      if (.not.log) goto 111      
      if(log) log=(log.and.VAN_GO(sam,neui,neuf,stp.q*stp.ss)) 
      neu1=neuf
      if(flipa.eq.1) neu1.s=-neu1.s 
      if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
      if (m.eq.8) goto 100
      if(log) log=(log.and.CRYST_GO2(ana,neu,neu1))
      if (m.eq.9) goto 101
      if (log) log=(log.and.BENDER_GO(sol4,neu1,neu))
      if (m.eq.10) goto 100
      if(log) log=(log.and.SLIT_GO(det,neu,neuf1))      
      MONIT_GO2=.true.
      return
      
100   neuf1=neu
      if (normmon.ne.0) then  ! calculate capture flux
        k0=sqrt(neuf1.k(1)**2+neuf1.k(2)**2+neuf1.k(3)**2)
        neuf1.p=neuf1.p*2*pi/k0/1.8d0
      endif
      MONIT_GO2=log
      return      

101   neuf1=neu1
      if (normmon.ne.0) then  ! calculate capture flux
        k0=sqrt(neuf1.k(1)**2+neuf1.k(2)**2+neuf1.k(3)**2)
        neuf1.p=neuf1.p*2*pi/k0/1.8d0
      endif
      MONIT_GO2=log
      return      

111   MONIT_GO2=.false.
      end

#--------------------------------------------------------      
      SUBROUTINE WrtNEU(neu)

      INCLUDE 'structures.inc'
      
      record /NEUTRON/ neu
      
1      format(7(1x,g10.4))
       write(*,1) (neu.r(i),i=1,3),(neu.k(i),i=1,3),neu.p
      end


#--------------------------------------------------------      
      SUBROUTINE FORW_INI(itask)
#     Clears all necessary variables and, if ICLR<>1, 
#     initializes objects and limits of random variables
#--------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'ness_common.inc'
      INCLUDE 'randvars.inc'
      INCLUDE 'source.inc'
      
      integer*4 itask,nev
      logical*4 verbose
      common /mcsetting/ verbose,nev
      real*8 lzm,lms,z0,z1,z2,w1,h1,ctm,stb,eps,eps1,stpch,b
      real*8 avmin,a1,a2,a3,a4,ahmin
      integer*4 i,j
       
#///  revert primary spectrometer for the forward tracing:
#/// NESS_CONV and SPEC_INI must be allways called before !!

      z1=sou.dist+sol1.frame.dist+guide.frame.dist+gdea.frame.dist
      z2=mon.frame.dist+sol2.frame.dist+sol2a.frame.dist

      
      sam.dist=sol2.frame.dist+sol2.frame.size(3)
      sol2a.frame.dist=z2-sol2.frame.dist-
     1                 sol2a.frame.dist-sol2a.frame.size(3)

      sol2.frame.dist=z2-sam.dist-sol2a.frame.dist
      w1=sol2.frame.size(1)  
      h1=sol2.frame.size(2)
      sol2.frame.size(1)=sol2.w2
      sol2.frame.size(2)=sol2.h2
      sol2.w2=w1
      sol2.h2=h1
      sol2.frame.axi=0
      if (sol2.typ.le.1) sol2.ch=-sol2.ch

      w1=sol2a.frame.size(1)
      h1=sol2a.frame.size(2)
      sol2a.frame.size(1)=sol2a.w2
      sol2a.frame.size(2)=sol2a.h2
      sol2a.w2=w1
      sol2a.h2=h1
      sol2a.frame.axi=-sol1.frame.axi
      if (sol2a.typ.le.1) sol2a.ch=-sol2a.ch
      
      mon.frame.dist=sol1.frame.dist+sol1.frame.size(3)
      mon.frame.gon(1)=-mon.frame.gon(1) -2*mon.chi      
                          
      gdea.frame.dist=z1-sol1.frame.dist-guide.frame.dist-
     1                 gdea.frame.dist-gdea.frame.size(3)        
      w1=gdea.frame.size(1)  
      h1=gdea.frame.size(2)
      gdea.frame.size(1)=gdea.w2
      gdea.frame.size(2)=gdea.h2
      gdea.w2=w1
      gdea.h2=h1 
      if (gdea.typ.le.1) gdea.ch=-gdea.ch

      z1=z1-gdea.frame.dist
      guide.frame.dist=z1-sol1.frame.dist-guide.frame.dist
     1                 -guide.frame.size(3)        
      w1=guide.frame.size(1)  
      h1=guide.frame.size(2)
      guide.frame.size(1)=guide.w2
      guide.frame.size(2)=guide.h2
      guide.w2=w1
      guide.h2=h1 
      if (guide.typ.le.1) guide.ch=-guide.ch

      z1=z1-guide.frame.dist
      sol1.frame.dist=z1-sol1.frame.dist-sol1.frame.size(3)
      w1=sol1.frame.size(1)  
      h1=sol1.frame.size(2)
      sol1.frame.size(1)=sol1.w2
      sol1.frame.size(2)=sol1.h2
      sol1.w2=w1
      sol1.h2=h1
      sol1.frame.axi=0
      if (sol1.typ.le.1) sol1.ch=-sol1.ch
      
      sou.dist=0     
      
      call SLIT_INIT(sou)
      call BENDER_INIT(gdea)
      call BENDER_INIT(guide)
      call BENDER_INIT(sol1)
      call CRYST_INIT2(mon)
      call BENDER_INIT(sol2a)
      call BENDER_INIT(sol2)
      call SLIT_INIT(sam)
                     
      lzm=sol1.frame.dist+mon.frame.dist+guide.frame.dist+
     1      gdea.frame.dist
      lms=sol2.frame.dist+sol2a.frame.dist+sam.dist
      ctm=sign(1,stp.sm)/tan(mon.thb)
      stb=sin(mon.thb)       
      eps1=1-2*mon.rv*abs(stb)*lms
             
#//// minimum vertical aperture:         
      avmin=1.d+35
      if (guide.frame.size(3).gt.0.and.guide.frame.dist.gt.0) then
         a1=(sou.size(2)+guide.frame.size(2))/
     1      (guide.frame.dist+gdea.frame.dist)
         a2=(guide.h2+guide.frame.size(2))/guide.frame.size(3)/guide.nlv
         a3=guide.gvt*4*pi/stp.ki
         a4=abs((guide.frame.size(2)+mon.frame.size(2))/
     1       (lzm-guide.frame.dist-gdea.frame.dist))     
          avmin=min(avmin,a1,max(a2,a3),max(a3,a4))
      endif
      if (guide.gvt.eq.0.d+0.and.
     1      sol1.frame.size(3).gt.0.and.sol1.frame.dist.gt.0) then
         a1=(sou.size(2)+sol1.frame.size(2))/
     1          (guide.frame.dist+sol1.frame.dist+gdea.frame.dist)
         a2=(sol1.h2+sol1.frame.size(2))/sol1.frame.size(3)/sol1.nlv
         a3=sol1.gvt*4*pi/stp.ki
         a4=abs((sol1.frame.size(2)+mon.frame.size(2))/
     1       (lzm-guide.frame.dist-sol1.frame.dist-gdea.frame.dist))     
         avmin=min(avmin,a1,max(a2,a3),max(a3,a4))
      endif
      if (sol1.gvt.eq.0.d+0.and.guide.gvt.eq.0.d+0) then   
         avmin=min(avmin,(sou.size(2)+mon.frame.size(2)*stb)/lzm)   
      endif  
                 
#//// minimum horizontal aperture:          
      ahmin=1.d+35
      if (guide.frame.size(3).gt.0.and.guide.frame.dist.gt.0) then
         a1=(sou.size(1)+guide.frame.size(1))/
     1      (guide.frame.dist+gdea.frame.dist)
         a2=(guide.w2+guide.frame.size(1))/guide.frame.size(3)/guide.nlh
         a3=guide.ghlu*4*pi/stp.ki
         a4=abs((guide.frame.size(1)+mon.frame.size(1)*stb)/
     1       (lzm-guide.frame.dist-gdea.frame.dist))     
         ahmin=min(ahmin,a1,max(a2,a3),max(a3,a4))
      endif
      if (guide.ghlu.eq.0.d+0.and.
     1      sol1.frame.size(3).gt.0.and.sol1.frame.dist.gt.0) then
         a1=(sou.size(1)+sol1.frame.size(1))/
     1       (sol1.frame.dist+guide.frame.dist+gdea.frame.dist)
         a2=(sol1.w2+sol1.frame.size(1))/sol1.frame.size(3)/sol1.nlh
         a3=sol1.ghlu*4*pi/stp.ki
         a4=abs((sol1.frame.size(1)+mon.frame.size(1)*stb)/
     1       (lzm-guide.frame.dist-sol1.frame.dist-gdea.frame.dist))     
         ahmin=min(ahmin,a1,max(a2,a3),max(a3,a4))
      endif
      if (sol1.ghlu.eq.0.d+0.and.guide.ghlu.eq.0.d+0) then   
       ahmin=min(ahmin,(sou.size(1)+mon.frame.size(1)*stb)/lzm)
      endif  
                  
#// common constraints for simulation started at the source
         
      tmat(5,2)=-eps1/(lzm*eps1+lms)
      tmat(2,5)=0
      rndlist.limits(2)=
     1   min(avmin,sam.size(2)/(lms+lzm)+abs(3*mon.vmos*stb)) 
      rndlist.limits(5)=sou.size(2)

#!! New horizontal optimization - 28/1/2000  !!!

      stpch=sin(mon.thb+mon.chi)
      eps=stpch/mon.stmch
      b=eps-2*mon.rh*lms/mon.stmch     
      rndlist.limits(1)=abs(ahmin)*rndlist.pool(1)
      tmat(4,3)=-mon.rh*stp.ki/mon.stmch*ctm
      tmat(1,3)=(1-lzm*mon.rh/mon.stmch)*ctm*stp.ki
      rndlist.limits(3)=sqrt((4*mon.hmos)**2+(mon.rh*
     1  mon.frame.size(3)*mon.ctmch/mon.stmch)**2)*stp.ki*abs(ctm)
      rndlist.limits(4)=sou.size(1)*rndlist.pool(4)

#// Only primary beamline, without monochromator
      if (mon.nh.eq.0.or.
     * (itask.eq.7.and.imonit.ge.0.and.imonit.lt.4)) then
        rndlist.limits(1)=ahmin
        rndlist.limits(2)=avmin
        rndlist.limits(4)=sou.size(1)
        rndlist.limits(5)=sou.size(2)
        rndlist.active(3)=0
          if (flxn.gt.0) then
               z0=2*pi/flxlam(1)
               z1=2*pi/flxlam(flxn)
               tmean(3)=(z1+z0)/2
               rndlist.limits(3)=abs(z1-z0)
             rndlist.active(3)=1
          else    
             rndlist.limits(3)=0.01*stp.ki
          endif  
          if (flxh.gt.0) then
               rndlist.active(1)=0
               rndlist.limits(1)=flxh*1.2                
          endif
          if (flxv.gt.0) then
               rndlist.active(2)=0
               rndlist.limits(2)=flxv*1.2
          endif
          do  i=1,6
          do  j=1,6
            if (i.ne.j) then
                 tmat(i,j)=0.          
            else
                 tmat(i,j)=1.          
            endif 
        enddo
        enddo        
      endif
         
#// if divergence limits for source were given in options:
      if (flxh.gt.0) rndlist.limits(1)=flxh*1.2                
      if (flxv.gt.0) rndlist.limits(2)=flxv*1.2

#// no constraints in debug mode
      if (idbg.ge.1) then
       if (flxh.le.0) rndlist.limits(1)=ahmin
       if (flxv.le.0) rndlist.limits(2)=avmin
       if (flxn.le.0) rndlist.limits(3)=0.05*stp.ki
       rndlist.limits(4)=sou.size(1)
       rndlist.limits(5)=sou.size(2)
      endif   
                       
      if (verbose) write(*,*)  'Forward tracing (source -> sample)'
      
      end