src/ness/ness_dev.f

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

Source module last modified on Fri, 12 May 2006, 12:16;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#//////////////////////////////////////////////////////////////////////
#////  $Id: ness_dev.f,v 1.5 2006/05/12 10:16:14 saroun Exp $
#////                                                              //// 
#////  NEutron Scattering Simulation - v.1.2, (c) J.Saroun, 1997   ////
#////                                                              //// 
#//////////////////////////////////////////////////////////////////////
#////
#/////  Subroutines for handling events & simple command interpreter
#////                      
#////  *   SUBROUTINE NESSEND
#////  *   SUBROUTINE NESS_LOOP
#////  *   SUBROUTINE READCOM(ICOMM,IOE)
#////  *   SUBROUTINE NESS(ITASK)
#////  *   LOGICAL*4 FUNCTION SAFETY_POOL()
#////  *   SUBROUTINE SWPOOL
#////  *   SUBROUTINE MAXV_UPD(ITASK)
#////  *   SUBROUTINE RANDFILL
#////  *   SUBROUTINE RESINT(ICOM,VAL,KI,R,KF)
#////  *   SUBROUTINE NESS_RUN(ICOM,NCNT,NEVENT)
#////  *   SUBROUTINE VALID(ICOM,NCNT)
#////  *   BLOCK DATA
#////  
#//////////////////////////////////////////////////////////////////////


#-------------------------------
      SUBROUTINE NESSEND
#     NESS destructor      
#-------------------------------
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'restrax.inc'
#      CALL KSTACK_DESTROY
      call KSTACK_FREERANGE(1,mf_max)
      return
      end


#------------------------------------------------------------
      SUBROUTINE IFNESS(icom,nev)
# All calls of Monte Caro should be made through this subroutine !!
# NEV - requested number of events (no check of validity !)
# Call Monte Carlo only if ICOM<>0 or configuration has changed
# ICOM=1 call MC anyway
# ICOM=0 call MC only if the configuration has been changed
#------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'restrax.inc'

      INCLUDE 'rescal.inc'
      
      integer*4 icom,nev
      real*8 qe(4),p
      integer*4 i,j,nj,GETIDENT

2     format( 'Events for dataset ',i2, ' already calculated.')
3     format( 'Events copied from set ',i2,  ' to ',i2)          
   
      lastnev=nev
      if(icom.eq.0) then  
      
#      J=mf_cur
#      write(*,*) 'ID: ',J,' done: ',mf_done(J),' mod: ',mf_changed(J) 
        j=GETIDENT()    ! index to identical setup, if any, with 'MC done'
        if(j.gt.0) then
           call KSTACK_N(nj,j)  
           if (nj.eq.nev) then      ! number of events accumulated in J agrees with the required one 
             if (j.eq.mf_cur) then  ! Current setup has already 'MC done'
               if (silent.lt.1) write(sout,2) mf_cur
               return
             else                                 ! There is another setup with 'MC done' which can be used
               call KSTACK_ALLOCATE(nev,mf_cur)
               do i=1,nev                         ! copy events from J to mf_cur
                 call GETQE(i,j,qe,p)
                 call SETQE(i,mf_cur,qe,p)
               enddo
               call SPEC_UPDATE          ! mark current setup as updated (i.e. MC has been done)
               i=mf_cur                  ! remember index of the current setup
               call mfit_set(j)          ! set J as the current setup
               mf_cur=i                  ! restore the index of current setup
               call mfit_get(mf_cur)     ! copy back to the mf_cur (in order to copy resolution matrices etc.) 
               mf_done(mf_cur)=.true.    ! .. an all si done
               if (silent.lt.1) write(sout,3) j,mf_cur
#      write(*,*) 'ID: ',mf_cur,' done: ',mf_done(mf_cur),' mod: ',
#     * isCHANGED,mf_changed(mf_cur),mf_changed(J) 
               return
             endif
           endif  
        endif
      endif    
      call SPEC_INI(0)
      call NESS(2,nev)
      call SPEC_UPDATE         ! update records with TAS setup for future comparisons
      call mfit_get(mf_cur)    ! copy records with current TAS setup to mf_ fields
      mf_done(mf_cur)=.true.   ! mark current setup as 'MC done' 
      end 
       
#------------------------------------------------------------
      SUBROUTINE NESS(itask,npreset)
