src/ness/ness_source.f

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

Source module last modified on Mon, 23 May 2005, 12:50;
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 - SOURCE
#////  
#////                          
#//////////////////////////////////////////////////////////////////////

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

      INCLUDE 'const.inc'
      INCLUDE 'structures.inc'
      INCLUDE 'source.inc'
        
      logical*4 log1, SLIT_GO
      real*8 k0,a,DFLUX
      record /SLIT/ obj
      record /NEUTRON/ neui,neuf
1     format(a10,1x,i4,1x,7(g11.4))
      
      log1=SLIT_GO(obj,neui,neuf)
      if (log1) then
        k0=sqrt(neuf.k(1)**2+neuf.k(2)**2+neuf.k(3)**2)
        neuf.p=neuf.p*DFLUX(neuf.r,neuf.k)
        if (flxh.gt.0) then
             a=atan(neuf.k(1)/neuf.k(3))
             if (abs(a).gt.flxh/2.) neuf.p=0 
        endif     
        if (neuf.p.gt.0.and.flxv.gt.0) then
           a=atan(neuf.k(2)/neuf.k(3))
           if (abs(a).gt.flxv/2.) neuf.p=0 
        endif     
        if (log1.and.(obj.shape.eq.1)) then
          neuf.p=neuf.p*pi/2*cos(neuf.r(1)/obj.size(1)*pi)
        endif
        neuf.p=neuf.p*
     *      (1.d0+flxa*(neuf.r(1)-flx0)+flxb*(neuf.r(1)-flx0)**2)*
     *      (1.d0+flya*(neuf.r(2)-fly0)+flyb*(neuf.r(2)-fly0)**2)
     
        log1=(neuf.p.gt.0.d0)
      if (neuf.p.le.0) then
          if (log1) obj.count=obj.count-1
          log1=.false.
        endif
      endif  
        
      if (dbgref) write(*,1) obj.name,obj.count,neuf.r,neuf.k,neuf.p
      
      SOURCE_GO=log1
      return
      end
      
#---------------------------------------------------------
      real*8 FUNCTION DFLUX(r,k)
#     F0 is the integral neutron flux [1e14/s/cm^2] 
# NEW!!! Returns dPhi/dK/dOmega in [1e14/s/cm^2/ster*Ang]
#---------------------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'source.inc'
      real*8 r(3),k(3)
      real*8 z,lam,vkt,k0
      integer*4 iz  
      real*8 res,ph,pv,v(2),di,dj
      real*8 LINTERP2D
1     format(a,6(2x,g10.4))

      k0=sqrt(k(1)**2+k(2)**2+k(3)**2)
 
      if (flxn.gt.0) goto 10  ! read lookup table

# Maxwell
      vkt=3.370*sqrt(stemp/273.15) 
      DFLUX=sflux*k0**3*exp(-k0*k0/vkt/vkt)/2./pi/vkt**4
      return
      
# Lookup table
#// FLXDIST = dPhi/dLambda in [1e12/s/cm^2/Ang]

10    lam=2*pi/k0
      ph=1.d0
      pv=1.d0
      if (flxlog.gt.0) goto 20  ! logarithmic scale

# Linear scale
      z=(lam-flxlam(1))/flxdlam               
      iz=int(z)+1
      if(iz.lt.1.or.iz.ge.flxn) then 
         res=0.d0               
      else         
         res=(flxdist(iz)+(z-iz+1)*(flxdist(iz+1)-flxdist(iz)))  
      endif 
      goto 30
# Log scale
20    z=log(lam/flxlam(1))/flxdlam  
      iz=int(z)+1
      if(iz.lt.1.or.iz.ge.flxn) then 
         res=0.d0               
      else         
         res=(flxdist(iz)+(z-iz+1)*(flxdist(iz+1)-flxdist(iz)))  
      endif 
 
# search 2D-table
30    if (flxhnx.gt.0) then
        v(1)=r(1)
        v(2)=k(1)/k0
        di=2.d0*flxhx/(flxhnx-1)
        dj=2.d0*flxha/(flxhna-1)
        ph=LINTERP2D(flxhp,flxhnx,flxhna,64,-flxhx,-flxha,di,dj,v)
      endif   
      if (flxvnx.gt.0) then
        v(1)=r(2)
        v(2)=k(2)/k0
        di=2.d0*flxvx/(flxvnx-1)
        dj=2.d0*flxva/(flxvna-1)
        pv=LINTERP2D(flxvp,flxvnx,flxvna,64,-flxvx,-flxva,di,dj,v)
      endif 
#      write(*,1) 'DFLUX: ',R(1),K(1)/K0,R(2),K(2)/K0,LAM 
#      write(*,1) 'DFLUX: ',FLXHX,FLXHA,FLXVX,FLXVA 
#      write(*,1) 'DFLUX: ',RES,PH,PV 
#      pause
      DFLUX=sflux/(2.d0*k0**2)*0.01*res*ph*pv
      end