Source module last modified on Sat, 21 May 2005, 19:42;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#//////////////////////////////////////////////////////////////////////
#//// ////
#//// NEutron Scattering Simulation - v.1.2, (c) J.Saroun, 1997 ////
#//// update May 1998 (J.S.) ////
#//////////////////////////////////////////////////////////////////////
#////
#//// Subroutines specific to 3-axis spectrometers and conversion
#//// from the RESTRAX-parameter set.
#////
#//// * SUBROUTINE SET_3AX(ICOM)
#//// * LOGICAL*4 FUNCTION SPEC_GO(ICOM)
#//// * SUBROUTINE SPEC_INI(ICLR,IRES)
#//// * SUBROUTINE NESS_CONV
#//// * SUBROUTINE CREATE_SOL(SOL1,ALPHA,NFM,VLSM,VLCANM,HDM1,HDM2,
#//// VDM1,VDM2)
#//// * SUBROUTINE WRITE_SETUP(IC)
#////
#//// May 1998: SOLLERs replaced by BENDERs in all subroutines and commons
#//// SET_3AX(2) sets values of critical angles for BENDERs
#//// SET_3AX(3) sets values of BENDERs radii
#//// SET_3AX(4) switch on/off spin flippers
#//// SET_3AX(5) switch on/off magnetization of crystals
#//////////////////////////////////////////////////////////////////////
#*** bug fixed: GUIDE=2*GAMACR replaced by GUIDE=GAMACR*MON.LAMBDA
#*** (25/5/98 by J.S.)
#----------------------------------------------------------------
SUBROUTINE SET_3AX(icom)
# changes sample position (with a possibility to add
# other parameters not included in RESTRAX3 parameter set.
# Can be called by the RESTRAX main program as well as by
# the NESS interactive command interpreter (NESS_LOOP)
#----------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'collimators.inc'
INCLUDE 'source.inc'
INCLUDE 'rescal.inc'
# INCLUDE 'trax.inc'
integer*4 icom,npar,ndpar
parameter(ndpar=16)
real*4 param(ndpar)
integer*4 i,i1,i2
character*4 s1,s2
# WRITE(*,*) 'SET_3AX: ',ICOM,NOS
if(nos.gt.0.and.nos.le.ndpar) then
do i=1,nos
param(i)=ret(i)
end do
endif
npar=nos
# WRITE(*,*) 'SET_3AX: ',ICOM,NPAR,(PARAM(I),I=1,NPAR)
if(icom.eq.1) then
1 format( ' sample position [mm]: ',3(2x,f7.2))
if(npar.ge.2) sam.sta(1)=param(2)
if(npar.ge.3) sam.sta(2)=param(3)
if(npar.ge.1) sam.sta(3)=param(1)
param(2)=sam.sta(1)
param(3)=sam.sta(2)
param(1)=sam.sta(3)
write(sout,1) (param(i),i=1,3)
endif
if(icom.eq.3) then
3 format( ' crystal rocking angles [min]: ',2(2x,f10.4))
# WRITE(SOUT,*) 'Command not available'
# RETURN
if(npar.ge.1) dthax(1)=param(1)
if(npar.ge.2) dthax(5)=param(2)
param(1)= dthax(1)
param(2)= dthax(5)
write(sout,3) (param(i),i=1,2)
endif
if(icom.eq.4) then
4 format( ' Spin flippers : ',2(3x,a4))
if(npar.ge.1) flipm=nint(param(1))
if(npar.ge.2) flipa=nint(param(2))
param(1)=flipm
param(2)=flipa
s1= 'off '
s2= 'off '
if (flipm.gt.0) s1= 'on '
if (flipa.gt.0) s2= 'on '
write(sout,4) s1,s2
endif
if(icom.eq.5) then
5 format( ' Magnetization : ',2(3x,a4))
if(npar.ge.1) mon.mag=param(1)
if(npar.ge.2) ana.mag=param(2)
param(1)=mon.mag
param(2)=ana.mag
s1= 'off '
s2= 'off '
if (mon.mag.gt.0) s1= 'on '
if (ana.mag.gt.0) s2= 'on '
write(sout,5) s1,s2
endif
if(icom.eq.6) then
6 format( ' Spin transfer : ',a4, ' -> ',a4)
61 format( ' Spin transfer : all')
i1=mod(nint(spint),2)
i2=int(spint/2)
if(npar.ge.1) i1=nint(param(1))
if(npar.ge.2) i2=nint(param(2))
if((i1.eq.0.or.i1.eq.1).and.(i2.eq.0.or.i2.eq.1)) then
s1= 'up '
s2= 'up '
if (i1.eq.0) s1= 'down'
if (i2.eq.0) s2= 'down'
write(sout,6) s1,s2
spint=i1+2*i2
else
spint=-1
write(sout,61)
endif
endif
if(icom.eq.7) then
7 format( ' POLARIZING BENDERS: ',4(2x,i1))
if(npar.ge.1) polar(3)=param(1)
if(npar.ge.2) polar(5)=param(2)
if(npar.ge.3) polar(6)=param(3)
if(npar.ge.4) polar(7)=param(4)
do i=1,4
param(i)=0
enddo
if (polar(3).ne.0) param(1)=1
if (polar(5).ne.0) param(2)=1
if (polar(6).ne.0) param(3)=1
if (polar(7).ne.0) param(4)=1
write(sout,7) (nint(param(i)),i=1,4)
endif
if(icom.eq.8) then
81 format( ' Crystal name: ',$)
82 format(a8)
if (npar.gt.0.and.(param(1).eq.1).or.(param(1).eq.2)) then
if (param(1).eq.1) then
write(sout,81)
read(sinp,82) mon.frame.name
else if (param(1).eq.2) then
write(sout,81)
read(sinp,82) ana.frame.name
endif
endif
call SET_CRYST(mon.frame.name(1:8),ana.frame.name(1:8))
endif
if(icom.eq.9) then
9 format( ' Oscilating colimators: ',4(2x,i1))
if(npar.ge.1) osc(3)=(param(1).ne.0)
if(npar.ge.2) osc(5)=(param(2).ne.0)
if(npar.ge.3) osc(6)=(param(3).ne.0)
if(npar.ge.4) osc(7)=(param(4).ne.0)
do i=1,4
param(i)=0
enddo
if (osc(3)) param(1)=1
if (osc(5)) param(2)=1
if (osc(6)) param(3)=1
if (osc(7)) param(4)=1
write(sout,9) (nint(param(i)),i=1,4)
endif
if(icom.eq.2) then
2 format( 'monochromator: '/,
* ' d-gradient [0.001/cm]: ',g13.5,/,
* ' grad. angle [deg] : ',g13.5,/,
* ' lamella thickness [um]: ',g13.5)
if(npar.ge.1) mon.dgr=param(1)
if(npar.ge.2) mon.dga=param(2)*pi/180
if(npar.ge.3) mon.dlam=param(3)
write(sout,2) mon.dgr,mon.dga/pi*180,mon.dlam
endif
if(icom.eq.21) then
21 format( 'analyzer: '/,
* ' d-gradient [0.001/cm]: ',g13.5,/,
* ' grad. angle [deg] : ',g13.5,/,
* ' lamella thickness [um]: ',g13.5)
if(npar.ge.1) ana.dgr=param(1)
if(npar.ge.2) ana.dga=param(2)*pi/180
if(npar.ge.3) ana.dlam=param(3)
write(sout,21) ana.dgr,ana.dga/pi*180,ana.dlam
endif
if(icom.eq.10) then
10 format( ' dI/dx [%/cm] : ',g13.5,/,
* ' d2I/dx2 [%/cm2]: ',g13.5,/,
* ' centre [cm] : ',g13.5)
if(npar.ge.1) flxa=param(1)/1000
if(npar.ge.2) flxb=param(2)/10000
if(npar.ge.3) flx0=param(3)*10
write(sout,10) flxa*1000,flxb*10000,flx0/10
endif
if(icom.eq.11) then
11 format( ' dI/dy [%/cm] : ',g13.5,/,
* ' d2I/dy2 [%/cm2]: ',g13.5,/,
* ' centre [cm] : ',g13.5)
if(npar.ge.1) flya=param(1)/1000
if(npar.ge.2) flyb=param(2)/10000
if(npar.ge.3) fly0=param(3)*10
write(sout,10) flya*1000,flyb*10000,fly0/10
endif
if(icom.eq.12) then
120 format( ' Analyzer part is in normal position')
121 format( ' Analyzer part is turned up')
122 format( ' Analyzer part is turned down')
123 format( ' Analyzer part is turned up/down')
if(npar.ge.1) then
if (param(1).eq.1) then
cfgmode=1
else
cfgmode=0
endif
endif
if (cfgmode.eq.0) write(sout, 120)
if (cfgmode.eq.1.and.res_dat(i_sa).gt.0) write(sout,121)
if (cfgmode.eq.1.and.res_dat(i_sa).lt.0) write(sout,122)
if (cfgmode.eq.1.and.res_dat(i_sa).eq.0) write(sout,123)
endif
if(icom.eq.13) then
130 format( ' Normal mode')
131 format( ' Simulation in E=const. plane')
if (emode.ne.0) emode=1
if(npar.ge.1) then
if (param(1).eq.1) then
emode=1
else
emode=0
endif
endif
if (emode.eq.0) write(sout, 130)
if (emode.eq.1) write(sout,131)
endif
do i=1,nos
ret(i)=param(i)
end do
nos=0
return
end
#---------------------------------------------------------------
SUBROUTINE SET_CRYST(namem,namea)
#---------------------------------------------------------------
implicit none
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'rescal.inc'
character*8 namem,namea
83 format( ' Monochromator: ',a8, ' Analyzer: ',a8)
if(namem(1:1).ne. ' ') mon.frame.name=namem
if(namea(1:1).ne. ' ') ana.frame.name=namea
if(namem(1:1).ne. ' '.or.namea(1:1).ne. ' ') then
write(sout,83) mon.frame.name(1:8), ana.frame.name(1:8)
endif
call READCRYST(mon,mon.frame.name(1:8))
call READCRYST(ana,ana.frame.name(1:8))
if(mon.vol.ne.0) res_dat(i_dm)=mon.dhkl
if(ana.vol.ne.0) res_dat(i_da)=ana.dhkl
end
#----------------------------------------
logical*4 FUNCTION CHECKPARAM()
#-----------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
real*8 l1,l2,kfix,fx,en
logical*4 log
kfix=res_dat(i_kfix)
fx=res_dat(i_fx)
en=res_dat(i_en)
log=.true.
if (fx.eq.1.) then
l1=2.*pi/kfix
if(kfix**2-en/hsqov2m.gt.0.d0) then
l2=2.*pi/sqrt(kfix**2-en/hsqov2m)
else
log=.false.
write(smes,*) 'Energy transfer too large'
write(smes,*) 'KI=',kfix, ' E/hsqov2m=',en/hsqov2m
goto 100
endif
else
l2=2.*pi/kfix
if(kfix**2+en/hsqov2m.gt.0.d0) then
l1=2.*pi/sqrt(kfix**2+en/hsqov2m)
else
log=.false.
write(smes,*) 'Energy transfer too large'
write(smes,*) 'KF=',kfix, ' E/hsqov2m=',en/hsqov2m
goto 100
endif
endif
if (l1.ge.2.*res_dat(i_dm)) then
write(smes,*) 'monochromator dhkl too large!'
write(smes,*) 'lambda=',l1, ' 2d=',2.*res_dat(i_dm)
log=.false.
goto 100
endif
if (l2.ge.2.*res_dat(i_da)) then
write(smes,*) 'analyzer dhkl too large!'
write(smes,*) 'lambda=',l2, ' 2d=',2.*res_dat(i_da)
log=.false.
goto 100
endif
100 CHECKPARAM=log
end
#---------------------------------------------------------------
SUBROUTINE LOG_EVENT(neu)
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
record /NEUTRON/ neu
end
#--------------------------------------------------------
SUBROUTINE SPEC_INI(iclr,itask)
# Clears all necessary variables and, if ICLR<>1,
# initializes objects and limits of random variables
#
# ITASK=1 ... inelastic scattering, TAS resolution
# ITASK=2 ... sample -> source
# ITASK=3 ... source -> sample
# ITASK=4 ... sample -> source + sample(powder) -> detector (no analyser)
# ITASK=5 ... source -> sample + sample(powder) -> detector (no analyser)
# ITASK=6 ... sample -> source + sample (Vanad) -> monitor(IMONIT)
# ITASK=7 ... source -> monitor(IMONIT)
# ITASK=8 ... inelastic scattering, TAS resolution, splitted TAS1 and TAS2
# ITASK=9 ... elastic (powder) resolution function
# ITASK=10 ... powder (ITASK=4), splitted TAS1 and TAS2
# ITASK=11 ... source -> detector, Bragg scattering (or double-crystal for Q=0)
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'rescal.inc'
INCLUDE 'randvars.inc'
integer*4 i,j,iclr,itask
real*8 a1,a2,a3,ahmin,avmin,ctm,ah2,av2,c2ts
real*8 lms,lsa,cta,z,z1,sgnm,sgna,stmch,stach
real*8 b89
real*8 wmax,hmax,band
# REAL*8 AUX(CRND,CRND),DETERM
record /STATI/ cov_qe
integer*4 ierr,nev
common /errors/ ierr
common /result/ cov_qe
logical*4 verbose
common /mcsetting/ verbose,nev
real*8 GETEFFMOS,thm
# write(*,*) 'SPEC_INI(ICLR,ITASK)',ICLR,ITASK
call STAT_CLR(4,cov_qe)
sou.count=0
gdea.frame.count=0
guide.frame.count=0
sol1.frame.count=0
mon.frame.count=0
sol2.frame.count=0
sol2a.frame.count=0
sam.count=0
sol3.frame.count=0
ana.frame.count=0
sol4.frame.count=0
det.frame.count=0
if (iclr.eq.1) then
return
endif
#// Reconfigure setup in special cases:
#// Powder diffractometer -> skip analyzer and SOL4
if (itask.eq.4.or.itask.eq.5.or.itask.eq.9)
* det.frame.dist=ana.frame.dist+sol4.frame.dist+det.frame.dist
#// set number of random values
if(itask.eq.1.or.itask.eq.8) then
rndlist.dim=9
if (emode.eq.1) rndlist.dim=8
endif
if(itask.eq.2.or.itask.eq.3.or.itask.eq.11) rndlist.dim=6
if(itask.eq.4.or.itask.eq.5) rndlist.dim=7
if(itask.eq.6.or.itask.eq.7.or.itask.eq.9) rndlist.dim=8
if(itask.eq.7.and.imonit.le.7) rndlist.dim=6
do 30 i=1,rndlist.dim
rndlist.mean(i)=0.d0
rndlist.pool(i)=1.1d0
rndlist.active(i)=1
30 continue
#// set time variable inactive
rndlist.active(6)=0
rndlist.limits(6)=1.d0
rndlist.pool(6)=1d0
#// initialize transformation matrix
do 80 i=1,crnd
do 80 j=1,crnd
if (i.ne.j) then
tmat(i,j)=0.d0
else
tmat(i,j)=1.d0
endif
80 continue
do i=1,rndlist.dim
tmean(i)=0.d0
enddo
#// Set mean ki value
sgnm=-sign(1,stp.sm) ! "minus" because of the up-stream tracing
thm=abs(mon.frame.gon(1)-sgnm*pi/2.+mon.chi)
tmean(3)=pi/mon.dhkl/sin(thm)
# ******************************************************
# *
# PRIMARY SPECTROMETER *
# *
# ******************************************************
#// Call another initialization procedure for the simulation started
#// from the source
if(itask.eq.3.or.itask.eq.5.or.itask.eq.7.or.ftas.gt.0) then
call FORW_INI(itask)
else
#// Initialize components
call SLIT_INIT(sou)
call BENDER_INIT(gdea)
call BENDER_INIT(guide)
call BENDER_INIT(sol1)
call CRYST_INIT2(mon)
call BENDER_INIT(sol2)
call BENDER_INIT(sol2a)
call SLIT_INIT(sam)
#// calculate maximum angular deviations for the secondary spectrometer
# CALL APERTURE1(ITASK,ahmin,avmin)
call APERTURE1(itask,ahmin,avmin,wmax,hmax,band)
1 format(a,5(2x,g12.6))
# write(*,*) 'APERTURE1 ',ahmin,avmin,wmax,hmax,band
lms=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
ctm=sgnm/tan(thm)
stmch=sin(thm-sgnm*mon.chi)
#// common constraints for simulation started at the sample
if(mon.nh.gt.1.or.mon.hmos.le.sec) then
z=1.d0
else
z=0.d0
endif
rndlist.limits(1)=ahmin*rndlist.pool(1)
rndlist.limits(2)=avmin*rndlist.pool(2)
# get contributions to Bragg angle spread
# a1=4*mon.hmos ! mosaicity
# a2=GETEFFMOS(MON)
# a3=0.5*tan(mon.thb)*(avmin/2)**2 ! vertical divergence
# RNDLIST.LIMITS(3)=SQRT(a1**2+a2**2+a3**2)*stp.ki*abs(ctm)*
# * RNDLIST.POOL(3)
# RNDLIST.LIMITS(4)=sam.size(1)*RNDLIST.POOL(4)
# RNDLIST.LIMITS(5)=sam.size(2)*RNDLIST.POOL(5)
rndlist.limits(3)=band*stp.ki*abs(ctm)* rndlist.pool(3)
rndlist.limits(4)=wmax*rndlist.pool(4)
rndlist.limits(5)=hmax*rndlist.pool(5)
tmat(5,2)=-1./lms
# Except fully asymmetric case
if(mon.frame.size(1)*abs(stmch).gt.mon.frame.size(3)) then
tmat(1,3)=(1.d0-lms*z*mon.rh/stmch)*ctm*stp.ki
tmat(4,3)=-z*mon.rh*stp.ki/stmch*ctm
endif
#// no constraints in debug mode
if (idbg.ge.1) then
rndlist.limits(1)=ahmin
rndlist.limits(2)=avmin
rndlist.limits(3)=0.05*stp.ki
rndlist.limits(4)=sam.size(1)
rndlist.limits(5)=sam.size(2)
endif
endif
# ******************************************************
# *
# SECONDARY SPECTROMETER *
# *
# ******************************************************
#// Initialize components
call BENDER_INIT(sol3)
call CRYST_INIT2(ana)
call BENDER_INIT(sol4)
call SLIT_INIT(det.frame)
#// calculate maximum angular deviations for the secondary spectrometer
call APERTURE2(itask,ah2,av2)
# write(*,*) 'APERTURE2 ',ah2,av2
if (rndlist.dim.ge.7) then
rndlist.active(7)=1
rndlist.limits(7)=av2
endif
if (rndlist.dim.ge.8) then
rndlist.active(8)=1
rndlist.limits(8)=ah2
endif
if(ana.nh.gt.1.or.ana.hmos.le.sec) then
z=1.d0
else
z=0.d0
endif
#/// for monitor after Vanad sample and analyzer
if(itask.eq.6.and.imonit.ge.9) then
sgna=sign(1,stp.sa)
cta=sgna/tan(ana.thb)
stach=sin(ana.thb-sgna*ana.chi)
lsa=sol3.frame.dist+ana.frame.dist
z1=1.d0-z*ana.rh*lsa/stach
# get contributions to Bragg angle spread
a1=4*ana.hmos ! mosaicity
a2=GETEFFMOS(ana)
if (abs(z1).gt.0.05) then
if(cfgmode.eq.1) then
tmat(3,7)=1.d0/cta/z1/stp.kf
else
tmat(3,8)=1.d0/cta/z1/stp.kf
endif
# TMAT(4,8)=COMEGA*Z*ana.rh/stach/Z1
rndlist.limits(8)=sqrt((sam.size(1)/lsa)**2+a1**2+a2**2)
endif
endif
#/// for powder diffractometer, initial optimization of vertical scatt. angle
if(itask.eq.4) then
c2ts=comega/somega
if(abs(c2ts).lt.5) tmat(2,7)=c2ts/stp.ki
endif
if(itask.eq.5) then
c2ts=comega/somega
if(abs(c2ts).lt.5) tmat(2,7)=-c2ts/stp.ki
endif
#/// for inelastic scattering (TAS resolution)
if(itask.eq.1.or.itask.eq.8) then
rndlist.active(9)=1
sgna=sign(1,stp.sa)
cta=sgna/tan(ana.thb)
stach=sin(ana.thb-sgna*ana.chi)
lsa=sol3.frame.dist+ana.frame.dist
# get contributions to Bragg angle spread
a1=4*ana.hmos ! mosaicity
a2=GETEFFMOS(ana)
a3=0.5*tan(ana.thb)*(av2/2)**2 ! vertical divergence
rndlist.limits(9)=sqrt(a1**2+a2**2+a3**2)*stp.kf*abs(cta)
b89=(1.d0-lsa*z*ana.rh/stach)*cta*stp.kf
if(cfgmode.eq.1) then
tmat(7,9)=b89
# TMAT(7,9)=-B89/HSQOV2M/STP.KF
tmat(5,9)=comega*z*ana.rh/stach*cta*stp.kf
else
tmat(8,9)=(1.d0-lsa*z*ana.rh/stach)*cta*stp.kf
tmat(4,9)=comega*z*ana.rh/stach*cta*stp.kf
endif
endif
#/// for tracing through the secondary spectrometer only
if(itask.eq.8.or.itask.eq.9) then
do i=1,6
rndlist.active(i)=0
rndlist.limits(i)=1
enddo
tmat(4,9)=0.d0
endif
#// no constraints in debug mode
if (idbg.ge.1) then
rndlist.limits(7)=av2
rndlist.limits(8)=ah2
rndlist.limits(9)=0.05*stp.kf
do i=1,rndlist.dim
do j=1,rndlist.dim
if (i.ne.j) then
tmat(i,j)=0.d0
else
tmat(i,j)=1.d0
endif
end do
end do
write(sout,*) 'No initial correlations'
endif
if (verbose) then
write(sout,*) 'Monte-Carlo variables initialized.'
call WRITE_SETUP(20,itask)
endif
# WRITE(SOUT,*) 'SPEC_INI done.'
# CALL WRITE_SETUP(20,ITASK)
#100 FORMAT('TMAT: ',16(1X,G10.4))
#101 FORMAT('TLIM: ',16(1X,G10.4))
# write(*,*)
# DO I=1,RNDLIST.DIM
# write(*,100) (TMAT(I,J),J=1,RNDLIST.DIM)
# ENDDO
# write(*,101) (RNDLIST.LIMITS(J),J=1,RNDLIST.DIM)
# write(*,*)
# write(*,*) 'DET(TMAT)= ',DETERM(TMAT,CRND,AUX)
return
999 ierr=2
return
end
#---------------------------------------------------------------------
logical FUNCTION SPEC_GO(itask)
# traces neutron trajectories starting at the sample
# ITASK=1 ... inelastic scattering, TAS resolution
# ITASK=2 ... sample -> source
# ITASK=3 ... source -> sample
# ITASK=4 ... sample -> source + sample(powder) -> detector (no analyser)
# ITASK=5 ... source -> sample + sample(powder) -> detector (no analyser)
# ITASK=6 ... sample -> source + sample (Vanad) -> monitor(IMONIT)
# ITASK=7 ... source -> monitor(IMONIT)
# The neutron coordinates are stored in the following order
# NEUI1(source) -> NEUI(incident) -> NEUF(scattered) -> NEUF1(detector)
#----------------------------------------------------------------------
implicit none
integer*4 itask
logical DIFF_GO,MONIT_GO,INELAST_GO,FLUX_GO, DIFF_GO2,
* MONIT_GO2,FLUX_GO2,TAS2_GO, DIFF2_GO, DIFF3_GO,DCRYST_GO
if(itask.eq.1) then
SPEC_GO=INELAST_GO()
return
else if(itask.eq.2) then
SPEC_GO=FLUX_GO()
return
else if(itask.eq.3) then
SPEC_GO=FLUX_GO2()
return
else if(itask.eq.4) then
SPEC_GO=DIFF_GO()
return
else if(itask.eq.5) then
SPEC_GO=DIFF_GO2()
return
else if(itask.eq.6) then
SPEC_GO=MONIT_GO()
return
else if(itask.eq.7) then
SPEC_GO=MONIT_GO2()
return
else if(itask.eq.8) then
SPEC_GO=TAS2_GO()
return
else if(itask.eq.9) then
SPEC_GO=DIFF2_GO()
return
else if(itask.eq.10) then
SPEC_GO=DIFF3_GO()
return
else if(itask.eq.11) then
SPEC_GO=DCRYST_GO()
return
else
SPEC_GO=.false.
endif
end
#---------------------------------------------------------------
logical FUNCTION FLUX_GO()
# simulate incident flux, start at the sample
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu
logical TAS1_GO,SLIT_GO
logical*4 log
common /neuif/ neui,neuf,neui1,neuf1
# LOG=SLIT_GO(SAM,NEUI,NEU)
# NEUI=NEU
# IF (LOG) LOG=TAS1_GO()
log=TAS1_GO()
neu=neui
if (log) log=(log.and.SLIT_GO(sam,neu,neui))
FLUX_GO=log
end
#---------------------------------------------------------------
logical FUNCTION TAS1_GO()
# trace primary TAS spectrometer from the sample
#---------------------------------------------------------------
implicit none
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
common /neuif/ neui,neuf,neui1,neuf1
real*8 t1,t2
# LOG=.TRUE.
log=SAM_BOARDER(sam,neui.r,neui.k,t1,t2)
log=(log.and.neui.p.gt.0)
neu1=neui
if(flipm.eq.1) neu1.s=-neu1.s
if(log) log=(log.and.BENDER_GO(sol2,neu1,neu))
if(log) log=(log.and.BENDER_GO(sol2a,neu,neu1))
if(log) log=(log.and.CRYST_GO2(mon,neu1,neu))
if(log) log=(log.and.BENDER_GO(sol1,neu,neu1))
if(log) log=(log.and.BENDER_GO(guide,neu1,neu))
if(log) log=(log.and.BENDER_GO(gdea,neu,neu1))
if(log) then
log=(log.and.SOURCE_GO(sou,neu1,neui1))
neui.p=neui1.p
neui1=neui
neui1.r(1)=-neui1.r(1)
neui1.k(2)=-neui1.k(2)
neui.r(1)=-neui.r(1)
neui.k(2)=-neui.k(2)
endif
TAS1_GO=log
end
#---------------------------------------------------------------
logical FUNCTION DIFF_GO()
# trace from the source to the detector with pwd. sample
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,PWD_GO,TAS1_GO,DETECT_GO
logical*4 log
common /neuif/ neui,neuf,neui1,neuf1
log=TAS1_GO()
if(log) log=(log.and.PWD_GO(sam,neui,neuf,stp.q*stp.ss))
neu=neuf
if(flipa.eq.1) neu.s=-neu.s
if(log) log=(log.and.BENDER_GO(sol3,neu,neu1))
if(log) log=(log.and.DETECT_GO(det,neu1,neuf1))
DIFF_GO=log
return
end
#---------------------------------------------------------------
logical FUNCTION MONIT_GO()
# trace from the source to the monitor at position IMONIT
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'randvars.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,SLIT_GO,CRYST_GO2,TAS1_GO,DETECT_GO
logical VAN_GO,VAN_TRANS,log
integer*4 m
common /neuif/ neui,neuf,neui1,neuf1
real*8 ll
integer*4 i
m=imonit
log=TAS1_GO()
if(.not.log) goto 999
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
neuf1=neuf
goto 100
endif
if (m.eq.6) then
if(log) log=(log.and.SLIT_GO(sam,neui,neuf))
neuf1=neuf
goto 100
endif
# call WrtNeu(NEUI)
if(log) log=(log.and.VAN_GO(sam,neui,neuf,stp.q*stp.ss))
# call WrtNeu(NEUF)
neu1=neuf
if(flipa.eq.1) neu1.s=-neu1.s
if(log) log=(log.and.BENDER_GO(sol3,neu1,neu))
# call WrtNeu(NEU)
# pause
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.DETECT_GO(det,neu,neuf1))
MONIT_GO=log
return
100 neuf1=neu
MONIT_GO=log
return
101 neuf1=neu1
MONIT_GO=log
return
999 MONIT_GO=.false.
return
end
#---------------------------------------------------------------
logical FUNCTION INELAST_GO()
# trace 3-axis setup to get resolution function R(Q,E)
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical SAM_GO,BENDER_GO,CRYST_GO2,TAS1_GO,DETECT_GO,TAS1_GO2
logical log
real*8 ki
common /neuif/ neui,neuf,neui1,neuf1
if(ftas.eq.0) then
log=TAS1_GO()
else
log=TAS1_GO2()
endif
if(.not.log) goto 10
if(log) log=(log.and.SAM_GO(sam,neui,neuf))
if (normmon.ne.0) then ! weight by monitor efficiency ~ 1/ki
ki=sqrt(neui.k(1)**2+neui.k(2)**2+neui.k(3)**2)
neuf.p=neuf.p*ki
endif
neuf.p=neuf.p/neui.p
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.CRYST_GO2(ana,neu,neu1))
if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
neuf.p=neuf1.p
10 INELAST_GO=log
end
#-----------------------------------------------------------------------------
logical FUNCTION DCRYST_GO()
# trace 3-axis setup without sample (incl. just nominal scatterinc angle)
# for Q=0, equivalent to the double-crystal setting
#-----------------------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BRAGG_GO,BENDER_GO,CRYST_GO2,TAS1_GO,DETECT_GO,TAS1_GO2
logical log
common /neuif/ neui,neuf,neui1,neuf1
if(ftas.eq.0) then
log=TAS1_GO()
else
log=TAS1_GO2()
endif
if(.not.log) goto 10
if(log) log=(log.and.BRAGG_GO(sam,neui,neuf))
# NEUF.P=1
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.CRYST_GO2(ana,neu,neu1))
if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
# NEUF.P=NEUF1.P
10 DCRYST_GO=log
end
#---------------------------------------------------------------
logical FUNCTION TAS2_GO()
# trace 3-axis setup, secondary part only
# as INELAST_GO, but without primary spectrometer
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical SAM_GO,BENDER_GO,CRYST_GO2,DETECT_GO
logical log
real*8 ki
common /neuif/ neui,neuf,neui1,neuf1
# real*8 s(10)
# integer*4 i
# save s
#1 format('TRACE PROBABILITIES: ',a,I,6(2x,G10.4))
# if(sam.count.eq.0) s(1)=0.
# if(ana.frame.count.eq.0) s(3)=0.
log=(neui.p.gt.0)
if(.not.log) goto 10
if(log) log=(log.and.SAM_GO(sam,neui,neuf))
if (normmon.ne.0) then ! weight by monitor efficiency ~ 1/ki
ki=sqrt(neui.k(1)**2+neui.k(2)**2+neui.k(3)**2)
neuf.p=neuf.p*ki
endif
neuf.p=neuf.p/neui.p
# if(log) s(1)=s(1)+NEUF.P
# if (sam.count.gt.0) then
# if (s(1).gt.sam.count*sam.size(3)*1.57*1.2) then
# write(*,1) 'WARNING!!! : ',sam.count,NEUI.R(1),NEUF.P
# write(*,1) 'sample: ',det.count,s(1)/sam.count
# pause
# endif
# endif
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.CRYST_GO2(ana,neu,neu1))
# if(log) s(3)=s(3)+NEU1.P/NEU.P
if(log) log=(log.and.BENDER_GO(sol4,neu1,neu))
if(log) log=(log.and.DETECT_GO(det,neu,neuf1))
# if (sam.count.gt.1000) then
# write(*,1) 'sample: ',sam.count,s(1)/sam.count
# write(*,1) 'sample x,P: ',10000,NEUI.R(1),NEUF.P
# endif
# if (ana.frame.count.gt.1000) then
# write(*,1) 'analyzer: ',ana.frame.count,s(3)/ana.frame.count
# endif
neuf.p=neuf1.p
10 TAS2_GO=log
end
#---------------------------------------------------------------
SUBROUTINE TestQE(ki,kf)
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'rescal.inc'
real*8 vq(3),wq(3),kf0,ki0,vki(3),vkf(3),ki(3),kf(3)
integer*4 i,j
do i=1,3
vki(i)=ki(i)
vkf(i)=kf(i)
enddo
kf0=vkf(1)**2+vkf(2)**2+vkf(3)**2
ki0=vki(1)**2+vki(2)**2+vki(3)**2
vkf(1)=vkf(1)-stp.kf*somega
vkf(3)=vkf(3)-stp.kf*comega
vki(3)=vki(3)-stp.ki
do i=1,3
vq(i)=vkf(i)-vki(i)
enddo
#* transform to C&N coord.
do i=1,3
wq(i)=0
do j=1,3
wq(i)=wq(i)+mlc(j,i)*vq(j)
enddo
enddo
if(wq(1).gt.0.06) then
80 format(a10,4(1x,g12.6))
write (*,80) 'VKI: ',(vki(i),i=1,3)
write (*,80) 'VKF: ',(vkf(i),i=1,3)
write (*,80) 'VQ: ',(vq(i),i=1,3)
write (*,80) 'WQ: ',(wq(i),i=1,3),hsqov2m*(ki0-kf0)-stp.e
vkf(1)=kf(1)*comega-kf(3)*somega
vkf(3)=kf(1)*somega+kf(3)*comega
write (*,80) 'KF: ',(vkf(i),i=1,3)
write (*,80) 'ang: ',ki(1)/ki(3),vkf(1)/vkf(3)
pause
endif
end
#---------------------------------------------------------------
logical FUNCTION DIFF2_GO()
# trace from a sample (diffuse elastic) to the detector
# without primary spectrometer
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,ESAM_GO,DETECT_GO
logical*4 log
common /neuif/ neui,neuf,neui1,neuf1
log=(neui.p.gt.0)
if(.not.log) goto 10
if(log) log=(log.and.ESAM_GO(sam,neui,neuf))
neuf.p=neuf.p/neui.p
neu=neuf
if(flipa.eq.1) neu.s=-neu.s
if(log) log=(log.and.BENDER_GO(sol3,neu,neu1))
if(log) log=(log.and.DETECT_GO(det,neu1,neuf1))
neuf.p=neuf1.p
10 DIFF2_GO=log
return
end
#---------------------------------------------------------------
logical FUNCTION DIFF3_GO()
# trace from a powder sample to the detector
# as DIFF_GO, but without primary spectrometer
#---------------------------------------------------------------
implicit none
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neui,neuf,neui1,neuf1,neu,neu1
logical BENDER_GO,PWD_GO,DETECT_GO
logical*4 log
common /neuif/ neui,neuf,neui1,neuf1
log=(neui.p.gt.0)
if(.not.log) goto 10
if(log) log=(log.and.PWD_GO(sam,neui,neuf,stp.q*stp.ss))
# NEUF.P=NEUF.P/NEUI.P
neu=neuf
if(flipa.eq.1) neu.s=-neu.s
if(log) log=(log.and.BENDER_GO(sol3,neu,neu1))
if(log) log=(log.and.DETECT_GO(det,neu1,neuf1))
10 DIFF3_GO=log
# E(1)=NEU.R(1)
# E(2)=NEU.R(2)
# E(3)=HSQOV2M*(KKI-STP.KI**2)
# E(4)=NEU.T/1000 ! in [ms]
# DEI=DEI+NEU.P*E(3)**2
# DEI0=DEI0+E(3)*NEU.P
# CALL EVARRAY(1,1,NCNT,E,NEU.P)
# DO I=1,3
# E(I)=NEU.K(I)
# ENDDO
# E(3)=E(3)-STP.KI
# E(4)=NEU.S
# CALL EVARRAY(1,0,NCNT,E,NEU.P)
return
end
#---------------------------------------------------------------
logical*4 FUNCTION BENCH_CR(icom,neu)
# traces neutron trajectories from the sample to the source
# (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neu,neu1
logical BENDER_GO,SLIT_GO,CRYST_GO2,log
integer*4 icom
101 format(1x,7(g13.6,2x),a1)
log=.true.
log=(neu.p.gt.0)
# IF(LOG) write(*,101) (NEU.R(i),i=1,3),(NEU.K(i),i=1,3),NEU.p
if(log) log=(log.and.SLIT_GO(sam,neu,neu1))
# IF(LOG) write(*,101) (NEU1.R(i),i=1,3),(NEU1.K(i),i=1,3),NEU1.p
if(flipm.eq.1) neu1.s=-neu1.s
if(log) log=(log.and.BENDER_GO(sol2,neu1,neu))
# IF(LOG) write(*,101) (NEU.R(i),i=1,3),(NEU.K(i),i=1,3),NEU.p
if(log) log=(log.and.BENDER_GO(sol2a,neu,neu1))
# IF(LOG) write(*,101) (NEU1.R(i),i=1,3),(NEU1.K(i),i=1,3),NEU1.p
BENCH_CR=log
if(log.and.(icom.eq.1)) log=(log.and.CRYST_GO2(mon,neu1,neu))
return
end
#---------------------------------------------------------------
logical*4 FUNCTION BENCH_SOL2(icom,neu)
# traces neutron trajectories from the sample to the source
# (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neu,neu1
logical BENDER_GO,SLIT_GO,log
integer*4 icom
log=.true.
log=(neu.p.gt.0)
if(log) log=(log.and.SLIT_GO(sam,neu,neu1))
if(flipm.eq.1) neu1.s=-neu1.s
BENCH_SOL2=log
if(log.and.(icom.eq.1)) log=(log.and.BENDER_GO(sol2,neu1,neu))
return
end
#---------------------------------------------------------------
logical*4 FUNCTION BENCH_PWD(icom,neu)
# traces neutron trajectories from the sample to the source
# (ICOM=1) or from the sample to the detector (ICOM=2)
#---------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
record /NEUTRON/ neu,neu1,neui
logical BENDER_GO,SLIT_GO,CRYST_GO2,log,SOURCE_GO,PWD_GO
integer*4 icom
log=.true.
log=(neu.p.gt.0)
neui=neu
if(log) log=(log.and.SLIT_GO(sam,neu,neu1))
if(flipm.eq.1) neu1.s=-neu1.s
if(log) log=(log.and.BENDER_GO(sol2,neu1,neu))
if(log) log=(log.and.BENDER_GO(sol2a,neu,neu1))
if(log) log=(log.and.CRYST_GO2(mon,neu1,neu))
if(log) log=(log.and.BENDER_GO(sol1,neu,neu1))
if(log) log=(log.and.BENDER_GO(guide,neu1,neu))
if(log) log=(log.and.BENDER_GO(gdea,neu,neu1))
if(log) then
log=(log.and.SOURCE_GO(sou,neu1,neu))
neu1=neui
neu1.p=neu.p
neu1.r(1)=-neu1.r(1)
neu1.k(2)=-neu1.k(2)
endif
BENCH_PWD=log
if(log.and.(icom.eq.1))
* log=(log.and.PWD_GO(sam,neu1,neu,stp.q*stp.ss))
return
end
#---------------------------------------------------
SUBROUTINE NESS_CONV(READCFG)
# Conversion of parameters from TRAX & RESCAL to NESS
#---------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
INCLUDE 'collimators.inc'
INCLUDE 'rescal.inc'
INCLUDE 'trax.inc'
integer*4 READCFG
integer*4 ierr
common /errors/ ierr
integer*4 i
if (READCFG.gt.0) call SETCFG(cfgname)
# write(*,*) 'Convert input data to NESS structures'
sol1.dlh=dlamh(3)
sol1.dlv=dlamv(3)
sol1.nlh=nlam(3)
sol1.nlv=vlam(3)
sol2.dlh=dlamh(5)
sol2.dlv=dlamv(5)
sol2.nlh=nlam(5)
sol2.nlv=vlam(5)
sol3.dlh=dlamh(6)
sol3.dlv=dlamv(6)
sol3.nlh=nlam(6)
sol3.nlv=vlam(6)
sol4.dlh=dlamh(7)
sol4.dlv=dlamv(7)
sol4.nlh=nlam(7)
sol4.nlv=vlam(7)
sol2a.dlh=dlamh(4)
sol2a.dlv=dlamv(4)
sol2a.nlh=nlam(4)
sol2a.nlv=vlam(4)
guide.dlh=dlamh(2)
guide.dlv=dlamv(2)
guide.nlh=nlam(2)
guide.nlv=vlam(2)
gdea.dlh=dlamh(1)
gdea.dlv=dlamv(1)
gdea.nlh=nlam(1)
gdea.nlv=vlam(1)
#/// sample:
smos=res_dat(i_etas)*minute/r8ln2
sam.name= 'sample'
sam.shape=1
sam.dist=0.
sam.axi=0.
do 10 i=1,3
sou.sta(i)=0.
sou.gon(i)=0.
10 continue
sam.size(1)=res_dat(i_sdi)*10.
sam.size(3)=res_dat(i_sdi)*10.
sam.size(2)=res_dat(i_shi)*10.
#/// Soller collimators
sol1.frame.name= 'col1'
sol2.frame.name= 'col2'
sol2a.frame.name= 'col2a'
guide.frame.name= 'guide'
gdea.frame.name= 'guide_a'
#xxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcxxxxxxxxxcx
call CREATE_COL(sol1,nfm,alpha(1),beta(1),vlsm,vl0-vlcanm-vlsm,
1 hdm1,hdm2,vdm1,vdm2,3,-1)
if (nfg.gt.0) then
call CREATE_COL(guide,nfg,0.d0,0.d0,lguide,
1 vl0-sol1.frame.dist/10., hg1,hg2,vg1,vg2,2,-1)
call CREATE_COL(gdea,nfg,0.d0,0.d0,lga,
1 dga+guide.frame.size(3)/10,hga1,hga2,vga1,vga2,1,-1)
else
call CREATE_COL(guide,nfg,0.d0,0.d0,0.d0,
1 vl0-sol1.frame.dist/10., hg1, hg2,vg1,vg2,2,-1)
dguide=0. ! important to set correctly source distance
call CREATE_COL(gdea,nfg,0.d0,0.d0,0.d0,
1 0.d0,hga2,hga1,vga2,vga1,1,-1)
dga=0. ! important to set correctly source distance
endif
call CREATE_COL(sol2,nfs,alpha(2),beta(2),vlms,vl1-vlcans-vlms,
1 hds1,hds2,vds1,vds2,5,-1)
if(alpha(2).gt.0) then
call CREATE_COL(sol2a,nfs,500.d0,500.d0,len2a,vlms+dist2a,
1 h2a1,h2a2,v2a1,v2a2,4,-1)
else
call CREATE_COL(sol2a,nfs,0.d0,0.d0,len2a,vlms+dist2a,
1 h2a1,h2a2,v2a1,v2a2,4,-1)
endif
#/// monochromator:
mon.frame.shape=3
mon.frame.size(1)=wmon*10.
mon.frame.size(2)=hmon*10.
mon.frame.size(3)=thmon*10.
mon.frame.dist=vl1*10.-sol2a.frame.dist-sol2.frame.dist
mon.frame.axi=0.
mon.chi=himon*deg
mon.dhkl=res_dat(i_dm)
mon.thb=asin(pi/mon.dhkl/stp.ki)
mon.rh=res_dat(i_romh)/1000.
mon.rv=res_dat(i_romv)/1000.
mon.hmos=res_dat(i_etam)*minute/r8ln2
mon.vmos=mon.hmos*anrm
if (stp.sm.lt.0) then
mon.frame.gon(1)=mon.thb-mon.chi+pi/2.+
& (dthax(1)-dthax(2))*pi/180/60
sol1.frame.axi=mon.thb*2.-dthax(2)*pi/180/60
else if (stp.sm.gt.0) then
mon.frame.gon(1)=-mon.thb-mon.chi-pi/2.-
& (dthax(1)-dthax(2))*pi/180/60
sol1.frame.axi=-mon.thb*2.+dthax(2)*pi/180/60
else
mon.frame.gon(1)=0. ! if SM=0, then a filter is considered instead of the analyzer
mon.thb=0. ! CRYST_GO recognizes this case if THB=0
sol1.frame.axi=0. ! dhkl determines the edge position, kc=pi/dhkl
mon.chi=pi/2.
mon.rh=0.
mon.rv=0.
mon.hmos=0.
mon.vmos=0.
stp.ki=2*pi/mon.dhkl
endif
mon.poi=poissm
mon.nh=nhm
mon.nv=nvm
mon.nb=nbm
mon.dh=0.1d0
mon.dv=0.1d0
mon.db=0.1d0
mon.frame.axv=0
#/// source:
sou.name= 'source'
sou.size(1)=wsou*10.
sou.size(2)=hsou*10.
sou.size(3)=0.1
if(nsou.eq.0) then
sou.shape=2
sou.size(1)=diasou*10.
sou.size(2)=diasou*10.
else if (nsou.eq.2) then
sou.shape=2
else if (nsou.eq.3) then
sou.shape=1
else
sou.shape=3
endif
sou.axi=0.
sou.dist=dguide*10.-dga*10.
do 20 i=1,3
sou.sta(i)=0.
sou.gon(i)=0.
20 continue
#/// Soller collimators:
sol3.frame.name= 'col3'
sol4.frame.name= 'col4'
call CREATE_COL(sol3,nfa,alpha(3),beta(3),vlsa,vlcana,
1 hda1,hda2,vda1,vda2,6,1)
sol3.frame.axi=omega+sign(1,stp.ss)*dthax(4)*minute
sol3.frame.gon(1)=sign(1,stp.ss)*dthax(3)*minute
call CREATE_COL(sol4,nfd,alpha(4),beta(4),vlad,vlcand,
1 hdd1,hdd2,vdd1,vdd2,7,1)
#/// analyzer:
# ANA.FRAME.NAME='analyzer'
ana.frame.shape=3
ana.frame.size(1)=wana*10.
ana.frame.size(2)=hana*10.
ana.frame.size(3)=thana*10.
ana.frame.dist=vl2*10.-sol3.frame.dist
ana.frame.axi=0.
ana.chi=-hiana*deg
ana.dhkl=res_dat(i_da)
ana.thb=asin(pi/ana.dhkl/stp.kf)
ana.rh=res_dat(i_roah)/1000.
ana.rv=res_dat(i_roav)/1000.
ana.hmos=res_dat(i_etaa)*minute/r8ln2
ana.vmos=ana.hmos*anra
if(stp.sa.eq.0) then
ana.frame.gon(1)=0. ! if SA=0, then a filter is considered instead of the analyzer
ana.thb=0. ! CRYST_GO recognizes this case if THB=0
sol4.frame.axi=0. ! dhkl determines the edge position, kc=2*pi/dhkl
ana.chi=pi/2.
ana.rh=0.
ana.rv=0.
ana.hmos=0
ana.vmos=0
if (stp.sm.eq.0) stp.kf=2*pi/mon.dhkl
else if(cfgmode.eq.1) then ! Option with scondary spectrometer turned up
if (stp.sa.gt.0) then
ana.frame.gon(1)=pi/2
ana.frame.gon(2)=-pi/2
ana.frame.gon(3)=ana.thb-ana.chi+pi/2.+dthax(5)*pi/180/60
sol4.frame.axi=0
sol4.frame.axv=-ana.thb*2.-dthax(6)*pi/180/60
else if (stp.sa.lt.0) then
ana.frame.gon(1)=-pi/2
ana.frame.gon(2)=+pi/2
ana.frame.gon(3)=-ana.thb+ana.chi+pi/2.-dthax(5)*pi/180/60
sol4.frame.axi=0
sol4.frame.axv=ana.thb*2.+dthax(6)*pi/180/60
endif
else
ana.frame.gon(2)=0
ana.frame.gon(3)=0
if (stp.sa.gt.0) then
ana.frame.gon(1)=ana.thb-ana.chi+pi/2.+dthax(5)*pi/180/60
sol4.frame.axi=ana.thb*2.+dthax(6)*pi/180/60
sol4.frame.axv=0
else if (stp.sa.lt.0) then
ana.frame.gon(1)=-ana.thb-ana.chi-pi/2.-dthax(5)*pi/180/60
sol4.frame.axi=-ana.thb*2.-dthax(6)*pi/180/60
sol4.frame.axv=0
endif
endif
ana.poi=poissa
ana.nh=nha
ana.nv=nva
ana.nb=nba
ana.dh=0.1d0
ana.dv=0.1d0
ana.db=0.1d0
#/// dector:
det.frame.name= 'detector'
if(ndet.eq.0) then
det.frame.shape=2
det.frame.size(1)=diadet*10.
det.frame.size(2)=diadet*10.
det.frame.size(3)=hdet*10.
else
det.frame.shape=3
det.frame.size(1)=wdet*10.
det.frame.size(2)=hdet*10.
det.frame.size(3)=wdet*10.
endif
det.frame.axi=0.
det.frame.axv=0.
det.frame.dist=vl3*10.-sol4.frame.dist
do i=1,3
det.frame.sta(i)=0.
det.frame.gon(i)=0.
enddo
if(adet.gt.0.) then
det.alpha=adet/10.d0
det.nd=nsegdet
det.space=spacedet
det.frame.gon(2)=phidet*pi/180.
if(det.frame.shape.eq.2) then
det.frame.size(1)=diadet*10.
det.frame.size(3)=diadet*10.
det.frame.size(2)=hdet*10.
else
det.frame.size(1)=wdet*10.
det.frame.size(2)=hdet*10.
det.frame.size(3)=diadet*10.
endif
endif
if((stp.sm.eq.0).and.(stp.sa.eq.0)) then
stp.e=hsqov2m*(stp.ki**2-stp.kf**2)
endif
# write(*,*) 'GUIDE.NLH, NLAM2: ',GUIDE.NLH, NLAM2
# call WRITE_SETUP(20)
# write(*,*) 'Conversion done.'
# pause
return
999 ierr=2
return
end
#--------------------------------------------------------------
SUBROUTINE CREATE_COL(obj,nfm,alpha,beta,lcol,dcol,
& hw1,hw2,vw1,vw2,ic,idir)
# Fill OBJ structure with parameters of a collimator segment
# NFM .. indicates presence
# ALPHA .. Soller divergence, horizontal
# BETA .. Soller divergence, vertical
# LENG .. collimator length
# DIST .. distance of entry from the preceding component
# H1,H2 .. entry and exit widths
# V1,V2 .. entry and exit heights
# IC .. index to other parameters in the common "collimators"
# IDIR .. direction downstream (1) or upstream (-1)
# if IDIR=-1, exchanges entry and exit and sets oposite sign of
# horiz. curvature for curved guides)
# Converts input sizes from [cm] to [mm]
#--------------------------------------------------------------
implicit none
include 'const.inc'
include 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'collimators.inc'
record /BENDER/ obj
integer*4 nfm,ic,idir,i
real*8 alpha,beta,lcol,dcol,hw1,hw2,vw1,vw2
integer*4 READ_MIRROR,is
real*8 h1,h2,v1,v2,leng,dist
1 format(a,3(2x,g12.6))
# write(*,1) 'Create collimator '//OBJ.FRAME.NAME(1:10),NFM,
# & ALPHA,LCOL
obj.typ=ctyp(ic)
is=sign(1,idir)
# unit conversion [cm]-> [mm]
# if IDIR<0, exchange entry and exit
if (is.gt.0) then
h1=hw1*10.
h2=hw2*10.
v1=vw1*10.
v2=vw2*10.
else
h2=hw1*10.
h1=hw2*10.
v2=vw1*10.
v1=vw2*10.
endif
leng=lcol*10.
dist=dcol*10.
obj.ch=roh(ic)*is
obj.cv=rov(ic)
obj.ghlu=gamh(ic)
obj.ghru=gamh(ic)
if (polar(ic).eq.0) then
obj.ghld=gamh(ic)
obj.ghrd=gamh(ic)
else
obj.ghld=0
obj.ghrd=0
endif
obj.oscilate=osc(ic)
obj.gvt=gamv(ic)
obj.gvb=gamv(ic)
obj.rhlu=refh(ic)
obj.rhld=refh(ic)
obj.rhru=refh(ic)
obj.rhrd=refh(ic)
obj.rvt=refv(ic)
obj.rvb=refv(ic)
obj.nhlu=READ_MIRROR(obj.ghlu)
obj.nhld=READ_MIRROR(obj.ghld)
obj.nhru=READ_MIRROR(obj.ghru)
obj.nhrd=READ_MIRROR(obj.ghrd)
obj.nvt=READ_MIRROR(obj.gvt)
obj.nvb=READ_MIRROR(obj.gvb)
obj.frame.axi=0.
do 10 i=1,3
obj.frame.sta(i)=0.
obj.frame.gon(i)=0.
10 continue
obj.frame.shape=3
obj.frame.dist=dist
obj.frame.size(1)=h1
obj.frame.size(2)=v1
obj.frame.size(3)=leng
obj.w2=h2
obj.h2=v2
if (obj.dlh.eq.0) obj.dlh=0.08
if (obj.dlv.eq.0) obj.dlv=0.08
if((alpha.gt.0).or.(nfm.ge.0)) then
if(alpha.gt.0.and.alpha.lt.500.and.obj.typ.lt.2) then ! set NLH automatically
if (obj.nlh.le.0) obj.nlh=
* nint((h1+h2)/(2*leng*(alpha*minute+obj.dlh/leng/10.)))
else
if (obj.nlh.le.0) obj.nlh=1
endif
if (beta.gt.0.and.beta.lt.500.and.obj.typ.lt.2) then ! set NLV automatically
if (obj.nlv.le.0) obj.nlv=
* nint((v1+v2)/(2*leng*(beta*minute+obj.dlv/leng/10.)))
else
if (obj.nlv.le.0) obj.nlv=1
endif
else
obj.frame.size(1)=1000.
obj.frame.size(2)=1000.
obj.frame.size(3)=0.
obj.w2=obj.frame.size(1)
obj.h2=obj.frame.size(2)
obj.nlh=1
obj.nlv=1
obj.typ=-1
endif
if(obj.nlh.le.1) obj.oscilate=0
100 format( 'WARNING! oscilating colimator ',a, ' has only ',
& i2, ' slits')
if (obj.oscilate.gt.0.and.obj.nlh.le.6) then
write(sout,100) obj.frame.name,obj.nlh
endif
end
#---------------------------------------------------------------
integer*4 FUNCTION READ_MIRROR(qc)
# read reflectivity data for supemirror (used in BENDER by NESS)
# 1 line header + 3 columns: m, r(up), r(down)
# returns:
# if found ... the index to lookup table
# if QC=-1 ... 0, clears tables
# if QC not in (0.1,10) ... 0, no reflections
# if error ... 0, show adequate message
#---------------------------------------------------------------
implicit none
include 'const.inc'
include 'inout.inc'
integer*4 iu
parameter(iu=22)
integer*4 m_n(5),ires,indx,i,j
real*8 mni,z,qc
character*3 suffix,m_name(5)
character*9 fname
real*8 m_alpha(128,5), m_ref1(128,5), m_ref2(128,5)
common /mirror/ m_alpha,m_ref1,m_ref2,m_n,m_name
logical*4 verbose
integer*4 nev
common /mcsetting/ verbose,nev
1 format(f3.1)
3 format( 'reflectivity (',i1, ') ',a9, ' , read ',i5, ' lines.')
4 format( 'Error ',i5, ' while reading mirror table, line ',i5, ' .')
5 format( 'found mirror table (',i1, ') m=',a3, ', ',i5, ' lines.')
6 format( 'no more space in mirror tables - clearing records')
mni=qc/gammani
READ_MIRROR=0
if(mni.lt.0) goto 200 ! clear all
if(mni.eq.0) goto 100
z=log10(mni)
if (z.lt.-1.or.z.ge.1) goto 100 ! must be 0.1 <= mNi < 10
# get filename suffix
suffix= '1.0'
write(suffix,1,err=10) mni
10 fname= 'mirror'//suffix
# search for an existing table
i=1
do while(i.le.5.and.m_name(i).ne.suffix.and.m_n(i).gt.0)
i=i+1
enddo
# no table found, no more free space
if (i.gt.5) then
if (verbose) write(sout,6)
do j=1,5
m_n(j)=0
m_name(j)= ' '
enddo
i=1
endif
# there is already corresponding table
if (m_name(i).eq.suffix) then
if (dbgref) write(sout,5) i,m_name(i),m_n(i)
READ_MIRROR=i
return
endif
# load the lookup table to the first free position
indx=i
call OPENRESFILE(fname,iu,ires,1)
if(ires.le.0) goto 100 ! error while opening
ires=0
i=0
read(iu,*,iostat=ires,end=40,err=100) ! assume 1-line header
do while(ires.eq.0.and.(i.lt.128))
read(iu,*,iostat=ires,end=30,err=40)
* m_alpha(i+1,indx), m_ref1(i+1,indx),m_ref2(i+1,indx)
i=i+1
enddo
# read OK
30 close(iu)
m_n(indx)=i
m_name(indx)=suffix
if (verbose) write(sout,3) indx,fname,i
READ_MIRROR=indx
return
# error while reading
40 close(iu)
write(sout,4) ires,i
READ_MIRROR=0
return
# no reflections
100 READ_MIRROR=0
return
# clear tables:
200 do j=1,5
do i=1,128
m_alpha(i,j)=i
m_ref1(i,j)=0
m_ref2(i,j)=0
enddo
m_n(j)=0
m_name(j)= ' '
enddo
READ_MIRROR=0
return
end
#---------------------------------------------------------------
SUBROUTINE READ_FLUX(fname)
# read flux distribution
# 1 line header + 2 columns: Lambda, dPhi/dLambda
# units are [Ang], [1e12/s/cm^2/Ang]
#---------------------------------------------------------------
implicit none
include 'const.inc'
include 'inout.inc'
INCLUDE 'source.inc'
integer*4 iu
parameter(iu=22)
integer*4 ires,ilin,i,j,ic,TRUELEN
character*30 fname,s
character*1024 line
1 format(a)
2 format(4(2x,g10.4))
ires=0
ilin=0
flxn=0
flxhnx=0
flxvnx=0
flxhna=0
flxvna=0
# empty string => clear table and exit
if (fname(1:1).eq. ' '.or.fname(1:1).eq.char(0)) return
s=fname
j=TRUELEN(s)
call OPENRESFILE(s(1:j),iu,ires,1)
if(ires.le.0) goto 100
read(iu,1,iostat=ires,end=30,err=40) line ! assume 1-line header
j=TRUELEN(line)
flxlog=index(line(1:j), 'LOGSCALE')
# if (FLXLOG.GT.0) write(*,*) 'LOGSCALE'
ilin=ilin+1
do while(ires.eq.0.and.(flxn.lt.256))
read(iu,1,iostat=ires,end=30,err=40) line
ilin=ilin+1
j=TRUELEN(line)
read(line(1:j),*,iostat=ires,err=20)
& flxlam(flxn+1), flxdist(flxn+1)
# write(*,2) flxn+1,flxlam(flxn+1), flxdist(flxn+1)
flxn=flxn+1
enddo
read(iu,1,iostat=ires,end=30,err=40) line
j=TRUELEN(line)
ilin=ilin+1
# write(*,*) '>'//LINE(1:10)//'<'
20 if (line(1:10).eq. 'HORIZONTAL') then
# write(*,*) ' read HORIZONTAL'
ic=0
read(line(11:j),*,iostat=ires,err=40) flxhnx,flxhna,flxhx,flxha
flxhx=flxhx*10.d0
if (flxhnx.gt.64.or.flxhna.gt.64) goto 40
do i=1,flxhnx
read(iu,1,iostat=ires,end=30,err=40) line
ilin=ilin+1
j=TRUELEN(line)
read(line(1:j),*,iostat=ires,err=25) (flxhp(i,j),j=1,flxhna)
ic=ic+1
enddo
else
goto 30
endif
read(iu,1,iostat=ires,end=30,err=40) line
j=TRUELEN(line)
ilin=ilin+1
# write(*,*) '>'//LINE(1:80)
25 if (ic.ne.flxhnx) goto 40
if (line(1:8).eq. 'VERTICAL') then
# write(*,*) ' read VERTICAL'
ic=0
read(line(9:j),*,iostat=ires,err=40) flxvnx,flxvna,flxvx,flxva
flxvx=flxvx*10.d0
if (flxvnx.gt.64.or.flxvna.gt.64) goto 40
do i=1,flxvnx
read(iu,1,iostat=ires,end=30,err=40) line
ilin=ilin+1
j=TRUELEN(line)
read(line(1:j),*,iostat=ires,err=30) (flxvp(i,j),j=1,flxvna)
ic=ic+1
enddo
endif
if (ic.ne.flxvnx) goto 40
30 close(iu)
3 format( 'Flux table: ',i3, ' lines.')
31 format( 'Flux table with 2D distributions: ',i3, ' lines, dim=',
& 4(1x,i3))
if (flxhnx.gt.0) then
write(sout,31) flxn,flxhnx,flxhna,flxvnx,flxvna
else
write(sout,3) flxn
endif
if (flxlog.gt.0) then
flxdlam=log(flxlam(flxn)/flxlam(1))/(flxn-1)
else
flxdlam=(flxlam(flxn)-flxlam(1))/(flxn-1)
endif
return
40 close(iu)
flxn=0
flxhnx=0
flxvnx=0
flxhna=0
flxvna=0
4 format( 'Error ',i5, ' while reading flux table, line ',i5, ' .')
write(sout,4) ires,ilin
return
100 flxn=0
write (sout,*) 'Cannot open flux table: <'//s(1:j)// '>'
return
end
#----------------------------------------
SUBROUTINE GETSTATE(itask,nevent)
#----------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 itask,nevent
5 format(1x,a8,$)
6 format(1x,i8,$)
7 format(1x,f8.6,$)
#// Write header
if (itask.le.2.or.itask.eq.4.or.itask.eq.6.or.itask.eq.11) then
write(*,5) sol2.frame.name
write(*,5) sol2a.frame.name
write(*,5) mon.frame.name
write(*,5) sol1.frame.name
write(*,5) guide.frame.name
write(*,5) gdea.frame.name
write(*,5) sou.name
write(*,5) sam.name
else if (itask.eq.3.or.itask.eq.5.or.itask.eq.7) then
write(*,5) sou.name
write(*,5) gdea.frame.name
write(*,5) guide.frame.name
write(*,5) sol1.frame.name
write(*,5) mon.frame.name
write(*,5) sol2a.frame.name
write(*,5) sol2.frame.name
write(*,5) sam.name
endif
if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) then
write(*,5) sol3.frame.name
write(*,5) det.frame.name
else if (itask.eq.1.or.itask.eq.6.or.itask.eq.7.or.
& itask.eq.11) then
write(*,5) sol3.frame.name
write(*,5) ana.frame.name
write(*,5) sol4.frame.name
write(*,5) det.frame.name
else if (itask.eq.8) then
write(*,5) sam.name
write(*,5) sol3.frame.name
write(*,5) ana.frame.name
write(*,5) sol4.frame.name
write(*,5) det.frame.name
endif
write(*,*)
#// Write counts
if (itask.le.2.or.itask.eq.4.or.itask.eq.6.or.itask.eq.11) then
write(*,6) sol2.frame.count
write(*,6) sol2a.frame.count
write(*,6) mon.frame.count
write(*,6) sol1.frame.count
write(*,6) guide.frame.count
write(*,6) gdea.frame.count
write(*,6) sou.count
write(*,6) sam.count
else if (itask.eq.3.or.itask.eq.5.or.itask.eq.7) then
write(*,6) sou.count
write(*,6) gdea.frame.count
write(*,6) guide.frame.count
write(*,6) sol1.frame.count
write(*,6) mon.frame.count
write(*,6) sol2a.frame.count
write(*,6) sol2.frame.count
write(*,6) sam.count
endif
if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) then
write(*,6) sol3.frame.count
write(*,6) det.frame.count
else if (itask.eq.1.or.itask.eq.6.or.itask.eq.7.or.
& itask.eq.11) then
write(*,6) sol3.frame.count
write(*,6) ana.frame.count
write(*,6) sol4.frame.count
write(*,6) det.frame.count
else if (itask.eq.8) then
write(*,6) sam.count
write(*,6) sol3.frame.count
write(*,6) ana.frame.count
write(*,6) sol4.frame.count
write(*,6) det.frame.count
endif
write(*,*)
#// Write transmissions
if (itask.le.2.or.itask.eq.4.or.itask.eq.6.or.itask.eq.11) then
if (nevent.gt.0) write(*,7) 1.*sol2.frame.count/nevent
if (sol2.frame.count.gt.0)
* write(*,7) 1.*sol2a.frame.count/sol2.frame.count
if (sol2a.frame.count.gt.0)
* write(*,7) 1.*mon.frame.count/sol2a.frame.count
if (mon.frame.count.gt.0)
* write(*,7) 1.*sol1.frame.count/mon.frame.count
if (sol1.frame.count.gt.0)
* write(*,7) 1.*guide.frame.count/sol1.frame.count
if (guide.frame.count.gt.0)
* write(*,7) 1.*gdea.frame.count/guide.frame.count
if (gdea.frame.count.gt.0)
* write(*,7) 1.*sou.count/gdea.frame.count
if (sou.count.gt.0) write(*,7) 1.*sam.count/sou.count
else if (itask.eq.3.or.itask.eq.5.or.itask.eq.7) then
if (nevent.gt.0) write(*,7) 1.*sou.count/nevent
if (sou.count.gt.0) write(*,7) 1.*gdea.frame.count/sou.count
if (gdea.frame.count.gt.0)
* write(*,7) 1.*guide.frame.count/gdea.frame.count
if (guide.frame.count.gt.0)
* write(*,7) 1.*sol1.frame.count/guide.frame.count
if (sol1.frame.count.gt.0)
* write(*,7) 1.*mon.frame.count/sol1.frame.count
if (mon.frame.count.gt.0)
* write(*,7) 1.*sol2a.frame.count/mon.frame.count
if (sol2a.frame.count.gt.0)
* write(*,7) sol2.frame.count/sol2a.frame.count
if (sol2.frame.count.gt.0)
* write(*,7) 1.*sam.count/sol2.frame.count
endif
if (itask.eq.4.or.itask.eq.5) then
if (sam.count.gt.0)
* write(*,7) 1.*sol3.frame.count/sam.count
if (sol3.frame.count.gt.0)
* write(*,7) 1.*det.frame.count/sol3.frame.count
else if (itask.eq.1.or.itask.eq.6.or.itask.eq.7.or.
& itask.eq.11) then
if (sam.count.gt.0)
* write(*,7) 1.*sol3.frame.count/sam.count
if (sol3.frame.count.gt.0)
* write(*,7) 1.*ana.frame.count/sol3.frame.count
if (ana.frame.count.gt.0)
* write(*,7) 1.*sol4.frame.count/ana.frame.count
if (sol4.frame.count.gt.0)
* write(*,7) 1.*det.frame.count/sol4.frame.count
else if (itask.eq.8) then
if (nevent.gt.0)
* write(*,7) 1.*sam.count/nevent
if (sam.count.gt.0)
* write(*,7) 1.*sol3.frame.count/sam.count
if (sol3.frame.count.gt.0)
* write(*,7) 1.*ana.frame.count/sol3.frame.count
if (ana.frame.count.gt.0)
* write(*,7) 1.*sol4.frame.count/ana.frame.count
if (sol4.frame.count.gt.0)
* write(*,7) 1.*det.frame.count/sol4.frame.count
else if (itask.eq.9) then
if (nevent.gt.0)
* write(*,7) 1.*sol3.frame.count/nevent
if (sol3.frame.count.gt.0)
* write(*,7) 1.*det.frame.count/sol3.frame.count
endif
write(*,*)
end
#---------------------------------------------------
SUBROUTINE SLIT_WRITE(iu,object)
# Writes parameters of OBJECT to unit U
#--------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
integer*4 iu,i
record /SLIT/ object
1 format(a30)
2 format( ' size : ',3(2x,f9.3))
3 format( ' pos : ',3(2x,f9.1))
5 format( ' gon : ',3(2x,f9.1))
4 format( ' distance, omega,phi,shape: ',3(2x,f9.1),5x,i1)
write(iu,*) '************************************'
write(iu,1) object.name
write(iu,*) '************************************'
write(iu,2) (object.size(i),i=1,3)
write(iu,3) (object.pos(i),i=1,3)
write(iu,5) (object.gon(i)*180/pi,i=1,3)
write(iu,4) object.dist,object.axi*180/pi,object.axv*180/pi,
* object.shape
return
end
#---------------------------------------------------
SUBROUTINE CRYST_WRITE(iu,object)
# Writes parameters of OBJECT to unit U
#--------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
integer*4 iu,i
real*8 GETEFFMOS, GETDTH
record /CRYSTAL/ object
1 format( ' nh,nv,nb: ',3(2x,i3))
12 format( ' spaces: ',3(2x,g10.4))
2 format( ' G0 : ',3(2x,f8.3))
3 format( ' dG : ',3(2x,e12.3))
7 format( ' lambda,dhkl,thb,chi: ',4(2x,f8.3))
8 format( ' curvatures (h,v,z): ',3(2x,g10.4))
9 format( ' hmos,vmos,etamax,effmos,dthb: ',5(2x,f7.2))
10 format( ' Qhkl,DW,mi,ref: ',4(2x,g12.4))
11 format( ' dExt,dLam,Ext1: ',3(2x,g12.4))
call SLIT_WRITE(iu,object.frame)
write(iu,*)
write(iu,1) object.nh,object.nv,object.nb
write(iu,12) object.dh,object.dv,object.db
write(iu,7) object.lambda,object.dhkl,object.thb*180/pi,
1 object.chi*180/pi
write(iu,8) object.rh*1000,object.rv*1000,object.rb*1000
write(iu,9) object.hmos*180*60/pi,object.vmos*180*60/pi,
1 object.deta*180*60/pi,GETEFFMOS(object)*180*60/pi,
& GETDTH(object)*180*60/pi
write(iu,10) object.qhkl,object.dw,object.mi,object.ref
write(iu,11) object.dext,object.dlam,object.ext1
write(iu,2) (object.g(i),i=1,3)
write(iu,3) (object.dg_dr(1,i),i=1,3)
write(iu,3) (object.dg_dr(2,i),i=1,3)
write(iu,3) (object.dg_dr(3,i),i=1,3)
return
end
#---------------------------------------------------
SUBROUTINE BENDER_WRITE(iu,object)
# Writes parameters of OBJECT to unit U
#--------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
integer*4 iu
record /BENDER/ object
2 format( ' nlh,nlv : ',2(2x,i4),a11)
3 format( ' w2,h2 : ',2(2x,f8.1))
4 format( ' crit. angles : ',6(2x,e12.3))
5 format( ' 1/RH, 1/RV : ',2(e12.3,2x))
51 format( ' focal distances (H,V) : ',2(g10.4,2x))
6 format( ' dlh,dlv : ',2(2x,f8.3))
7 format( ' reflectivities : ',6(2x,f8.3))
8 format( ' ref. indexes : ',6(2x,i2))
call SLIT_WRITE(iu,object.frame)
if (object.typ.lt.0) then
write(iu,*) 'ignored'
else if (object.typ.eq.0) then
write(iu,*) 'collimator'
else if (object.typ.eq.1) then
write(iu,*) 'guide'
else if (object.typ.eq.2) then
write(iu,*) 'parabolic guide'
else if (object.typ.eq.3) then
write(iu,*) 'parabolic guide with optimized slit lengths'
else if (object.typ.eq.4) then
write(iu,*) 'elliptic guide'
endif
write(iu,*)
write(iu,3) object.w2, object.h2
if (object.oscilate.gt.0) then
write(iu,2) object.nlh,object.nlv, ' oscilating'
else
write(iu,2) object.nlh,object.nlv
endif
write(iu,6) object.dlh,object.dlv
write(iu,4) object.ghlu,object.ghld,object.ghru,object.ghrd,
1 object.gvt,object.gvb
write(iu,7) object.rhlu,object.rhld,object.rhru,object.rhrd,
1 object.rvt,object.rvb
write(iu,8) object.nhlu,object.nhld,object.nhru,object.nhrd,
1 object.nvt,object.nvb
if (object.typ.gt.1) then
write(iu,51) object.ch,object.cv
else
write(iu,5) object.ch,object.cv
endif
end
#---------------------------------------------------
SUBROUTINE DETECT_WRITE(iu,object)
# Writes parameters of OBJECT to unit U
#--------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'structures.inc'
integer*4 iu
record /DETECTOR/ object
2 format( ' alpha [1/A/cm]: ',g12.4)
3 format( ' No. of segments : ',i3)
4 format( ' gap [mm] : ',g12.4)
5 format( ' tilt [deg] : ',g12.4)
call SLIT_WRITE(iu,object.frame)
write(iu,*)
write(iu,2) object.alpha*10.
write(iu,3) object.nd
write(iu,4) object.space
write(iu,5) object.frame.gon(2)*180/pi
return
end
#---------------------------------------------------
SUBROUTINE WRITE_SETUP(ic,itask)
# Writes actual parameters of the setup
#---------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
integer*4 ic,itask
# REAL*8 Z1,Z2,Z3,fwhm1,fwhm2
5 format( ' w2,h2: ',2(2x,f7.1))
6 format( ' nl: ',i4)
10 format( ' a',i1, ': ',f8.3)
11 format( ' KI,KF,Q: ',4(2x,f8.3))
if(ic.ne.6) open(unit=ic,file= 'res_setup.txt',err=999,
1 status= 'Unknown')
write(ic,*) 'Configuration ',cfgname
call SLIT_WRITE(ic,sou)
write(ic,*)
call BENDER_WRITE(ic,gdea)
write(ic,*)
call BENDER_WRITE(ic,guide)
write(ic,*)
call BENDER_WRITE(ic,sol1)
write(ic,*)
call CRYST_WRITE(ic,mon)
write(ic,*)
call BENDER_WRITE(ic,sol2a)
write(ic,*)
call BENDER_WRITE(ic,sol2)
write(ic,*)
call SLIT_WRITE(ic,sam)
write(ic,*)
call BENDER_WRITE(ic,sol3)
write(ic,*)
if (itask.ne.4.and.itask.ne.5.and.itask.ne.9) then
call CRYST_WRITE(ic,ana)
write(ic,*)
call BENDER_WRITE(ic,sol4)
write(ic,*)
endif
call DETECT_WRITE(ic,det)
write(ic,*)
#12 FORMAT(' range etam: +-',E12.4,' r: ',3(2x,E12.3))
#13 FORMAT(' range etaa: +-',E12.4,' r: ',3(2x,E12.3))
# WRITE(IC,13) ABS(X_CR(1,2)),Y_CR(1,2),Y_CR(N_CR/2,2),Y_CR(N_CR,2)
# CALL GETREFPAR(MON,MON.lambda,MON.QHKL,MON.MI,Z1,Z2,Z3,fwhm1)
# CALL GETREFPAR(ANA,ANA.lambda,ANA.QHKL,ANA.MI,Z1,Z2,Z3,fwhm2)
#14 FORMAT(' fwhm [min] mon: = ',G12.5,' anal: ',G12.5)
# WRITE(IC,14) fwhm1*60*180/PI,fwhm2*60*180/PI
write(ic,*)
write(ic,*) 'AXES:'
write(ic,10) 1,mon.frame.gon(1)*180/pi
if (sol1.frame.axi.ne.0) then
write(ic,10) 2,sol1.frame.axi*180/pi
else
write(ic,10) 2,sol2.frame.axi*180/pi
endif
write(ic,10) 4,sol3.frame.axi*180/pi
# WRITE(IC,10) 5,ANA.FRAME.GON(1)*180/PI
# WRITE(IC,10) 6,SOL4.FRAME.AXI*180/PI
write(ic,*)
write(ic,11) stp.ki,stp.kf,stp.q ! ,STP.E
if(ic.ne.6) close(ic)
# WRITE(*,*) 'Setup written'
return
999 write(*,*) 'Cannot open file for output!'
return
end
#------------------------------------------------------------------------
SUBROUTINE APERTURE2(itask,ahmax,avmax)
# Calculate maximum angular deviations transmitted through the instrument
# for the SECONDARY spectrometer (sample-detector)
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
real*8 ahmax,avmax
integer*4 itask,i
real*8 a(20),l1,d1,l2,d2,b1,b2,ksi,stmch,stpch,z
# Horizontal, sample-detector
#--------------------------------
do i=1,20
a(i)=1e30
enddo
# Colim. 3
l1=sol3.frame.dist
d1=sam.size(1)+sol3.frame.size(1)
if (l1.gt.1e-10) a(1)=d1/l1
l1=sol3.frame.dist+sol3.frame.size(3)
d1=sam.size(1)+sol3.w2
if (l1.gt.1e-10) a(2)=d1/l1
if (sol3.frame.size(3).gt.1d-10) then
b1=(sol3.w2+sol3.frame.size(1))/sol3.frame.size(3)/sol3.nlh
else
b1=1.d30
endif
b2=sol3.ghlu*4*pi/stp.kf
if (l1.gt.1e-10) a(3)=max(b1,b2)
if (imonit.eq.8) goto 10
if (itask.eq.4.or.itask.eq.5) then
# 2-axis diffractometer: only Colim.3 and detector
l1=sol3.frame.dist+det.frame.dist
d1=sam.size(1)+det.frame.size(1)
if (l1.gt.1e-10) a(4)=d1/l1
goto 10
else
# Analyzer
l1=sol3.frame.dist+ana.frame.dist
d1=sam.size(1)+abs(ana.frame.size(1)*sin(ana.thb-ana.chi))+
* abs(ana.frame.size(3)*cos(ana.thb-ana.chi))
if (l1.gt.1e-10) a(4)=d1/l1
endif
if (ana.nh.gt.1.or.ana.hmos.le.sec) then
z=1.d0
else
z=0.d0
endif
l1=sol3.frame.dist+ana.frame.dist
d1=sam.size(1)+ abs(ana.frame.size(3)*cos(ana.thb-ana.chi))
if(ana.nh.gt.1) then
d1=d1+abs(ana.frame.size(1)*sin(ana.thb-ana.chi))/ana.nh
endif
stmch=sin(ana.thb-ana.chi)
stpch=sin(ana.thb+ana.chi)
if (stmch.lt.1d-10) stmch=1d-10
# Colim. 4
l2=sol4.frame.dist
d2=sol4.frame.size(1)
ksi=stmch/stpch-2*z*ana.rh*l2/stmch
if (abs(l2+l1*ksi).gt.1.d-10) then
a(5)=(d2+abs(d1*ksi))/(l2+l1*ksi)
endif
if (imonit.eq.9) goto 10
l2=sol4.frame.dist+sol4.frame.size(3)
d2=sol4.w2
ksi=stmch/stpch-2*z*ana.rh*l2/stmch
if (abs(l2+l1*ksi).gt.1.d-10) then
a(6)=(d2+abs(d1*ksi))/(l2+l1*ksi)
endif
if (sol4.frame.size(3).gt.1d-10) then
b1=(sol4.w2+sol4.frame.size(1))/sol4.frame.size(3)/sol4.nlh
else
b1=1.d30
endif
b2=sol4.ghlu*4*pi/stp.kf
a(7)=max(b1,b2)
if (imonit.eq.10) goto 10
# Detector
l2=sol4.frame.dist+det.frame.dist
d2=det.frame.size(1)
ksi=stmch/stpch-2*z*ana.rh*l2/stmch
if (abs(l2+l1*ksi).gt.1.d-10) then
a(8)=(d2+abs(d1*ksi))/(l2+l1*ksi)
endif
10 ahmax=1d30
do i=1,20
ahmax=min(ahmax,abs(a(i)))
enddo
# Vertical, sample-detector
#--------------------------------
do i=1,20
a(i)=1e30
enddo
# Colim. 3
l1=sol3.frame.dist
d1=sam.size(2)+sol3.frame.size(2)
if (l1.gt.1e-10) a(1)=d1/l1
l1=sol3.frame.dist+sol3.frame.size(3)
d1=sam.size(2)+sol3.h2
if (l1.gt.1e-10) a(2)=d1/l1
if (sol3.frame.size(3).gt.1d-10) then
b1=(sol3.h2+sol3.frame.size(2))/sol3.frame.size(3)/sol3.nlv
else
b1=1.d30
endif
b2=sol3.gvt*4*pi/stp.kf
a(3)=max(b1,b2)
if (imonit.eq.8) goto 20
if (itask.eq.4.or.itask.eq.5.or.itask.eq.9) then
# 2-axis diffractometer: only Colim.3 and detector
l1=sol3.frame.dist+det.frame.dist
d1=sam.size(2)+det.frame.size(2)
if (l1.gt.1e-10) a(4)=d1/l1
goto 20
else
# Analyzer
l1=sol3.frame.dist+ana.frame.dist
d1=sam.size(2)+ana.frame.size(2)
if (l1.gt.1e-10) a(4)=d1/l1
endif
l1=sol3.frame.dist+ana.frame.dist
d1=sam.size(2)
if(ana.nv.gt.1) then
d1=d1+ana.frame.size(2)/ana.nv
endif
if (ana.nv.gt.1) then
z=1.d0
else
z=0.d0
endif
# Colim. 4
l2=sol4.frame.dist
d2=sol4.frame.size(2)
ksi=1-2*sin(ana.thb)*cos(ana.chi)*z*ana.rv*l2
if (abs(l2+l1*ksi).gt.1.d-10) then
a(5)=(d2+abs(d1*ksi))/(l2+l1*ksi)
endif
if (imonit.eq.9) goto 20
l2=sol4.frame.dist+sol4.frame.size(3)
d2=sol4.h2
ksi=1-2*sin(ana.thb)*cos(ana.chi)*z*ana.rv*l2
if (abs(l2+l1*ksi).gt.1.d-10) then
a(6)=(d2+abs(d1*ksi))/(l2+l1*ksi)
endif
if (sol4.frame.size(3).gt.1d-10) then
b1=(sol4.h2+sol4.frame.size(2))/sol4.frame.size(3)/sol4.nlv
else
b1=1.d30
endif
b2=sol4.gvt*4*pi/stp.kf
a(7)=max(b1,b2)
if (imonit.eq.10) goto 20
# Detector
l2=sol4.frame.dist+det.frame.dist
d2=det.frame.size(2)
ksi=1-2*sin(ana.thb)*cos(ana.chi)*z*ana.rv*l2
if (abs(l2+l1*ksi).gt.1.d-10) then
a(8)=(d2+abs(d1*ksi))/(l2+l1*ksi)
endif
20 avmax=1d30
do i=1,20
avmax=min(avmax,abs(a(i)))
enddo
# IF(ANA.NV.GT.1) THEN
# D1=ANA.FRAME.SIZE(2)/ANA.NV
# L1=SOL3.FRAME.DIST+ANA.FRAME.DIST
# AVMAX=AVMAX+ABS(D1/L1)
# ENDIF
end
#------------------------------------------------------------------------
SUBROUTINE APERTURE1(itask,ahmax,avmax,wmax,hmax,band)
# Calculate maximum angular deviations transmitted through the instrument
# for the PRIMARY spectrometer (sample-source)
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'structures.inc'
INCLUDE 'ness_common.inc'
real*8 ahmax,avmax,wmax,hmax,band
integer*4 itask,i
real*8 a(20),b(30),c(30)
real*8 l1,d1,l2,d2,ksi,stmch,stpch,ctmch,ctpch,sgnm,z
real*8 a1,a2,a3,w2,h2,f1,eta
real*8 ah1,ah2,ah3,av1,av2,av3
real*8 g1,g2,g3,g4,g5
real*8 GETEFFMOS
# write(*,*) 'APERTURE1 entry'
# Horizontal, sample->source
#--------------------------------
do i=1,20
a(i)=1e30
enddo
do i=1,30
b(i)=1e30
enddo
do i=1,20
c(i)=1e30
enddo
# Colim. 2
g1=sol2.ghlu*4*pi/stp.ki
w2=sol2.frame.size(1)
l1=sol2.frame.dist
d1=sam.size(1)+w2
if (l1.gt.1e-10) a(1)=d1/l1
#----
w2=sol2.w2
l1=sol2.frame.dist+sol2.frame.size(3)
d1=sam.size(1)+w2
if (l1.gt.1e-10) a(2)=max(d1/l1,g1)
l1=sol2.frame.size(3)
d1=(w2+sol2.frame.size(1))/sol2.nlh
if (l1.gt.1e-10) a(3)=max(d1/l1,g1)
# Colim. 2A
g2=sol2a.ghlu*4*pi/stp.ki
w2=sol2a.frame.size(1)
l1=sol2a.frame.dist+sol2.frame.dist
d1=sam.size(1)+w2
if (l1.gt.1e-10) a(4)=max(d1/l1,g1)
l1=l1-sol2.frame.dist
d1=sol2.frame.size(1)+w2
if (l1.gt.1e-10) a(5)=max(d1/l1,g1)
l1=l1-sol2.frame.size(3)
d1=sol2.w2+w2
if (l1.gt.1e-10) a(6)=max(d1/l1,g1)
#----
w2=sol2a.w2
l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
d1=sam.size(1)+w2
if (l1.gt.1e-10) a(7)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.dist
d1=sol2.frame.size(1)+w2
if (l1.gt.1e-10) a(8)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.size(3)
d1=sol2.w2+w2
if (l1.gt.1e-10) a(9)=max(d1/l1,g1,g2)
l1=sol2a.frame.size(3)
d1=(w2+sol2a.frame.size(1))/sol2a.nlh
if (l1.gt.1e-10) a(10)=max(d1/l1,g2)
# Monochromator
sgnm=-sign(1,stp.sm) ! "minus" because of the up-stream tracing
stmch=sin(mon.thb-sgnm*mon.chi)
stpch=sin(mon.thb+sgnm*mon.chi)
ctmch=cos(mon.thb-sgnm*mon.chi)
ctpch=cos(mon.thb+sgnm*mon.chi)
if (abs(stmch).lt.1d-10) stmch=1d-10
if (abs(stpch).lt.1d-10) stpch=1d-10
w2=abs(mon.frame.size(1)*stmch)+abs(mon.frame.size(3)*ctmch)
l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
d1=sam.size(1)+w2
if (l1.gt.1e-10) a(11)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.dist
d1=sol2.frame.size(1)+w2
if (l1.gt.1e-10) a(12)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.size(3)
d1=sol2.w2+w2
if (l1.gt.1e-10) a(13)=max(d1/l1,g1,g2)
l1=mon.frame.dist
d1=sol2a.frame.size(1)+w2
if (l1.gt.1e-10) a(14)=max(d1/l1,g1,g2)
l1=l1-sol2a.frame.size(3)
d1=sol2a.w2+w2
if (l1.gt.1e-10) a(15)=max(d1/l1,g1,g2)
ah1=1.d30
do i=1,20
ah1=min(ah1,abs(a(i)))
enddo
# do i=1,20
# if(ah1.eq.abs(a(i))) write(*,*) 'a: ', i,a(i)
# enddo
#// End of primary part (before monochromator)
# Colim. 1
w2=sol1.frame.size(1)
g3=sol1.ghlu*4*pi/stp.ki
l1=sol1.frame.dist
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(1)=d1/l1
#---------
w2=sol1.w2
l1=sol1.frame.dist+sol1.frame.size(3)
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(2)=max(d1/l1,g3)
l1=sol1.frame.size(3)
d1=(w2+sol1.frame.size(1))/sol1.nlh
if (l1.gt.1e-10) b(3)=max(d1/l1,g3)
# Guide B
w2=guide.frame.size(1)
g4=guide.ghlu*4*pi/stp.ki
l1=sol1.frame.dist+guide.frame.dist
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(4)=max(d1/l1,g3)
l1=guide.frame.dist
d1=sol1.frame.size(1)+w2
if (l1.gt.1e-10) b(5)=max(d1/l1,g3)
l1=guide.frame.dist-sol1.frame.size(3)
d1=sol1.w2+w2
if (l1.gt.1e-10) b(6)=max(d1/l1,g3)
#---------
w2=guide.w2
l1=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(7)=max(d1/l1,g3,g4)
l1=guide.frame.dist+guide.frame.size(3)
d1=sol1.frame.size(1)+w2
if (l1.gt.1e-10) b(8)=max(d1/l1,g3,g4)
l1=guide.frame.dist+guide.frame.size(3)-sol1.frame.size(3)
d1=sol1.w2+w2
if (l1.gt.1e-10) b(9)=max(d1/l1,g3,g4)
l1=guide.frame.size(3)
d1=(guide.frame.size(1)+w2)/guide.nlh
if (l1.gt.1e-10) b(10)=max(d1/l1,g4)
# Guide A
w2=gdea.frame.size(1)
g5=gdea.ghlu*4*pi/stp.ki
l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(11)=max(d1/l1,g3,g4)
l1=guide.frame.dist+gdea.frame.dist
d1=sol1.frame.size(1)+w2
if (l1.gt.1e-10) b(12)=max(d1/l1,g3,g4)
l1=guide.frame.dist+gdea.frame.dist-sol1.frame.size(3)
d1=sol1.w2+w2
if (l1.gt.1e-10) b(13)=max(d1/l1,g3,g4)
l1=gdea.frame.dist
d1=guide.frame.size(1)+w2
if (l1.gt.1e-10) b(14)=max(d1/l1,g3,g4)
l1=gdea.frame.dist-guide.frame.size(3)
d1=guide.w2+w2
if (l1.gt.1e-10) b(15)=max(d1/l1,g3,g4)
#---------
w2=gdea.w2
l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
* gdea.frame.size(3)
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(16)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)
d1=sol1.frame.size(1)+w2
if (l1.gt.1e-10) b(17)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)-
* sol1.frame.size(3)
d1=sol1.w2+w2
if (l1.gt.1e-10) b(18)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+gdea.frame.size(3)
d1=guide.frame.size(1)+w2
if (l1.gt.1e-10) b(19)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+gdea.frame.size(3)-guide.frame.size(3)
d1=guide.w2+w2
if (l1.gt.1e-10) b(20)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.size(3)
d1=(gdea.frame.size(1)+w2)/gdea.nlh
if (l1.gt.1e-10) b(21)=max(d1/l1,g5)
# Source
l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
d1=abs(mon.frame.size(1)*stpch)+abs(mon.frame.size(3)*ctpch)+w2
if (l1.gt.1e-10) b(22)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+sou.dist
d1=sol1.frame.size(1)+w2
if (l1.gt.1e-10) b(23)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+sou.dist-sol1.frame.size(3)
d1=sol1.w2+w2
if (l1.gt.1e-10) b(24)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+sou.dist
d1=guide.frame.size(1)+w2
if (l1.gt.1e-10) b(25)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+sou.dist-guide.frame.size(3)
d1=guide.w2+w2
if (l1.gt.1e-10) b(26)=max(d1/l1,g3,g4,g5)
l1=sou.dist
d1=gdea.frame.size(1)+w2
if (l1.gt.1e-10) b(27)=max(d1/l1,g3,g4,g5)
l1=sou.dist-gdea.frame.size(3)
d1=gdea.w2+w2
if (l1.gt.1e-10) b(28)=max(d1/l1,g3,g4,g5)
ah2=1.d30
do i=1,30
ah2=min(ah2,abs(b(i)))
enddo
# do i=1,30
# if(ah2.eq.abs(b(i))) write(*,*) 'b: ', i,b(i)
# enddo
#// End of secondary part (after monochromator)
#// find max. divergence
# write(*,*) 'MON.RH,MON.NH ',MON.RH,MON.NH,stmch
z=0.d0
if (mon.rh.ne.0.d0.and.
* (mon.nh.gt.1.or.mon.hmos.le.sec)) then
# write(*,*) '????'
z=1.d0
f1=0.5*stmch/mon.rh
else
f1=1.d30
endif
l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
d1=sam.size(1)+abs(mon.frame.size(3)*ctmch)
if(mon.nh.gt.1) then
d1=d1+abs(mon.frame.size(1)*stmch)/mon.nh
endif
# write(*,*) 'stmch,F1 ',stmch,F1
eta=abs(GETEFFMOS(mon))+2.*mon.hmos
# write(*,*) 'eta ',eta
# Colim. 1
l2=sol1.frame.dist
d2=sol1.frame.size(1)
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10) then
c(1)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
l2=sol1.frame.dist+sol1.frame.size(3)
d2=sol1.w2
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
c(2)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# write(*,*) 'col1 ',C(1),C(2)
# Guide B
l2=sol1.frame.dist+guide.frame.dist
d2=guide.frame.size(1)
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
c(3)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
l2=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
d2=guide.w2
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
c(4)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# write(*,*) 'GDB ',C(3),C(4)
# Guide A
l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
d2=gdea.frame.size(1)
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
c(5)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
* gdea.frame.size(3)
d2=gdea.w2
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
* and.g5.eq.0) then
c(6)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# write(*,*) 'GDA ',C(5),C(6)
# Source
l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
d2=sou.size(1)
ksi=stpch/stmch-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
* and.g5.eq.0) then
c(7)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# write(*,*) 'SRC ',C(7)
ah3=1.d30
do i=1,20
ah3=min(ah3,abs(c(i)))
enddo
# do i=1,20
# if(ah3.eq.abs(c(i))) write(*,*) 'c: ', i,c(i)
# enddo
ahmax=min(ah1,ah3)
#// get max. beam width at the sample
wmax=sam.size(1)
l1=sol2.frame.dist
d1=sol2.frame.size(1)
wmax=min(wmax,d1+l1*ahmax)
l1=sol2.frame.dist+sol2.frame.size(3)
d1=sol2.w2
wmax=min(wmax,d1+l1*ahmax)
l1=sol2.frame.dist+sol2a.frame.dist
d1=sol2a.frame.size(1)
wmax=min(wmax,d1+l1*ahmax)
l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
d1=sol2a.w2
wmax=min(wmax,d1+l1*ahmax)
l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
d1=abs(mon.frame.size(1)*stmch)+abs(mon.frame.size(3)*ctmch)
wmax=min(wmax,d1+l1*ahmax)
if(mon.nh.eq.1.and.abs(f1-l1).gt.1.d-10) then
ahmax=min(ahmax,(abs(ah2*f1)+wmax+2.d0*eta*abs(f1))/abs(f1-l1))
endif
# WRITE(*,*) 'GAMMA ',(ABS(AH2*F1)+WMAX+2.D0*ETA*ABS(F1))/ABS(F1-L1)
#--------------------------------
# Vertical, sample->source
#--------------------------------
do i=1,20
a(i)=1e30
enddo
do i=1,30
b(i)=1e30
enddo
do i=1,20
c(i)=1e30
enddo
# Colim. 2
g1=sol2.gvt*4*pi/stp.ki
l1=sol2.frame.dist
d1=sam.size(2)+sol2.frame.size(2)
if (l1.gt.1e-10) a(1)=d1/l1
#----
l1=sol2.frame.dist+sol2.frame.size(3)
d1=sam.size(2)+sol2.h2
if (l1.gt.1e-10) a(2)=max(d1/l1,g1)
l1=sol2.frame.size(3)
d1=(sol2.h2+sol2.frame.size(2))/sol2.nlv
if (l1.gt.1e-10) a(3)=max(d1/l1,g1)
# Colim. 2A
g2=sol2a.gvt*4*pi/stp.ki
h2=sol2a.frame.size(2)
l1=sol2a.frame.dist+sol2.frame.dist
d1=sam.size(2)+h2
if (l1.gt.1e-10) a(4)=max(d1/l1,g1)
l1=l1-sol2.frame.dist
d1=sol2.frame.size(2)+h2
if (l1.gt.1e-10) a(5)=max(d1/l1,g1)
l1=l1-sol2.frame.size(3)
d1=sol2.h2+h2
if (l1.gt.1e-10) a(6)=max(d1/l1,g1)
#----
h2=sol2a.h2
l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
d1=sam.size(2)+h2
if (l1.gt.1e-10) a(7)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.dist
d1=sol2.frame.size(2)+h2
if (l1.gt.1e-10) a(8)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.size(3)
d1=sol2.h2+h2
if (l1.gt.1e-10) a(9)=max(d1/l1,g1,g2)
l1=sol2a.frame.size(3)
d1=(sol2a.h2+sol2a.frame.size(2))/sol2a.nlv
if (l1.gt.1e-10) a(10)=max(d1/l1,g2)
# Monochromator
h2=mon.frame.size(2)
l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
d1=sam.size(2)+h2
if (l1.gt.1e-10) a(11)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.dist
d1=sol2.frame.size(2)+h2
if (l1.gt.1e-10) a(12)=max(d1/l1,g1,g2)
l1=l1-sol2.frame.size(3)
d1=sol2.h2+h2
if (l1.gt.1e-10) a(13)=max(d1/l1,g1,g2)
l1=mon.frame.dist
d1=sol2a.frame.size(2)+h2
if (l1.gt.1e-10) a(14)=max(d1/l1,g1,g2)
l1=l1-sol2a.frame.size(3)
d1=sol2a.h2+h2
if (l1.gt.1e-10) a(15)=max(d1/l1,g1,g2)
av1=1.d30
do i=1,20
av1=min(av1,abs(a(i)))
enddo
# do i=1,20
# if(av1.eq.abs(a(i))) write(*,*) 'a: ', i,a(i)
# enddo
#// End of primary part (before monochromator)
# Colim. 1
h2=sol1.frame.size(2)
g3=sol1.gvt*4*pi/stp.ki
l1=sol1.frame.dist
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(1)=d1/l1
#---------
h2=sol1.h2
l1=sol1.frame.dist+sol1.frame.size(3)
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(2)=max(d1/l1,g3)
l1=sol1.frame.size(3)
d1=(h2+sol1.frame.size(2))/sol1.nlv
if (l1.gt.1e-10) b(3)=max(d1/l1,g3)
# Guide B
h2=guide.frame.size(2)
g4=guide.gvt*4*pi/stp.ki
l1=sol1.frame.dist+guide.frame.dist
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(4)=max(d1/l1,g3)
l1=guide.frame.dist
d1=sol1.frame.size(2)+h2
if (l1.gt.1e-10) b(5)=max(d1/l1,g3)
l1=guide.frame.dist-sol1.frame.size(3)
d1=sol1.h2+h2
if (l1.gt.1e-10) b(6)=max(d1/l1,g3)
#---------
h2=guide.h2
l1=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(7)=max(d1/l1,g3,g4)
l1=guide.frame.dist+guide.frame.size(3)
d1=sol1.frame.size(2)+h2
if (l1.gt.1e-10) b(8)=max(d1/l1,g3,g4)
l1=guide.frame.dist+guide.frame.size(3)-sol1.frame.size(3)
d1=sol1.h2+h2
if (l1.gt.1e-10) b(9)=max(d1/l1,g3,g4)
l1=guide.frame.size(3)
d1=(guide.frame.size(2)+h2)/guide.nlv
if (l1.gt.1e-10) b(10)=max(d1/l1,g4)
# Guide A
h2=gdea.frame.size(2)
g5=gdea.gvt*4*pi/stp.ki
l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(11)=max(d1/l1,g3,g4)
l1=guide.frame.dist+gdea.frame.dist
d1=sol1.frame.size(2)+h2
if (l1.gt.1e-10) b(12)=max(d1/l1,g3,g4)
l1=guide.frame.dist+gdea.frame.dist-sol1.frame.size(3)
d1=sol1.h2+h2
if (l1.gt.1e-10) b(13)=max(d1/l1,g3,g4)
l1=gdea.frame.dist
d1=guide.frame.size(2)+h2
if (l1.gt.1e-10) b(14)=max(d1/l1,g3,g4)
l1=gdea.frame.dist-guide.frame.size(3)
d1=guide.h2+h2
if (l1.gt.1e-10) b(15)=max(d1/l1,g3,g4)
#---------
h2=gdea.h2
l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
* gdea.frame.size(3)
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(16)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)
d1=sol1.frame.size(2)+h2
if (l1.gt.1e-10) b(17)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+gdea.frame.size(3)-
* sol1.frame.size(3)
d1=sol1.h2+h2
if (l1.gt.1e-10) b(18)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+gdea.frame.size(3)
d1=guide.frame.size(2)+h2
if (l1.gt.1e-10) b(19)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+gdea.frame.size(3)-guide.frame.size(3)
d1=guide.h2+h2
if (l1.gt.1e-10) b(20)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.size(3)
d1=(gdea.frame.size(2)+h2)/gdea.nlv
if (l1.gt.1e-10) b(21)=max(d1/l1,g5)
# Source
l1=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
d1=mon.frame.size(2)+h2
if (l1.gt.1e-10) b(22)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+sou.dist
d1=sol1.frame.size(2)+h2
if (l1.gt.1e-10) b(23)=max(d1/l1,g3,g4,g5)
l1=guide.frame.dist+gdea.frame.dist+sou.dist-sol1.frame.size(3)
d1=sol1.h2+h2
if (l1.gt.1e-10) b(24)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+sou.dist
d1=guide.frame.size(2)+h2
if (l1.gt.1e-10) b(25)=max(d1/l1,g3,g4,g5)
l1=gdea.frame.dist+sou.dist-guide.frame.size(3)
d1=guide.h2+h2
if (l1.gt.1e-10) b(26)=max(d1/l1,g3,g4,g5)
l1=sou.dist
d1=gdea.frame.size(2)+h2
if (l1.gt.1e-10) b(27)=max(d1/l1,g3,g4,g5)
l1=sou.dist-gdea.frame.size(3)
d1=gdea.h2+h2
if (l1.gt.1e-10) b(28)=max(d1/l1,g3,g4,g5)
av2=1.d30
do i=1,30
av2=min(av2,abs(b(i)))
enddo
# do i=1,30
# if(av2.eq.abs(b(i))) write(*,*) 'b: ', i,b(i)
# enddo
#// End of secondary part (after monochromator)
#// find max. divergence
z=0.d0
if (mon.rv.ne.0.d0.and.mon.nv.gt.1.and.
* abs(cos(mon.chi)).gt.1.d-3) then
z=1.d0
f1=0.5/cos(mon.chi)/sin(mon.thb)/mon.rv
else
f1=1.d30
endif
l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
d1=sam.size(2)
if(mon.nv.gt.1) then
d1=d1+mon.frame.size(2)/mon.nv
endif
eta=4.*mon.vmos*cos(mon.chi)*sin(mon.thb)
# Colim. 1
l2=sol1.frame.dist
d2=sol1.frame.size(2)
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10) then
c(1)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
l2=sol1.frame.dist+sol1.frame.size(3)
d2=sol1.h2
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
c(2)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# Guide B
l2=sol1.frame.dist+guide.frame.dist
d2=guide.frame.size(2)
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0) then
c(3)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
l2=sol1.frame.dist+guide.frame.dist+guide.frame.size(3)
d2=guide.h2
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
c(4)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# Guide A
l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist
d2=gdea.frame.size(2)
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0) then
c(5)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+
* gdea.frame.size(3)
d2=gdea.h2
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
* and.g5.eq.0) then
c(6)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# Source
l2=sol1.frame.dist+guide.frame.dist+gdea.frame.dist+sou.dist
d2=sou.size(2)
ksi=1.d0-l2/f1
if (abs(l2+l1*ksi).gt.1.d-10.and.g3.eq.0.and.g4.eq.0.
* and.g5.eq.0) then
c(7)=(d2+abs(d1*ksi)+2*eta*l2)/(l2+l1*ksi)
endif
# write(*,*) 'ksi: ',ksi,D1*ksi,L2+L1*ksi
av3=1.d30
do i=1,20
av3=min(av3,abs(c(i)))
enddo
# do i=1,30
# if(av3.eq.abs(c(i))) write(*,*) 'c: ', i,c(i)
# enddo
avmax=min(av1,av3)
#// get max. beam height at the sample
hmax=sam.size(2)
l1=sol2.frame.dist
d1=sol2.frame.size(2)
hmax=min(hmax,d1+l1*av1)
l1=sol2.frame.dist+sol2.frame.size(3)
d1=sol2.h2
hmax=min(hmax,d1+l1*av1)
l1=sol2.frame.dist+sol2a.frame.dist
d1=sol2a.frame.size(2)
hmax=min(hmax,d1+l1*av1)
l1=sol2.frame.dist+sol2a.frame.dist+sol2a.frame.size(3)
d1=sol2a.h2
hmax=min(hmax,d1+l1*av1)
l1=sol2.frame.dist+sol2a.frame.dist+mon.frame.dist
d1=mon.frame.size(2)
hmax=min(hmax,d1+l1*av1)
if(mon.nv.eq.1.and.abs(f1-l1).gt.1.d-10) then
avmax=min(avmax,abs((abs(av2*f1)+hmax+abs(eta*f1))/(f1-l1)))
endif
# IF(MON.NV.GT.1) THEN
# D1=MON.FRAME.SIZE(2)/MON.NV
# L1=SOL2.FRAME.DIST+SOL2a.FRAME.DIST+MON.FRAME.DIST
# AVMAX=AVMAX+ABS(D1/L1)
# ENDIF
# write(*,*) 'AV: ',ABS((ABS(AV2*F1)+HMAX+ABS(ETA*F1))/(F1-L1))
# DO I=1,20
# IF (avmax.eq.ABS(A(I))) write(*,*) 'Hor. limit: ', I,A(I)
# ENDDO
a1=4*mon.hmos ! mosaicity
a2=GETEFFMOS(mon)
a3=0.5*tan(mon.thb)*(avmax/2)**2 ! vertical divergence
band=sqrt(a1**2+a2**2+a3**2)+ah2
#10 format('AHMAX, WMAX, AH1, AH2, AH3, BAND',6(1x,G10.4))
#20 format('AVMAX, HMAX, AV1, AV2, AV3',5(1x,G12.6))
# write(*,*) 'APERTURE 1'
# write(*,10) AHMAX, WMAX, AH1, AH2, AH3, BAND
# write(*,20) AVMAX, HMAX, AV1, AV2 , AV3
# pause
end