#  ITASK=0 ... writes covariance and resolution matrices
#  ITASK=2 ... makes pre-defined cycle (see comments bellow)
#/// (J.S. 1997) takes preset number of events from NPRESET
#------------------------------------------------------------
      implicit none
      
      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'
      INCLUDE 'restrax.inc'    ! contains already ness_common.inc
            
      integer*4 ndcom,ndpar
      parameter(ndcom=16,ndpar=16)

      character*5 commands(ndcom)
                 
      real*4   param(ndpar),secnds
      record /STATI/ cov_qe       
      
      integer*4 hit(crnd),nevent,ntot,nout,ncnt,dotcnt
      integer*4 itask,npreset,ncom,npar,icom,i,nev,mess
      real*8 t1,t2,t3,z
           
      common /result/ cov_qe
      common /commands/ ncom,commands,npar,param
      common /pool/ hit
       
      
      real*8 e4(4),e16(crnd)

      equivalence(e16,e4)
      save ncnt

1     format( '.',$)            
3     format( ' Wait please ',$)            
4     format( ' Time to wait [s]: ',g8.3)           
5     format( ' Timeout reached at ',f8.2, ' s')      
7     format(4x,5(2x,e12.5)) 
8     format( ' Time spent:  ',f8.2, ' s ',i8, ' events, ',i8, ' counts')    
12    format( ' Safety pool hits: ',16(1x,i3))
 
      icom=0
      

#/////////////  command = ACCU  ////////////////////       
      
      if(itask.eq.2) then
      
      do 200 i=1,rndlist.dim
200       hit(i)=0
                    
      
      nev=npreset
      nevent=0
      ncnt=0
      ntot=0 
      dotcnt=0 
      nout=nev*10000
      dbg_time=0
            
      call KSTACK_ALLOCATE(nev,mf_cur)   
            
      t1=secnds(0.0)

      if(nev.ge.2000) then
        mess=0
      else
        mess=1
      endif
#------------------   Main Cycle    -----------------------
      write(smes,3) 
      do while ((ncnt.lt.nev).and.(ntot.lt.nout))
         call NESS_RUN(icom,ncnt,nevent)
         
         if(ncnt.eq.0) dotcnt=0
         
         if(ncnt.eq.500) t2=secnds(0.0)

#/// When 1000 events were accumulated, total time is estimated:

         if((mess.eq.0).and.(ncnt.ge.1000)) then
            mess=1
            t3=secnds(0.0)
            z=(t2-t1)+(t3-t2)*(nev-1000.)/500.
            if (silent.lt.1) write(smes,4) z
         endif

#/// When 2000 events were accumulated, actual limits of random 
#/// variables are estimated.
         
         if((ncnt.eq.2000).and.(mess.lt.2)) then
              call MAXV_UPD(2)
              mess=2
         endif

#/// When 5000 events were accumulated, safety pool is switched-off.
        
         if((ncnt.eq.5000).and.(mess.lt.3)) then
              call SWPOOL
              mess=3
         endif         
         
#/// Write a dot for each 500 successful events
         i=(ncnt+1)/500
         if(mod(ncnt+1,500).eq.0.and.i.gt.dotcnt) then
              dotcnt=(ncnt+1)/500
              write(sout,1)
         endif         
            
         ntot=ntot+1 
         if ((nevent.gt.10000000).and.(ncnt.eq.0)) ntot=nout        
      end do
      if(ncnt.ge.5000) call SWPOOL
         
      write(sout,*) 
      
#----------------------- End ------------------------------      
      
      t3=secnds(0.0)
      if (silent.lt.1) call GETSTATE      
      if (ntot.ge.nout) then
         write(smes,5) t3-t1
         ncnt=0
      else
         if (silent.lt.1) write(smes,8) t3-t1,nevent,ncnt
      endif
#      WRITE(SMES,12) (HIT(I),I=1,RNDLIST.DIM)
#      WRITE(SMES,*) 'DBG_TIME: ',DBG_TIME 

      call GETCOV_QE(ncnt)    ! resolution matrix
#      write(*,*) 'GETCOV_QE finished'
      call RESINT(2)  ! get norm factors 
#      write(*,*) 'RESINT(2) finished'

#      write(*,*) 'NESS finished'

      endif

      end 

#-------------------------------------------------------------------
      SUBROUTINE GETCOV_QE(ncnt)
      implicit none
      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'
      INCLUDE 'restrax.inc'    ! contains already ness_common.inc

      integer*4 i,j,ncnt      
      record /STATI/ cov_qe                  
      common /result/ cov_qe
      real*8 e4(4),e16(crnd),p
      equivalence(e16,e4)


#/// calculates the covariance matrix and resolution matrix from
#/// the accumulated events:
#      write(*,*) 'GETCOV_QE'
      call STAT_CLR(4,cov_qe)
      
