Source module last modified on Tue, 29 Mar 2005, 14:17;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#//////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X 4.4
#////
#//// Conversion subroutines between RESCAL and TRAX parameters
#////
#//// * SUBROUTINE RT_CONVRT
#//// * SUBROUTINE VIVF(VI,VF)
#////
#//////////////////////////////////////////////////////////////////////
#----------------------------------------------------
SUBROUTINE READ_SOU(line,ns,dia,w,h,ier)
# Read parameters of a DETECTOR from the CFG file
#-----------------------------------------------------------
implicit none
integer*4 ns,ier
real*8 dia,w,h
character*128 line
ier=0
read(line,*,err=99) ns,dia,w,h
return
99 ier=1
end
#----------------------------------------------------
SUBROUTINE READ_DET(line,nd,dia,w,h,angle,nseg,space,phi,ier)
# Read parameters of a DETECTOR from the CFG file
#-----------------------------------------------------------
implicit none
integer*4 nd,nseg,ier
real*8 dia,w,h,angle,space,phi
character*128 line
ier=0
read(line,*,err=1) nd,dia,w,h,angle,nseg,space,phi
return
1 read(line,*,err=99) nd,dia,w,h
angle=0.d0
nseg=1
space=0.d0
phi=0.d0
return
99 ier=1
end
#----------------------------------------------------
SUBROUTINE READ_MONO(line,chi,aniz,pois,thick,height,width,
* nh,nv,nb,ier)
# Read parameters of a CRYSTAL from the CFG file
#-----------------------------------------------------------
implicit none
real*8 chi,aniz,pois,thick,height,width
integer*4 nh,nv,nb,ier
character*128 line
ier=0
read(line,*,err=1) chi,aniz,pois,thick,height,width,
* nh,nv,nb
return
1 read(line,*,err=99) chi,aniz,pois,thick,height,width,
* nh,nv
nb=1
return
99 ier=1
end
#-----------------------------------------------------------
SUBROUTINE READ_COL(line,dist,leng,h1,h2,v1,v2,ic,ier)
# Read parameters of a GUIDE/COLLIMATOR from the CFG file
# IC .. collimator index
#-----------------------------------------------------------
implicit none
INCLUDE 'collimators.inc'
real*8 dist,leng,h1,h2,v1,v2
integer*4 ic,ier
character*128 line
10 format(a15,8(1x,g10.4))
ier=0
# full format
read(line,*,err=1) ctyp(ic),dist,leng,h1,h2,v1,v2,roh(ic),rov(ic),
& gamh(ic),gamv(ic),refh(ic),refv(ic),nlam(ic),vlam(ic),
& dlamh(ic),dlamv(ic)
# write(*,10) 'full format',IC,CTYP(IC),ROH(IC),ROV(IC)
if (ctyp(ic).gt.4.or.ctyp(ic).lt.-1) goto 1 ! -1 >= CTYP <= 4, else error
if (leng.le.0) ctyp(ic)=-1
return
# old RESTRAX format, extended by NLAM, VLAM, DLAM
1 read(line,*,err=2) dist,leng,h1,h2,v1,v2,roh(ic),gamh(ic),
& gamv(ic),refh(ic),refv(ic),nlam(ic),vlam(ic),dlamh(ic)
# write(*,*) 'format 1!'
ctyp(ic)=0
dlamv(ic)=dlamh(ic)
rov(ic)=0
if (gamh(ic).gt.0.or.gamv(ic).gt.0) ctyp(ic)=1
if (leng.le.0) ctyp(ic)=-1
return
# old RESTRAX format, extended by NLAM,DLAM
2 read(line,*,err=3) dist,leng,h1,h2,v1,v2,roh(ic),gamh(ic),
& gamv(ic),refh(ic),refv(ic),nlam(ic),dlamh(ic)
# write(*,*) 'format 2!'
vlam(ic)=0
dlamv(ic)=dlamh(ic)
rov(ic)=0
ctyp(ic)=0
if (gamh(ic).gt.0.or.gamv(ic).gt.0) ctyp(ic)=1
if (leng.le.0) ctyp(ic)=-1
return
# old RESTRAX format
3 read(line,*,err=99) dist,leng,h1,h2,v1,v2,roh(ic),gamh(ic),
& gamv(ic),refh(ic),refv(ic)
# write(*,*) 'format 3!'
nlam(ic)=0
vlam(ic)=0
dlamh(ic)=0.0
dlamv(ic)=dlamh(ic)
rov(ic)=0
ctyp(ic)=0
if (gamh(ic).gt.0.or.gamv(ic).gt.0) ctyp(ic)=1
if (leng.le.0) ctyp(ic)=-1
return
99 ier=1
end
#--------------------------------------------------------------
SUBROUTINE READ_COL1(line,nf,dist,leng,h1,h2,v1,v2,ic,ier)
# Read parameters of a GUIDE/COLLIMATOR from the CFG file, with presence indicator
#--------------------------------------------------------------
implicit none
real*8 dist,leng,h1,h2,v1,v2
integer*4 ic,nf,is,il,ier
character*128 line
ier=0
is=1
call FINDPAR(line,1,is,il)
if (il.le.0) goto 99
read(line(is:is+il-1),*,err=99) nf
call READ_COL(line(is+il:128),dist,leng,h1,h2,v1,v2,ic,ier)
return
99 ier=1
end
#----------------------------------------------------------
SUBROUTINE READCFG(fname)
# Read configuration from FNAME (assume that exists)
# + some initial conversions
#----------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'collimators.inc'
INCLUDE 'rescal.inc'
INCLUDE 'trax.inc'
integer*4 iu
parameter (iu=25)
character*(*) fname
character*128 line
data nhm,nha,nvm,nva /1,1,1,1/
integer*4 ier,iline,i,is,il
#xxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxxCxxxxxxxxx
100 format(a60)
101 format(a)
call BOUNDS(fname,is,il)
open(unit=iu,file=fname(is:is+il-1),status= 'OLD',err=999,
* iostat=ier)
# *** READ CFG FILE ***
iline=0
#* Source
3 read(iu,*,end=997)
read(iu,100,end=997) cfgtitle
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_SOU(line,nsou,diasou,wsou,hsou,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* Guide A
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL(line,dga,lga,hga1,hga2,vga1,vga2,1,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* Guide B
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL1(line,nfg,dguide,lguide,hg1,hg2,vg1,vg2,2,ier)
if (ier.ne.0) goto 997
iline=iline+2
if (nfg.eq.0) then ! ignore guides
ctyp(2)=-1
ctyp(1)=-1
endif
#* Monochromator
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_MONO(line,himon,anrm,poissm,thmon,hmon,wmon,nhm,
& nvm,nbm,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* Analyzer
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_MONO(line,hiana,anra,poissa,thana,hana,wana,nha,
& nva,nba,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* Detector
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_DET(line,ndet,diadet,wdet,hdet,adet,nsegdet,spacedet,
* phidet,ier)
if(nsegdet.gt.64) nsegdet=64
if (ier.ne.0) goto 997
iline=iline+2
#* Distances
read(iu,*,end=997)
read(iu,*,end=997,err=997) vl0,vl1,vl2,vl3
iline=iline+2
#* COL1
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL(line,vlcanm,vlsm,hdm1,hdm2,vdm1,vdm2,3,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* COL2 A
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL(line,dist2a,len2a,h2a1,h2a2,v2a1,v2a2,4,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* COL2 B
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL(line,vlcans,vlms,hds1,hds2,vds1,vds2,5,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* COL3
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL(line,vlcana,vlsa,hda1,hda2,vda1,vda2,6,ier)
if (ier.ne.0) goto 997
iline=iline+2
#* COL4
read(iu,*,end=997)
read(iu,101,end=997) line
call READ_COL(line,vlcand,vlad,hdd1,hdd2,vdd1,vdd2,7,ier)
if (ier.ne.0) goto 997
iline=iline+2
# *** END OF READ CFG FILE, go to interpretation ***
close(iu)
go to 2
# *** ERROR while reading, show message and go to interpretation anyway ***
997 write(sout,*) 'ERROR after line ',iline, ' in file '//fname
write(sout,*) line
pause
close(iu)
2 continue
# some unit conversions
do i=1,nco
gamh(i)=gamh(i)*gammani
gamv(i)=gamv(i)*gammani
if (ctyp(i).le.1) then ! convert RO to [mm]
roh(i)=roh(i)/1000.
rov(i)=rov(i)/1000.
endif
enddo
write(sout,*) 'Configuration updated from ',fname(is:is+il-1)
return
999 write(*,998) ier
998 format( 'Fatal error: ',i5, ' cannot open configuration file. ',/,
* 'Check privileges or disk space !')
stop
end
#----------------------------------------------------------
SUBROUTINE WRITEDEFCFG
# Write default config. file to the current directory
# Use the full format (new in since version 4.9.92)
# TYP=-1 no collimator
# TYP=0 standard collimator (course or soller)
# TYP=1 guide (or bender), can be curved (RO means curvature in [1/m] )
# TYP=2 parabolic guide, equal lengths of the lamellae (RO means focal distance in [cm] !)
# TYP=3 parabolic guide, optimized lengths of the lamellae
# TYP=4 elliptic guide, wider window is the smaller ellipse axis
#
# extended detector format:
# =========================
# if eta>0, then assumes vertical tube(s)
# nseg = number of tubes
# space = space between tubes [mm]
# phi = inclination angle [deg], phi=0 means tube is vertical
# detector efficiency: 1-EXP(-eta*lambda*pathlength)
#----------------------------------------------------------
implicit none
character*16 c(13)
character*82 vals(13),head(13)
integer*4 i
# element names
data c/
& 'title',
& 'n-guide A',
& 'n-guide B',
& 'monochromator',
& 'analyzer',
& 'segments',
& 'detector',
& 'distances',
& '1st collimator',
& '2nd collimator A',
& '2nd collimator B',
& '3nd collimator',
& '4th collimator'/
# some headers
vals(1)= 'default setup (IN14 with PG and Soller)'
vals(2)= '0 21. 6. 12.'
vals(3)= '1 7.5 584.5 6. 6. 12. 12. 0. 0. 1.2 1.2 1 1'//
1 ' 1 1 0. 0.'
vals(4)= '1 1 807.5 1050. 6. 6. 12. 12. 0. 0. 1.2 1.2'//
1 ' 1 1 1 1 0. 0.'
vals(5)= '0. 1. 0.3 0.2 12. 15. 1 7 1'
vals(6)= '0. 1. 0.3 1.0 12. 16. 1 5 1'
vals(7)= '1 4.0 4.0 6.0 0.0 1 0. 0.'
vals(8)= '22.5 270. 155. 64.'
vals(9)= '0 1. 5. 10. 10. 15. 15. 0. 0. 0. 0.'//
1 ' 0. 0. 1 1 0. 0.'
vals(10)= '-1 2. 0. 6. 6 12. 12. 0. 0. 0. 0.'//
1 ' 0. 0. 1 1 0. 0.'
vals(11)= '0 100. 20. 4. 4. 12. 12 0. 0. 0. 0.'//
1 ' 0. 0. 1 1 0. 0.'
vals(12)= '0 113. 20. 4. 4. 12. 12. 0. 0. 0. 0.'//
1 ' 0. 0. 1 1 0. 0.'
vals(13)= '0 35. 20. 4. 4. 12. 12. 0. 0. 0. 0.'//
1 ' 0. 0. 1 1 0. 0.'
head(1)= 'title (max.60 characters)'
head(2)= 'shape, dia, width, height'
head(3)= 'typ, gap, len, H1, H2, V1, V2, roh, rov,'//
1 ' mh, mv, refh, refv, nh, nv, dh, dv'
head(4)= 'use, typ, dist, len, H1, H2, V1, V2, roh, rov,'//
1 ' mh, mv, refh, refv, nh, nv, dh, dv'
head(5)= 'chi, aniz., poiss., thick., height, length, nh, nv, nt'
head(6)=head(5)
head(7)= 'shape, dia, width, height, eta, nseg, space, angle'
head(8)= 'sou-mono, mono-sample, sample-anal, anal-det'
head(9)= 'typ, dist, len, H1, H2, V1, V2, roh, rov,'//
1 ' mh, mv, refh, refv, nh, nv, dh, dv'
head(10)=head(3)
head(11)=head(9)
head(12)=head(9)
head(13)=head(9)
1 format(a13, ' (',a, ')')
2 format(a)
open(unit=24,file= 'simres00.cfg',status= 'UNKNOWN',err=10)
do i=1,13
write(24,1) c(i),head(i)
write(24,2) vals(i)
enddo
close(24)
10 continue
end
#----------------------------------------------------------
SUBROUTINE SETDEFRES
# Sets the default rescal parameters and write to default.res file
# in the current directory
#----------------------------------------------------------
implicit none
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
integer*4 i
do i=1,mres
res_dat(i)=res_def(i)
enddo
call WRITE_RESCAL(rescal_defname,i)
end