Source module last modified on Mon, 23 May 2005, 11:52;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#////////////////////////////////////////////////////////////////////////
#
# ************************************
# *** ***
# *** S I M R E S ***
# *** (PWD) ***
# *** (C) J.Saroun & J.Kulda ***
# *** ILL Grenoble ***
# *** evaluation version ***
# ************************************
#
# A clone of RESTRAX: http://omega.ujf.cas.cz/restrax
#
# Provides more flexible (and more realistic) ray-tracing code useful for simulation
# of newly designed or upgraded instruments and optimisation of their configuration.
# This version permits to simulate intensity and distribution of neutron beam in both
# real and momentum subspaces at different positions along the TAS beamline.
# Arrangements derived from TAS setup can also be simulated - they involve e.g. powder
# diffractometers equipped with multidetectors, neutron guides or different configurations
# of primary spectormeter (i.e. crystal monochromator with series of collimator or
# guide segments).
#
#****************************************************************************
# *** For all additional information contact the authors: ***
# *** ***
# *** kulda@ill.fr saroun@ujf.cas.cz ***
# *** ***
#****************************************************************************
#***********************************************************
#
# ONLY M.C. SIMULATION OF NEUTRON FLUX IN THIS VERSION !!!
#
#***********************************************************
#-------------------------------------
SUBROUTINE RESTRAX_MAIN
# Main unit for console application
#-------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'linp.inc'
character*(128) line
character*1 ch
integer*4 l
1 format(a)
2 format(a,$)
call CMD_HANDLE( 'SETLINP')
do while (.true.)
10 if (linp_in.eq.5) write(linp_out,2) linp_p(1:linp_np)// '> '
if (linp_eof.gt.0) goto 20
read(sinp,1,end=20) line ! treat EOF
ch=line(1:1)
if (ch.eq. '#'.or.ch.eq. ' '.or.ch.eq.char(0)) goto 10
l=len(line)
call CMD_HANDLE(line(1:l))
goto 10
20 call REINP( ' ')
call REOUT( ' ') ! end of job file -> close also output file
call LINPSETIO(sinp,sout,smes)
enddo
end
#-------------------------------------------------------------
SUBROUTINE BEFORE(ierr)
# Call whenever the setup may have changed
# Updates calculated auxilliary fields
# eturns IRES=0, if everything is OK
#-------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'rescal.inc'
INCLUDE 'trax.inc'
integer*4 ier,ierr
common /error/ier
real*8 z,z1,co,si
# look on the commons for collimators at a more convenient scope
integer*4 ncol(4),i,j
real*8 vlc(6,4)
equivalence (ncol(1),nfm)
equivalence (vlc(1,1),vlcanm)
# ATTENTION : order of following routines may be important !!!
ier=0
#/// scattering triangle in STP record
stp.nfx=res_dat(i_fx)
stp.sm=res_dat(i_sm)
stp.ss=res_dat(i_ss)
stp.sa=res_dat(i_sa)
stp.kfix=res_dat(i_kfix)
if (stp.nfx.eq.1.) then
stp.ei0=hsqov2m*stp.kfix**2
stp.ef0=stp.ei0-res_dat(i_en)
else
stp.ef0=hsqov2m*stp.kfix**2
stp.ei0=stp.ef0+res_dat(i_en)
end if
stp.ki=sqrt(stp.ei0/hsqov2m)
stp.kf=sqrt(stp.ef0/hsqov2m)
call QNORM(qhkl,z,z1)
stp.q=z1
stp.e=hsqov2m*(stp.ki**2-stp.kf**2)
#// scattering angle
if (stp.q.eq.0) then
comega=1
somega=0
omega=0
else
comega=-(stp.q**2-stp.ki**2-stp.kf**2)/(2*stp.ki*stp.kf)
if(abs(comega).gt.1) goto 999
somega=sign(1,stp.ss)*sqrt(1-comega**2)
omega=asin(somega)
if (comega.lt.0) omega=sign(1,stp.ss)*pi-omega
endif
#/// trans. matrix CN->lab
do 60 i=1,3
do 60 j=1,3
mlc(i,j)=0.
60 continue
if (stp.q.eq.0) then
co=1
si=0
else
co=(stp.kf**2-stp.ki**2-stp.q**2)/(2*stp.ki*stp.q)
if(abs(co).gt.1) goto 999
si=sign(1,stp.ss)*sqrt(1-co**2)
endif
mlc(1,1)=si
mlc(1,2)=co
mlc(2,3)=1.
mlc(3,1)=co
mlc(3,2)=-si
#// transformation matrices
call RECLAT ! compute reciprocal lattice parameters and matrices
call TRANSMAT ! create transformation matrices for coordinate systems
# collimator parameters from TRAX
# //// if ALPHA(I)<500 then the coarse collimator is ignored
# //// if ALPHA(I)>=500 then the Soller collimator is ignored
# //// if ALPHA(I)=0 then no collimation is considered
do i=1,4
alpha(i)=res_dat(i_alf1+i-1)
beta(i)=res_dat(i_bet1+i-1)
ncol(i)=-1
if (alpha(i).ge.500.and.vlc(2,i).ne.0) then
alpha(i)=0.
ncol(i)=1
endif
enddo
ierr=ier
return
999 ierr=1
end
#-----------------------------
SUBROUTINE LOGO
#-----------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'config.inc'
1 format(2x, '-----------------------------------------------',/,
& 2x, 'S I M R E S - Monte Carlo ray-tracing ',/,
& 2x, 'Version: ',a40,/,
& 2x, 'Build: ',a40,/,
& 2x, '-----------------------------------------------',/,
& 2x, '(C) J.Saroun & J.Kulda',/,
& 2x, 'ILL Grenoble, NPI Rez near Prague',/,
& 2x, ' ',/,
& 2x, '-----------------------------------------------',/,
& 2x, 'type ? for command list',/,/)
write(sout,1) package_version,package_date
return
end
#***********************************************************************
SUBROUTINE UNITS(sarg)
#***********************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
character*1 ch
1 format( ' Energy In m[eV] Or T[Hz]? (meV) ',$)
2 format( 'THz')
5 format( 'meV')
3 format(a)
4 format( ' Units are ',a)
ch=sarg(1:1)
if(ch.eq. ' ') then
write(smes,1)
read(sinp,3) ch
call MKUPCASE(ch)
endif
if(ch.eq. 'T') then
euni=0.24181
write(cunit,2)
else
euni=1.
write(cunit,5)
endif
write(sout,4) cunit
end
#
#
#-----------------------------------------------------------
SUBROUTINE GETROANAL(ro)
# return "optimal" monochromator and analyzer curvatures
# calculated analytically
# *** J.S. 3/6/1997
#-----------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'trax.inc'
INCLUDE 'rescal.inc'
real*4 ro(4)
real*8 thm,chim,tha,chia
thm=pi/sqrt(stp.ei0/hsqov2m)/res_dat(i_dm)
thm=abs(asin(thm))
chim=himon*deg
tha=pi/sqrt(stp.ef0/hsqov2m)/res_dat(i_da)
tha=abs(asin(tha))
chia=hiana*deg
# RO(1)=SIN(THM+CHIM)/2./VL1*100
# change to monochromatic focusing:
ro(1)=sin(thm+chim)/vl1*100
# write(*,*) 'VL1, THM, CHIM: ',VL1,THM*180/PI,CHIM*180/PI
ro(2)=1./vl1/(2.*sin(thm)*cos(chim))*100
# RO(3)=(VL2*SIN(THA+CHIA) + VL3*SIN(THA-CHIA))/2./VL2/VL3*100
ro(3)=sin(tha-chia)/vl2*100
ro(4)=(1./vl2+1./vl3)/(2.*sin(tha)*cos(chia))*100
end
#-----------------------------------------------------------
SUBROUTINE GETRO
# generates "optimal" monochromator and analyzer curvatures
#-----------------------------------------------------------
implicit none
INCLUDE 'inout.inc'
include 'rescal.inc'
real*4 ro(4)
integer*4 i
character*10 remark(4)
1 format(1x,a4, ' = ',f8.4, ' [m-1] ',a10)
call GETROANAL(ro)
do i=1,4
remark(i)= ' '
if((nos.eq.0).or.((nos.ge.i).and.(ret(i).eq.1.))) then
res_dat(i_romh+i-1)=ro(i)
remark(i)= ' changed'
endif
write(sout,1) res_nam(i_romh+i-1),ro(i),remark(i)
enddo
end
#-----------------------------------------------------------
SUBROUTINE GETROOPTMC
# Optimize curvature with M.C. simulation
# Only one of the curvatures can be optimized
# *** J.S. 5/7/2001
#-----------------------------------------------------------
implicit none
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
real*4 ro(4)
integer*4 ierr,i
common /error/ierr
integer*4 optpar,optmerit
real*8 optev
common /mcoptim/ optpar,optmerit,optev
real*4 OPTMC,par(1),tol,dpar(1)
external OPTMC
logical*4 verbose
integer*4 nev
common /mcsetting/ verbose,nev
1 format(1x,a4, ' = ',f8.4, ' [m-1] ',a10)
5 format( ' Numerical optimization failed ! ')
6 format( ' Wrong syntax. Type> MRO n [e] ',/,
* 'n=1 to 4 for ROMH, ROMV, ROAH, ROAV',/,
* 'e .. number of events in 1000 (default e=1)')
7 format( ' (1) Incident flux',/,
* ' (2) flux/dE ',/,
* ' (3) flux/dE^2 ',/,
* ' (4) Powder peak (detector with Soller)',/,
* ' (5) Powder peak (position-sensitive detector) ',/,
* ' (6) Vanad peak ',/,
* 'Select figure of merit: ',$)
20 write(*,7)
read(sinp,*) i
if(i.lt.1.or.i.gt.6) goto 20
optmerit=i
# WRITE(*,*) OPTMERIT
call NESS_CONV(1)
call GETROANAL(ro) ! Analytical estimation
optpar=nint(ret(1))
if (nos.gt.1) then
optev=ret(2)
else
optev=1.0
endif
if(optpar.lt.0.or.optpar.gt.4.or.nos.lt.1) then
write(sout,6)
return
endif
tol=0.1
dpar(1)=0.05 ! minimum increment for vert. curvature = 0.05m^-1
if (optpar.eq.1.or.optpar.eq.3) dpar(1)=0.01 ! 0.01m^-1 for hor. curv.
par(1)=ro(optpar)
# VERBOSE=.FALSE.
call LMOPT(OPTMC,par,1,tol,dpar,0)
# VERBOSE=.TRUE.
if (ierr.ne.0) then
write(sout,5)
return
endif
res_dat(i_romh+optpar-1)=par(1)
write(sout,1) res_nam(i_romh+optpar-1),res_dat(i_romh+optpar-1),
& ' changed'
return
end
#
#
#
#***********************************************************************
SUBROUTINE SAM_FLUX(icom)
# /// simulate flux at the sample (arg<>2) or at the detector (arg=2)
# /// by forward method (ICOM=1) or "from the sample" (ICOM=0)
# /// ICOM=2- monitor at position RET(1)
#***********************************************************************
#
implicit none
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 icom
#// monitor
if (icom.eq.2) then
call NESS_CONV(1)
imonit=nint(ret(1))
if (imonit.le.7) then
call NESS(7,0.d0)
else
call NESS(6,0.d0)
endif
imonit=-1
return
endif
#// no monitor
imonit=-1
call NESS_CONV(1)
if (icom.eq.3) then ! TAS
call NESS(8,0.d0)
else if (icom.eq.4) then ! PWD
call NESS(9,0.d0)
else if (icom.eq.5) then ! PWDS
call NESS(10,0.d0)
#// FLUX (ICOM=1) or NFLUX (ICOM=0) command:
else
if (ret(1).eq.2) then ! powder - PSD
call NESS(4+icom,0.d0)
else if (ret(1).eq.3) then ! TAS
call NESS(1,0.d0)
else if (ret(1).eq.4) then ! TAS forward
ftas=1
call NESS(1,0.d0)
ftas=0
else if (ret(1).eq.11) then ! double cryst. (bragg scattering)
call NESS(11,0.d0)
else ! flux at the sample
call NESS(2+icom,0.d0)
endif
endif
return
end
#***********************************************************************
SUBROUTINE SCAN_CHI(icom)
# Make a scan with monochromator cutting angle
# arguments are STEP [deg], NSTEPS, [NEVENTS]
# simulates powder diffration
#***********************************************************************
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'trax.inc'
integer*4 icom,nchi,i
real*4 ev,dchi,chi0
1 format( 'CHI = ',g12.6)
if (nos.ge.2) then
call NESS_CONV(1)
chi0=himon
dchi=ret(1)
nchi=nint(ret(2))
ev=10.d0
if(nos.ge.3) ev=ret(3) ! number of events
if (nchi.gt.100) nchi=100
if (nchi.lt.1) nchi=1
do i=1,nchi
himon=chi0+(i-(nchi+1)/2)*dchi
call NESS_CONV(0)
write(sout,1) mon.chi*180/pi
call NESS(9,-abs(ev))
enddo
himon=chi0
call NESS_CONV(0)
endif
end
#***********************************************************************
SUBROUTINE SCAN_TAS
# /// simulate standard TAS scan (DH,DK,DL,DE)
#//// using scattering cross-section defined by SQE_AMAG funciton
# accepts 4 arguments:
# a1 ... number of steps (obligatory)
# a2 ... number of events (x1000) , default=10
# a3 ... time (~monitor counts), default=100
# a4 ... background (in cnts), default=0
#***********************************************************************
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'rescal.inc'
integer*4 i,j,nstp
real*8 ev,monef
parameter(monef=1d-8)
real*8 cnts(128),cntd(128),cnte(128),ki(128),time,bcg
real*8 qhkl0(4),k0
real*4 GASDEV
1 format(i3,2x,4(g10.4,1x),2(g12.4,2x))
2 format( 'PNT QH QK QL EN CNTS MON')
3 format( 'PNT QH QK QL EN CNTS TIME')
if (nos.ge.1) then
k0=stp.ki
call NESS_CONV(1)
do j=1,4
qhkl0(j)=qhkl(j)
enddo
# WRITE(SOUT,1) (QHKL0(J),J=1,4)
# pause
nstp=nint(ret(1))
ev=10.d0
if(nos.ge.2) ev=ret(2) ! number of events
time=100.d0
if(nos.ge.3) time=ret(3) ! time
bcg=0.d0
if(nos.ge.4) bcg=ret(4) ! background
if (nstp.gt.100) nstp=100
if (nstp.lt.1) nstp=1
write(sout,2)
do i=1,nstp
do j=1,4
qhkl(j)=qhkl0(j)+(i-(nstp+1)/2)*delq(j)
enddo
call NESS_CONV(1)
call NESS(8,abs(ev))
cnts(i)=iinc
cntd(i)=time*i3ax
cnte(i)=time*di3ax
ki(i)=stp.ki
write(sout,1) i,(qhkl(j),j=1,4),cntd(i),cnts(i)
enddo
do j=1,4
qhkl(j)=qhkl0(j)
enddo
call NESS_CONV(1)
do i=1,nstp
spcx(i)=qhkl0(4)+(i-(nstp+1)/2)*delq(4)
spcy(i)=cntd(i)/cnts(i)/monef ! normalize to monitor counts
spcd(i)=cnte(i)/cnts(i)/monef
enddo
write(sout,3)
do i=1,nstp
if (bcg.gt.0) then ! add const. background and errors
spcy(i)=spcy(i)+bcg
spcd(i)=sqrt(abs(spcy(i))+spcd(i)**2)
spcy(i)=spcy(i)+sqrt(abs(spcy(i)))*GASDEV()
endif
write(sout,1) i,(qhkl0(j)+(i-(nstp+1)/2)*delq(j),j=1,4),
* spcy(i),time/monef/cnts(i)*ki(i)
enddo
spcn=nstp
endif
end
#***********************************************************************
SUBROUTINE SCAN_THETA
# /// simulate standard TAS scan (A1,A2,A3,A4,A5,A6)
# accepts 4 arguments:
# a1 ... number of steps (obligatory)
# a2 ... number of events (x1000) , default=10
# a3 ... time (~monitor counts), default=100
# a4 ... background (in cnts), default=0
#***********************************************************************
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 mf
parameter (mf=65)
integer*4 nstp
real*8 ev,monef
parameter(monef=1d-8)
integer*4 i_io
character*128 line
character*50 filename
real*8 ar(6)
integer*4 na,ia(6),iwhat,k,i,j
real*4 fx(mf),fy(mf),dfy(mf),fy1(mf),dfy1(mf)
real*8 cnts(128),cntd(128),cnte(128),time
4 format( 'A',i1, ' ',$)
5 format(g10.4,1x,$)
55 format(2(g10.4,1x))
6 format( 'Axes [1..6]: ',$)
7 format(a)
8 format( 'Steps [min]: ',$)
9 format( '(1) Sample, (2) Powder, (3) Double-Crystal, (4) TAS :',$)
44 format(1x,4(2x,e13.5))
if (nos.lt.1) then
write(sout,*) 'Use number of points as the 1st argument'
return
endif
write(sout,9)
read(sinp,*) iwhat
if (iwhat.eq.4) then
call SCAN_TAS
return
else if (iwhat.lt.1.or.iwhat.gt.4) then
write(*,*) 'UNDEFINED TASK: ',iwhat
return
endif
#// initialize
call NESS_CONV(1)
do j=1,6
dthax(j)=0.
ia(j)=j
ar(j)=0.
enddo
#// interpret arguments
nstp=nint(ret(1))
ev=10.d0
if(nos.ge.2) ev=ret(2) ! number of events
time=1.d0
if(nos.ge.3) time=ret(3) ! time
if (nstp.gt.101) nstp=101
if (nstp.lt.1) nstp=1
#// read angular steps from input
write(sout,6)
read(sinp,7) line ! read axes indexes
call GETLINPARG(line,ar,6,na)
do i=1,na
ia(i)=int(ar(i))
if(ia(i).gt.6.or.ia(i).le.0) ia(i)=0
enddo
write(sout,8)
read(sinp,7) line ! read axes steps
call GETLINPARG(line,ar,6,j)
if (j.ne.na) then
write(*,*) 'EACH AXIS MUST HAVE A STEP DEFINED !!'
endif
do i=1,na
write(sout,4) ia(i)
enddo
write(sout,*)
do i=1,na
write(sout,5) ar(i)
enddo
write(sout,*)
#// get only valid steps
k=0
do i=1,na
if (ia(i).ne.0.and.ar(i).ne.0) then
k=k+1
ar(k)=ar(i)
ia(k)=ia(i)
write(sout,4) ia(i) ! write header
endif
enddo
na=k
write(sout,*) 'CNTS ERR'
do j=1,mf
fy1(j)=0
dfy1(j)=0
enddo
#// Start scan
do i=1,nstp
do j=1,na
dthax(ia(j))=(i-(nstp+1)/2)*ar(j)
enddo
do j=1,na
write(sout,5) dthax(ia(j))
enddo
call NESS_CONV(0)
if (iwhat.eq.1) then
call NESS(2,abs(ev))
cntd(i)=time*iinc
cnte(i)=time*diinc
else if (iwhat.eq.2) then
call NESS(4,abs(ev))
cntd(i)=time*ipwd
cnte(i)=time*dipwd
else if (iwhat.eq.3) then
call NESS(11,abs(ev))
cntd(i)=time*i3ax
cnte(i)=time*di3ax
endif
cnts(i)=iinc
write(sout,55) cntd(i),cnte(i)
call PSD_ARRAY(fx,fy,dfy,mf)
do j=1,mf
fy1(j)=fy1(j)+fy(j)
dfy1(j)=dfy1(j)+dfy(j)**2
enddo
enddo
#// End scan, reset configuration
do j=1,mf
dfy1(j)=sqrt(dfy1(j))
enddo
do j=1,6
dthax(j)=0.
enddo
call NESS_CONV(0)
#// save integrated profile at the PSD
i_io=22
filename= ' '
12 format(a50)
13 format( ' PSD data output: ',$)
write(sout,13)
read(sinp,12) filename
if(filename(1:1).eq. ' '.or.filename(1:1).eq.char(0)) then ! generate automatic filename
goto 200
else
open(unit=i_io,file=filename,err=999,status= 'Unknown')
write(i_io,*) 'X INT ERR '
do i=1,mf
write(i_io,44) fx(i),fy1(i),dfy1(i)
enddo
close(i_io)
endif
#// Fill arrays with results
200 do i=1,nstp
spcx(i)=(i-(nstp+1)/2)*ar(1)
spcy(i)=cntd(i)
spcd(i)=cnte(i)
enddo
#// List data
do j=1,na
write(sout,4) j
enddo
write(sout,*) 'CNTS ERR'
do i=1,nstp
do j=1,na
write(sout,5) (i-(nstp+1)/2)*ar(j)
enddo
write(sout,55) spcy(i),spcd(i)
enddo
spcn=nstp
return
999 write(*,*) 'Cannot open file as unit ',i_io
return
end
#
#***********************************************************************
SUBROUTINE BENCH
# /// simulate flux at the sample (arg<>2) or at the detector (arg=2)
# /// by forward method (ICOM=1) or "from the sample" (ICOM=0)
#***********************************************************************
#
implicit none
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 nb
nb=1000
imonit=-1
if(nos.gt.0) nb=nint(1000*ret(1))
call NESS_CONV(1)
call NESS(2,0.d0)
call NESS_BENCH(nb)
return
end
#
#
#***********************************************************************
SUBROUTINE ROCK(icr)
# simulates rocking curve for monochromator (icr=1) or analyzer (icr=2)
# arguments: NEVENTS, NSTEPS, STEP [min]
# saves results in rcurve.dat
#***********************************************************************
#
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 icr,nc,nth,i
real*8 rth(129),dth,divh,divv
nc=1000
nth=65
dth=2./180./60.*pi
divh=0.
divv=0.
if(nos.gt.0) nc=nint(1000*ret(1))
if(nos.gt.1) nth=nint(ret(2))
if(nth.lt.11) nth=11
if(nth.gt.129) nth=129
if(nos.gt.2) dth=ret(3)/180/60*pi
if(nos.gt.3) divh=ret(4)/180/60*pi
if(nos.gt.4) divv=ret(5)/180/60*pi
call NESS_CONV(1)
call SPEC_INI(0,3)
if (nos.gt.0.and.ret(1).eq.0.) then
call TEST_SYMMETRY(nc,nth,dth,divh,divv)
else
call NESS_ROCK(icr,nc,nth,dth,rth,divh,divv)
open(22,file= 'rcurve.dat',status= 'unknown',err=100)
1 format(a)
2 format(2(e11.5,4x))
write(22,1) 'theta[min] r(theta)'
do i=1,nth
write(22,2) (-(nth-1)/2.+i*1.)*dth*180*60/pi,rth(i)
enddo
100 close(22)
endif
return
end
#
#***********************************************************************
SUBROUTINE TYPECFG
# /// print complete configuration of all components
#***********************************************************************
#
implicit none
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 n
call NESS_CONV(1)
if(nos.gt.0) then
n=nint(ret(1))
if (n.gt.9) then
call SPEC_INI(0,8)
else
call SPEC_INI(0,3)
endif
if(n.eq.1) call SLIT_WRITE(sout,sou)
if(n.eq.2) call BENDER_WRITE(sout,gdea)
if(n.eq.3) call BENDER_WRITE(sout,guide)
if(n.eq.4) call BENDER_WRITE(sout,sol1)
if(n.eq.5) call CRYST_WRITE(sout,mon)
if(n.eq.6) call BENDER_WRITE(sout,sol2a)
if(n.eq.7) call BENDER_WRITE(sout,sol2)
if(n.eq.8) call SLIT_WRITE(sout,sam)
if(n.eq.9) call BENDER_WRITE(sout,sol3)
if(n.eq.10) call CRYST_WRITE(sout,ana)
if(n.eq.11) call BENDER_WRITE(sout,sol4)
if(n.eq.12) call SLIT_WRITE(sout,det)
else
call SPEC_INI(0,8)
call WRITE_SETUP(sout,8)
endif
return
end
#-----------------------------------------------------------
SUBROUTINE SET_DEVICE(sarg)
# set graphics device string for PGPLOT
#-----------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
character*60 dst
integer*4 i,pgbegin
1 format( ' Graphics device (? for help) : ',$)
2 format(a)
#// write(sout,*) DEVSTR
write(sout,*) "present device: ",devstr
if (sarg.ne. ' ') then
devstr=sarg
write(sout,*) "new device: ",devstr(1:i)
else
write(sout,1)
read(sinp,2) dst
201 i=pgbegin(0,dst,1,1)
if (i.ne.1) then
write(smes,*) "pgbegin error: ",i
dst= '?'
goto 201
end if
call pgqinf( 'DEV/TYPE',devstr,i)
write(smes,*) "new device: ",devstr(1:i)
call pgend
return
endif
end
#-----------------------------------------------------------
SUBROUTINE SETVAR(ivar)
#
#-----------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'source.inc'
integer*4 ivar
1 format( ' Source flux [1e14 n/s/cm^2] : ',f10.4)
2 format( ' Source temperature [K] : ',f6.0)
if (ivar.eq.1) then
if(nos.ne.0) sflux=ret(1)
write(sout,1) sflux
endif
if (ivar.eq.2) then
if(nos.ne.0) stemp=ret(1)
write(sout,2) stemp
endif
return
end
#-------------------------------------------------------------
SUBROUTINE SETCFG(sarg)
# Read configuration file
# IF IREAD>0, prepare also all calculated fields and run TRAX!
#-------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
character*128 name,fn,fres
integer*4 is,il,ires,isc,ilc
logical*4 isdefname,iscreated
1 format( ' Configuration file [*.cfg]: ',$)
11 format( ' Configuration file [',a, ']: ',$)
2 format(a)
3 format( 'Cannot find configuration file ',a,/,
* '=> trying default: ',a)
4 format( 'Cannot find configuration file ',a,/,
* '=> trying the previous one: ',a)
5 format( 'Could not open any configuration file !!')
6 format( 'Could not find default cfg. file ',
& '=> creating one in current directory')
iscreated=.false.
# Get filename from dialog or from the argument SARG
call BOUNDS(sarg,is,il)
call BOUNDS(cfgname,isc,ilc)
if (il.eq.0) then
if (ilc.le.0) then ! both SARG and CFGNAME are empty
write(smes,1)
read(sinp,2) name
else
write(sout,11) cfgname(isc:isc+ilc-1) ! offer current CFGNAME as default
read(sinp,2) name
if (name.eq. ' ') name=cfgname(isc:isc+ilc-1)
endif
else
name=sarg(is:is+il-1)
endif
10 call BOUNDS(name,is,il)
fn=name(is:is+il-1)
isdefname=(fn(1:il).eq.rescal_defname) ! is FN the default filename ?
# Add .cfg extension if NAME doesn't have one
if (il.le.4.or.fn(il-3:il).ne. '.cfg') then
if (128.ge.il+4) then ! append .cfg if there is enough space
fn=name(is:is+il-1)// '.cfg'
il=il+4
endif
endif
call CHECKRESFILE(fn,ires,fres,silent)
# file not found:
if (ires.le.0) then
if(isdefname) then ! default not found => create one
write(sout,6)
call WRITEDEFCFG
iscreated=.true.
goto 10
else if (ilc.gt.0) then ! there is a previous filename => try it
write(sout,4) fn(1:il),cfgname(isc:isc+ilc-1)
name=cfgname(isc:isc+ilc-1)
goto 10
else if (.not.iscreated) then ! try the default
write(sout,3) ' ',rescal_defname
name=rescal_defname
goto 10
else ! something is wrong - file was created but cannot read it !
write(sout,5) ! should not happen except the lack of write privileges or quota
return
endif
endif
# note: CFGNAME=FN is without path, FRES is complete pathname
call BOUNDS(fres,is,il)
cfgname=fn
call READCFG(fres(is:is+il-1)) ! read parameters from *.cfg
end
#-----------------------------------------------------------------------
SUBROUTINE SETPATH(sarg)
# select search path for data files
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
character*128 mypath
integer*4 is,il
1 format( ' Path to data files [',a, '] : ',$)
2 format(a)
3 format( ' Data in ',a)
call BOUNDS(datpath,is,il)
# Get pathname from dialog or from the argument SARG
if (sarg.eq. ' ') then
if (il.le.0) then
write(sout,1) 'current folder'
read(sinp,2) mypath
else
write(sout,1) datpath(is:is+il-1)
read(sinp,2) mypath
if (mypath(1:1).eq. ' '.or.mypath(1:1).eq.char(0)) then
mypath=datpath(is:is+il-1)
endif
endif
else
mypath=sarg
endif
# Interpret MYPATH, ensure that ending / is present
call BOUNDS(mypath,is,il)
if ((il.le.0).or.
* (il.eq.1.and.mypath(is:is+il-1).eq. '.').or.
* (il.eq.2.and.mypath(is:is+il-1).eq. '.'//pathdel)) then
datpath= ' '
write(sout,3) 'current folder'
return
endif
if(mypath(is+il-1:is+il-1).ne.pathdel) then
datpath=mypath(is:is+il-1)//pathdel
else
datpath=mypath(is:is+il-1)
endif
write(sout,3) datpath(1:il)
end
#-----------------------------------------------------------------------
SUBROUTINE SETRESPATH(sarg)
# select search path for configuration files
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
character*128 mypath
integer*4 is,il
1 format( ' Additional search path for configuration files [',
* a, '] : ',$)
2 format(a)
3 format( ' Configurations in ',a)
call BOUNDS(respath,is,il)
# Get pathname from dialog or from the argument SARG
if (sarg.eq. ' ') then
if (il.le.0) then
write(sout,1) 'current folder'
read(sinp,2) mypath
else
write(sout,1) respath(is:is+il-1)
read(sinp,2) mypath
if (mypath(1:1).eq. ' '.or.mypath(1:1).eq.char(0)) then
mypath=respath(is:is+il-1)
endif
endif
else
mypath=sarg
endif
# Interpret MYPATH, ensure that ending / is present
call BOUNDS(mypath,is,il)
if ((il.le.0).or.
* (il.eq.1.and.mypath(is:is+il-1).eq. '.').or.
* (il.eq.2.and.mypath(is:is+il-1).eq. '.'//pathdel)) then
respath= ' '
write(sout,3) 'current folder'
return
endif
if(mypath(is+il-1:is+il-1).ne.pathdel) then
respath=mypath(is:is+il-1)//pathdel
else
respath=mypath(is:is+il-1)
endif
write(sout,3) respath(1:il)
end
#-----------------------------------------------------------------------
SUBROUTINE LIST
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
integer*4 i1,i
19 format( ' ',a5, ' = ',g14.7,1x,$)
51 format( ' ',2(a4, ' = ',f10.5,1x),/, ! DM,DA
2 ' ',3(a4, ' = ',f10.2,1x),/, ! ETAM,ETAA,ETAS
3 ' ',3(a4, ' = ',f10.0,1x),/, ! SM,SA,SS
4 ' ',a4, ' = ',f10.5,1x, a4, ' = ',f10.0,1x,/, ! KFIX,FX
5 ' ',4(a4, ' = ',f10.2,1x),/, ! ALF1..4
6 ' ',4(a4, ' = ',f10.2,1x),/, ! BET1..4
7 4( ' ',3(a4, ' = ',f10.4,1x)/), ! AS,AA,AX,BX
1 ' ',4(a4, ' = ',f10.4,1x),/, ! QH..EN
2 ' ',4(a4, ' = ',f10.4,1x),/, ! DQH..DE
2 ' ',2(a4, ' = ',f10.4,1x),/, ! DA3,DA4
3 ' ',4(a4, ' = ',f10.4,1x),/, ! GH..GL,GMOD
4 ' ',4(a4, ' = ',f10.4,1x),/, ! ROMH..ROAV
5 ' ',2(a4, ' = ',f10.2,1x)) ! SDI,SHI
if (nos.ge.1) then
do i=1,nos
i1=nint(ret(i))
if (i1.gt.0.and.i1.lt.res_nvar) then
write(sout,19) res_nam(i1),res_dat(i1)
endif
enddo
write(sout,*)
else
write(sout,51) (res_nam(i),res_dat(i),i=1,res_nvar)
# nos=0
# call SET_3AX(1)
# call SET_3AX(3)
# call SET_3AX(4)
# call SET_3AX(5)
# call SET_3AX(6)
endif
end
#--------------------------------
SUBROUTINE DOSHELL(comm)
# execute shell command
#--------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) comm
character*256 comm1
integer*4 is,l
1 format( ' Command : ',$)
2 format(a)
comm1= ' '
if((comm(1:1).eq. ' ').or.(comm(2:2).eq.char(0))) then
write(sout,1)
read(sinp,2) comm1
else
l=len(comm)
if(l.gt.256) l=256
comm1=comm(1:l)
endif
call BOUNDS(comm1,is,l)
if (l.gt.0) then
call system(comm1(is:is+l-1))
endif
end
#**********************************************************************
SUBROUTINE REINP(sarg)
# redirection of input
#***********************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
integer*4 iuini,iufile,ires
data iuini,iufile/0,10/
if(iuini.eq.0) iuini=sinp
if (sinp.ne.iuini) close(sinp)
if((sarg(1:1).ne. ' ').and.(sarg(1:1).ne.char(0))) then
call OPENRESFILE(sarg,iufile,ires,0)
if (ires.le.0) goto 2002
sinp=iufile
else
sinp=iuini
endif
return
2002 write(smes,*) 'Cannot open input file '//sarg
sinp=iuini
end
#**********************************************************************
SUBROUTINE REOUT(sarg)
# redirection of input
#***********************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
integer*4 iuini,iufile
data iuini,iufile/0,11/
if(iuini.eq.0) iuini=sout
if (sout.ne.iuini) close(sout)
if((sarg(1:1).ne. ' ').and.(sarg(1:1).ne.char(0))) then
open (unit=iufile,err=2002,name=sarg, status= 'UNKNOWN')
sout=iufile
else
sout=iuini
endif
# WRITE(*,*) SOUT
return
2002 write(smes,*) 'Cannot open output file '//sarg
sout=iuini
end
#-----------------------------------------------------
SUBROUTINE READINIFILE(jobname)
# read initialization file
# CFGNAME = configuration file
# DATAPATH = path to the data files
# OPENFILE = data or RESCAL file to open
# return JOBNAME .. filename of a job file to be executed at the startup
#-----------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*128 line
character*(*) jobname
integer*4 ires,ierr
1 format(a)
jobname= ' '
call OPENRESFILE( 'restrax.ini',22,ires,0)
if(ires.gt.0) then
ires=0
do while(ires.eq.0)
read(22,1,end=100,iostat=ires) line
if(line(1:1).ne. '#') then
call READ_STR( 'CFGNAME',line,cfgname,ierr)
call READ_STR( 'DATAPATH',line,datpath,ierr)
call READ_STR( 'JOB',line,jobname,ierr)
call READ_STR( 'OPENFILE',line,rescal_name,ierr)
endif
enddo
100 close(22)
endif
end
#-----------------------------------------------------------------------------
SUBROUTINE PROCARG
#// Process command line arguments for SIMRES
#-----------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'randvars.inc'
INCLUDE 'source.inc'
integer*4 i,j,m,is,il
character*128 s
integer*4 iargc
# Handle command-line options
m=iargc()
# Derive path to default setup files from executable pathname
call getarg(0,s)
i=index(s,pathdel// 'bin'//pathdel)
if (i.gt.1) then
cfgpath=s(1:i)// 'setup'//pathdel
else
cfgpath= 'setup'//pathdel
endif
idbg=0
irnd=0
iopt=1 ! automatic optimization by default
normmon=0 ! constant monitor efficiency (NOT ~ 1/k)
mdist=0
m=iargc()
do i=1,m
call getarg(i,s)
if (s(1:5).eq. '-dir=') then
call BOUNDS(s,is,il)
is=is+5
il=il-5
if(il.gt.0) then
respath=s(is:is+il-1)
if(respath(1:il).ne.pathdel) then ! add path delimiter
respath=respath(1:il)//pathdel
il=il+1
endif
write(sout,*) 'dir='//respath(1:il)
endif
else if (s(1:2).eq. '-d') then
idbg=2
read(s(3:3),*,err=10) j
if(j.ne.0) idbg=j
endif
10 if (s(1:2).eq. '-s') then
read(s(3:30),*) j
if(j.ne.0) then
iseed=abs(j)
write(sout,*) 'SEED=',iseed
endif
endif
if (s(1:2).eq. '-t') then
read(s(3:30),*,err=20) j
call RAN1SEED(iseed)
write(*,*) 'Test of the random number generator:'
call RAN1TEST(j,1000000*j)
20 goend=1
return
endif
if (s(1:4).eq. '-flx') then
call READ_FLUX(s(5:))
endif
if (s(1:4).eq. '-flh') then
read(s(5:30),*,err=30) flxh
flxh=flxh*pi/180
endif
30 if (s(1:4).eq. '-flv') then
read(s(5:30),*,err=35) flxv
flxv=flxv*pi/180
endif
35 if (s(1:3).eq. '-RB') then
read(s(4:30),*,err=40) cbar
write(*,*) 'Right barrier [mm]: ',cbar
endif
40 if (s(1:3).eq. '-MX') then
read(s(4:30),*,err=50) cmx
write(*,*) 'crystal shift x [mm]: ',cmx
endif
50 if (s(1:6).eq. '-Voigt') then
mdist=1
write(*,*) 'pseudo-Voigt mosaic distribution'
else if (s(1:7).eq. '-Lorenz') then
mdist=2
write(*,*) 'Lorenzian mosaic distribution'
else if (s(1:4).eq. '-Uni') then
mdist=3
write(*,*) 'Uniform mosaic distribution'
else
mdist=0
write(*,*) 'Gaussian mosaic distribution'
endif
if (s(1:4).eq. '-sil') then
read(s(5:30),*,err=60) silent
write(sout,*) 'SILENT=',silent
endif
60 if (s(1:5).eq. '-ran1') then
irnd=1
write(*,*) 'Numerical Recipes RAN1 generator'
endif
if (s(1:5).eq. '-rand') then
irnd=2
write(*,*) 'System random number generator'
endif
if (s(1:6).eq. '-noopt') then
iopt=0
write(*,*) 'No automatic sampling optimization'
endif
if (s(1:5).eq. '-nmon') then
normmon=1
write(*,*) 'Incident intensities ~ 1/ki'
endif
if (s(1:6).eq. '-cross') then
isqom=0
read(s(7:7),*,err=70) j
if(j.gt.0.and.j.le.3) isqom=j
if (isqom.eq.1) then
write(*,*) 'SCAN with antif. magnon cross-section'
else if (isqom.eq.2) then
write(*,*) 'SCAN with Vanadium sample'
endif
endif
70 if (s(1:4).eq. '-log') then
logfile=s(5:30)
write(*,*) 'Events logged in '//logfile
100 format( 'Log events between [min max]: ',$)
write(*,100)
read(*,*) logmin,logmax
endif
if (s(1:5).eq. '-help'.or.s(1:1).eq. '?') then
do j=1,18
write(*,*) hlpopt(j)
enddo
goend=1
endif
enddo
end
#-----------------------------------------------------------------------------
SUBROUTINE RESINIT
#// initialize RESTRAX
#// include all actions necessary to allocate memory,
#// initialize variables, print LOGO etc..
#-----------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'config.inc'
INCLUDE 'randvars.inc'
INCLUDE 'rescal.inc'
integer*4 ires
character*128 extname,outname,fname,jobname
real*8 HMOS_DIST
integer*4 i,READ_MIRROR
external HMOS_DIST
20 format( 'Using default RESCAL parameters: ',a)
# initialize error function
call ERF_INIT(HMOS_DIST,-6.d+0,6.d+0)
# clear mirror and flux lookup tables
i=READ_MIRROR(-1.d0)
call READ_FLUX( ' ')
# set path delimiter for M$ Windows
call MKUPCASE(sysname)
if (sysname(1:7).eq. 'WINDOWS') then
pathdel= '\'
endif
# default silence level:
silent=1
# initialize LINP
call LINPSET(res_nvar+res_ncmd, 'SimRes',res_nam,res_hlp)
call LINPSETIO(sinp,sout,smes)
goend=0
# Handle command-line options
call PROCARG
if (goend.ne.0) call RESEND
call RAN1SEED(iseed) ! Initialize random number generator
call LOGO ! print LOGO
call READINIFILE(jobname) ! read restrax.ini file
call SETRESPATH(respath) ! set default path for configuration
call UNITS(cunit) ! set units for energy (meV)
call SETPATH(datpath) ! set data path to current dir.
call SET_CRYST( 'Ge 111 ', 'Ge 111 ') ! read some crystal parameters
call getenv( 'PGPLOT_DEV',fname)
if(fname(1:1).ne. ' ') then
devstr=fname
endif
call OPENFILE(rescal_name,ires)
if (ires.le.0) then
call SETDEFRES
write(smes,20) rescal_defname
endif
call SETCFG(cfgname) ! Read the configuration file
# job file required by restrax.ini
if (jobname(1:1).ne. ' ') then
call REINP(jobname)
call LINPSETIO(sinp,sout,smes)
return
endif
# ask for a job file
2000 format(a30)
2001 format( ' batch file : ',$)
2004 format( ' output file : ',$)
write(*,2001)
read(*,2000) extname
if((extname(1:1).ne. ' ').and.(extname(1:1).ne.char(0))) then
call CHECKRESFILE(extname,ires,fname,silent)
if (ires.gt.0) then
write(*,2004)
read(*,2000) outname
if((outname(1:1).ne. ' ').and.(outname(1:1).ne.char(0))) then
call REOUT(outname)
write(sout,*) 'RESTRAX - batch job '//extname
endif
call REINP(fname)
call LINPSETIO(sinp,sout,smes)
# write(*,*) 'input/output is ',SINP,'/',SOUT
endif
endif
end
#-----------------------------------------------------------------------------
SUBROUTINE RESEND
#// end of RESTRAX
#// include all actions necessary to deallocate memory etc...
#-----------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
call REINP( ' ')
call REOUT( ' ')
call NESSEND ! NESSEND must be called to deallocate
write(smes,*) ' -> End of ResTrax'
stop
end