#      write(*,*) 'STAT_CLR'
      
      do  i=1,ncnt
         call GETQE(i,mf_cur,e4,p) 
         call STAT_INP(4,cov_qe,e16,p)
      enddo

      if(cov_qe.nc.gt.0) then
         call STAT_GET(4,cov_qe)
       
         if(cov_qe.c(4,4).le.1.e-10) cov_qe.c(4,4)=1.
         call INVERT(4,cov_qe.c,crnd,aness,4)
                
         do i=1,4
               amean(i)=cov_qe.m(i) 
         enddo

      else
         do i=1,4
             do j=1,4
                aness(i,j)=0.
             end do
             amean(i)=0.            
         enddo
         write(smes,*)  'No events accumulated !'              
#    CALL KSTACK_FREE(mf_cur)
      endif         

      end
         
#-------------------------------------------------------------------
      logical*4 FUNCTION SAFETY_POOL()
#     Checks, if the value of any random variable X(I) is found
#     in the safety pool. If yes, corresponding limits are relaxed.
#-------------------------------------------------------------------
      
      INCLUDE 'ness_common.inc'
      
      real*8 z
      integer*4 hit(crnd)    
      common /pool/ hit
      logical*4 log1

5     format(a20,1x,i2,3(2x,f12.5))

      log1=.false.
      do 10 i=1,rndlist.dim
      
      if (rndlist.active(i).gt.0) then
        z=abs(2*rndlist.pool(i)*rndx(i))-rndlist.limits(i)   
        if (z.gt.0) then        
           rndlist.limits(i)=rndlist.limits(i)*rndlist.pool(i)
           hit(i)=hit(i)+1
           log1=.true.
        endif
      endif      
10    continue
      SAFETY_POOL=log1
      return
      end        


#     --------------------------------------------------
      SUBROUTINE SWPOOL
#     switch safety pool off/on
#     --------------------------------------------------
     
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'ness_common.inc'

      byte mypool(crnd)
      integer*4 ipool_off      
      real*8 mylim(crnd)      
      save ipool_off
      data ipool_off/0/
      
      
      if(ipool_off.eq.0) then
#         WRITE(SMES,*) 'Safety pool OFF'
         do 10 i=1,rndlist.dim
           mylim(i)=rndlist.limits(i)
           mypool(i)=rndlist.active(i)
           rndlist.limits(i)=rndlist.limits(i)/rndlist.pool(i)
           rndlist.active(i)=0
10       continue
         ipool_off=1
      else
#         WRITE(SMES,*) 'Safety pool ON'
         do 20 i=1,rndlist.dim
           rndlist.limits(i)=mylim(i)
           rndlist.active(i)=mypool(i)           
20       continue
         ipool_off=0
      endif
      
      return
      end      
                                                   
#-----------------------------------------------------------------------
      SUBROUTINE MAXV_UPD(itask)
#     ITASK=0 ... clears MAXV(I) array
#     ITASK=1 ... MAXV(I) is compared with X(I) and changed if necessary
#     ITASK=2 ... limits are changed according to MAXV(I)        
#-----------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      
      INCLUDE 'ness_common.inc'
      
      real*8 maxv(crnd)
      
      save maxv
      
      if(itask.eq.0) then
      do  5 i=1,rndlist.dim                 
         maxv(i)=0.
5     continue       
      
      else if(itask.eq.1) then
      
      do  10 i=1,rndlist.dim
        if (rndlist.active(i).gt.0) then              
          if(abs(rndx(i)).gt.maxv(i)) maxv(i)=abs(rndx(i))
        endif  
10    continue        
      
      else if(itask.eq.2) then
      
      do  20 i=1,rndlist.dim
        if (rndlist.active(i).gt.0) then
           rndlist.limits(i) = 2.*maxv(i)*rndlist.pool(i)*1.001
        endif              
20    continue

      endif
      return
      end          
          
      
#----------------------------------------------------------
      SUBROUTINE RANDFILL
#
#----------------------------------------------------------
      implicit none
      
      INCLUDE 'ness_common.inc'
      integer*4 i
      real*4 RAN1
        
      do  i=1,rndlist.dim
         rndx(i)=rndlist.limits(i)*(RAN1()-0.5)
      end do

      return
      end


#------------------------------------------------------------
      SUBROUTINE NESS_RUN(icom,ncnt,nevent)
#     makes one event
#------------------------------------------------------------
      implicit none

      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'ness_common.inc'
      
      record /NEUTRON/ neui,neuf,neui1,neuf1
      real*8 kff,ki,kf,dkki,dkkf,si,co,pp
      integer*4 nevent,icom,ncnt,ierr,i
      logical*4 SPEC_GO,SAFETY_POOL,emod   
      common /errors/ ierr 
      common /neuif/ neui,neuf,neui1,neuf1,dkki,dkkf
      common /mode/ emod
      real*4 RAN1
      real*8 DFLUX,v3xv3
  
  
