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