1     format(a20,4(2x,f12.5))
      
      
      nevent=nevent+1
      call RANDFILL

      si=sin(rndx(3))
      co=sqrt(1-si**2) 
      neui.r(2)=rndx(2)+sam.sta(2)
      neui.r(1)=rndx(1)*co+sam.sta(1)
      neui.r(3)=rndx(1)*si+sam.sta(3)
     
      neui.p=1
      neui.t=0
      neui.phi=0
      neui.s=2*nint(RAN1())-1
      neuf=neui
      neuf.s=2*nint(RAN1())-1               
      do 20 i=1,2
         neui.k(i)=rndx(i+3)
         neuf.k(i)=rndx(i+5)
20    continue

      neui.k(3)=stp.ki
      neuf.k(3)=stp.kf
      

      neui.k(2)=-neui.k(2)
      sam.count=sam.count+1 
      if(SPEC_GO(1)) then  
           if(emod) then
              ki=sqrt(v3xv3(neui1.k,neui1.k))
              kf=sqrt(v3xv3(neuf.k,neuf.k))
              kff=sqrt(ki**2-stp.e/hsqov2m)
              do i=1,3
                 neuf.k(i)=neuf.k(i)*kff/kf
              end do
           endif 
         if (stp.sm.eq.0) then
             ki=sqrt(v3xv3(neui1.k,neui1.k))
           pp=DFLUX(1.d0,ki)*ki**2
           neui1.p=neui1.p*pp
           neui.p=neui.p*pp
         endif
                                     
           if(SPEC_GO(2)) then
             if (stp.sa.eq.0) then
               neuf1.p=neuf1.p*(1.+dkkf)**2
          neuf.p=neuf.p*(1.+dkkf)**2
             endif
               call MAXV_UPD(1)               
               if (SAFETY_POOL()) then                   
                   call SPEC_INI(1)
                   nevent=0
                   ncnt=0
                   return
               endif
               ncnt=ncnt+1
               call VALID(icom,ncnt)               
           endif
      endif
       
      return
      end         

#---------------------------------------------------------------
      SUBROUTINE VALID(icom,ncnt)
#     Makes all operations with a succesfull event      
#---------------------------------------------------------------
      implicit none     

      INCLUDE 'const.inc'      
      INCLUDE 'inout.inc'
      INCLUDE 'rescal.inc'
      INCLUDE 'restrax.inc'
      
      integer*4 icom,ncnt,i
      real*8 phi0,ki(3),kf(3),kki,kkf  
      real*8 dkki,dkkf
      record /NEUTRON/ neui,neuf,neui1,neuf1
      common /neuif/ neui,neuf,neui1,neuf1,dkki,dkkf       

#/// correction on abs(ki,kf)                   
      kki=0.d0
      kkf=0.d0
      neui.k(2)=-neui.k(2)
      do i=1,3
         neui.k(i)=neui.k(i)*(1+dkki)
         neuf.k(i)=neuf.k(i)*(1+dkkf)
         ki(i)=neui.k(i)
         kki=kki+neui.k(i)**2
         kkf=kkf+neuf.k(i)**2
      end do
      neui.phi=neui1.phi
      neuf.phi=neuf1.phi
1     format(6(g16.9,1x)) 
              
      phi0=stp.tauf/hbar*hsqov2m*(kki-kkf)
 
#      write(*,*) 'VALID ', NCNT,mf_cur,MLC(1,1)
#      pause
     
      
      call KSTACK_WRITE(ncnt,mf_cur,neui.k,neuf.k,neui.p,neuf.p,
     *             neui.s,neuf.s,neui.phi-neuf.phi-phi0)       
     

#// mean values are subtracted from NEUI.K and NEUF.K:      
      ki(3)=ki(3)-stp.ki 

#///  transform dKF to lab. coord.
      kf(3)=-neuf.k(1)*somega+(neuf.k(3)-stp.kf)*comega
      kf(2)=neuf.k(2)   
      kf(1)=+neuf.k(1)*comega+(neuf.k(3)-stp.kf)*somega

#// covariance matrices of the (ki,r,kf) vector are accumulated:      
      call RESINT(1,neui1.p*neuf1.p,ki,neui.r,kf)
     
      return
      end          

#-------------------------------------------------------------------        
      SUBROUTINE RESINT(icom,val,ki,r,kf)
#     ICOM=0  clear data
#     ICOM=1  accumulates covariance matrices
#     ICOM=2  evaluates corresponding normalization factors
#  Vol(ki), Vol(kf), Vol(ki,r,kf)/Vol(ki)
#-------------------------------------------------------------------        
      implicit none 
      
      INCLUDE 'const.inc'
      INCLUDE 'inout.inc'
      INCLUDE 'restrax.inc'

      real*8 ki(3),r(3),kf(3),val,mean(9),rm(9),sc,d1,d2,d3
      real*8 cov(9,9),rc(9,9),v(9),aux(9,9),r3(3,3),r3f(3,3),aux3(3,3)
      real*8 r2f(2,2),aux2(2,2),rc8(8,8),aux8(8,8)
      integer*4 icom,i,j
      real*8 DETERM
      logical*4 emod
      common /mode/ emod
      save sc,cov,mean
      
         
      if(icom.eq.1) then            !  add event
        do 15 i=1,3
           v(i)=ki(i)
           v(i+3)=r(i)
           v(i+6)=kf(i)
15      continue
        sc=sc+val
        do 20 i=1,9        
          mean(i)=mean(i)+val*v(i)
          do 20 j=1,9
            cov(i,j)=cov(i,j)+val*v(i)*v(j)
20      continue      
      endif          
      
      if(icom.eq.2) then           ! evaluate norm. factor
        if(sc.le.0.) goto 999     
#/ exclude KF(3) for elastic mode
        if(emod) then
        do 31 i=1,8        
            rm(i)=mean(i)/sc
            do 31 j=1,8       
              rc8(i,j)=cov(i,j)/sc
              if((i.le.3).and.(j.le.3)) r3(i,j)=cov(i,j)/sc
              if((i.ge.7).and.(j.ge.7)) r2f(i-6,j-6)=cov(i,j)/sc
31          continue     
          do 41 i=1,8        
            do 41 j=1,8
              rc8(i,j)=rc8(i,j)-rm(i)*rm(j)
              if((i.le.3).and.(j.le.3)) r3(i,j)=r3(i,j)-rm(i)*rm(j)        
              if((i.ge.7).and.(j.ge.7)) r2f(i-6,j-6)=
     *                r2f(i-6,j-6)-rm(i)*rm(j)
41        continue 
          d1=DETERM(rc8,8,aux8)
          d2=DETERM(r3,3,aux3)        
          d3=DETERM(r2f,2,aux2)        
          relness=(2*pi)**3*sqrt(d1/d2)
          vkiness=(2*pi)*sqrt(2*pi*d2)
          vkfness=(2*pi)*sqrt(d3)
      else
#
        do 30 i=1,9        
            rm(i)=mean(i)/sc
            do 30 j=1,9
              rc(i,j)=cov(i,j)/sc
              if((i.le.3).and.(j.le.3)) r3(i,j)=cov(i,j)/sc
              if((i.ge.7).and.(j.ge.7)) r3f(i-6,j-6)=cov(i,j)/sc
30        continue     
          do 40 i=1,9        
            do 40 j=1,9
              rc(i,j)=rc(i,j)-rm(i)*rm(j)
              if((i.le.3).and.(j.le.3)) r3(i,j)=r3(i,j)-rm(i)*rm(j)        
              if((i.ge.7).and.(j.ge.7)) r3f(i-6,j-6)=
     *                r3f(i-6,j-6)-rm(i)*rm(j)
40        continue 
          d1=DETERM(rc,9,aux)
          d2=DETERM(r3,3,aux3)        
          d3=DETERM(r3f,3,aux3)        
          relness=(2*pi)**3*sqrt(d1/d2)
          vkiness=(2*pi)*sqrt(2*pi*d2)
          vkfness=(2*pi)*sqrt(2*pi*d3)
        endif
                                        
      else if(icom.eq.0) then      ! clear array
         sc=0.
         do 10 i=1,9
           mean(i)=0.
           do 10 j=1,9
             cov(i,j)=0
10       continue
      endif
      
      return
      
999   write(smes,*)  'No events accumulated'
      val=0.
      return      
      
      end          
           


#--------------------------------------------
      real*8 FUNCTION DFLUX(f0,k)
#--------------------------------------------
      implicit none
      INCLUDE 'const.inc'
      INCLUDE 'ness_common.inc'
      real*8 k,vkt2,f0,c0
      data stemp /300/
      
      c0=0.5/pi/vkt2**2
      vkt2=12.187081*stemp/293. 
      DFLUX=f0*c0*k*exp(-k*k/vkt2)

      end