Source module last modified on Tue, 2 May 2006, 0:54;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#//////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X
#////
#//// RESTRAX: Some subroutines for I/O operations
#////
#//////////////////////////////////////////////////////////////////////
#--------------------------------------------------------
SUBROUTINE CHECKRESFILE(fname,fpath,isil,ires,fres)
# Test existence of a file
# INPUT:
# fname ... filename
# fpath ... colon delimited list of search directories
# isil ... silence level, if isil>0 => no message
# RETURN:
# fres ... resulting filename (incl. path)
# IRES>0 ... ord. number of the path string from fpath
# IRES=0 ... not found
#--------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) fname,fpath,fres
integer *4 ires,isil
integer*4 is,il,isf,ilf,ll,lres,j,ip
logical*4 log1
character*128 ffn
3 format( ' File not found : ',a)
5 format( ' File "',a, '" found at "',a, '"')
#11 FORMAT(' CHECKRESFILE: ',I4,' <',a,'>')
call BOUNDS(fname,isf,ilf)
# write(*,11) ILF,TRIM(FNAME)
lres=len(fres)
log1=.false.
il=1
ffn= ' '
j=1
ip=0
# if (j.gt.is) write(*,11) IL,trim(fpath)
do while (.not.log1.and.il.ge.0)
ip=ip+1
call FINDSTRPAR(fpath, ':',ip,is,il)
# write(*,*) 'CHECKRESFILE: after FINDSTRPAR', IP,IS,IL
if (il.ge.0) then
j=is+il-1
# write(*,*) 'before path selection: ',IL,j
if (il.le.0) then
# write(*,*) 'IL<=0: ',ISF,ILF,fname(ISF:ISF+ILF-1)
ffn=fname(isf:isf+ilf-1)
ll=ilf
else if (j.gt.0.and.fpath(j:j).ne.pathdel) then
# write(*,*) 'IL>0 && path != PATHDEL: ',is,j
ffn=fpath(is:j)//pathdel//fname(isf:isf+ilf-1)
ll=j-is+2+ilf
else
# write(*,*) 'IL>0: ',is,j
ffn=fpath(is:j)//fname(isf:isf+ilf-1)
ll=j-is+1+ilf
endif
# IF (IL.GT.0.AND.J.GT.0.AND.fpath(j:j).NE.PATHDEL) THEN
# write(*,*) 'IL>0 && path != PATHDEL: ',is,j
# FFN=fpath(is:j)//PATHDEL//fname(ISF:ISF+ILF-1)
# LL=j-is+2+ILF
# ELSE IF (IL.GT.0) THEN
# write(*,*) 'IL>0: ',is,j
# FFN=fpath(is:j)//fname(ISF:ISF+ILF-1)
# LL=j-is+1+ILF
# ELSE
# write(*,*) 'IL<=0: ',ISF,ILF,fname(ISF:ISF+ILF-1)
# FFN=fname(ISF:ISF+ILF-1)
# LL=ILF
# ENDIF
# write(*,11) IP,TRIM(FFN)
inquire(file=ffn,exist=log1)
endif
enddo
if (ll.gt.lres) ll=lres
fres=ffn(1:ll)
# write(*,11) IP,FRES(1:LEN_TRIM(FRES))
if (log1) then
ires=ip
if (isil.le.0) write(smes,5) fname(isf:isf+ilf-1),fpath(is:j)
else
ires=-1
if (isil.le.0) write(smes,3) fname(isf:isf+ilf-1)
endif
end
#-------------------------------------------------------------------------
SUBROUTINE OPENRESFILE(fname,fext,iunit,ird,isil,fres,ierr)
# Open file for input in RESTRAX, searching in following directories:
# current:DATPATH:RESPATH:CFGPATH
# INPUT:
# fname ... filename
# fext ... default extension
# iuit ... file unit number
# ird ... force user input if ird>0, even if fname is not empty
# isil ... silence level (no message if isil>0)
# OUTPUT:
# ierr ... <>0 if cannot open file
# FRES ... resulting filename without path
#-------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) fname,fext,fres
integer*4 iunit,ird,isil,ierr
integer*4 ires,is,il,is1,il1,is2,il2,is3,il3
character*256 fpath,fn,ffn
character*16 fe
#1 FORMAT(' OPENRESFILE: ',I4,' <',a,'>')
ierr=-1
call BOUNDS(fname,is,il)
call BOUNDS(respath,is1,il1)
call BOUNDS(cfgpath,is2,il2)
call BOUNDS(datpath,is3,il3)
fpath= ':'//datpath(is3:is3+il3-1)// ':'//respath(is1:is1+il1-1)//
& ':'//cfgpath(is2:is2+il2-1)
call DLG_FILEOPEN(fname(is:is+il-1),fpath,fext,ird,1,ires,ffn)
if (ires.gt.0) then
# write(*,1) ires,ffn(1:LEN_TRIM(ffn))
call FNSPLIT(ffn,pathdel,fpath,fn,fe)
call BOUNDS(fn,is1,il1)
call BOUNDS(fe,is2,il2)
if (il1.gt.0.and.il2.gt.0) then
fres=fn(is1:is1+il1-1)//fe(is2:is2+il2-1)
else if (il1.gt.0) then
fres=fn(is1:is1+il1-1)
else
fres= ' '
endif
call OPENINPFILE(ffn,iunit,isil,ierr)
endif
end
#-------------------------------------------------------------------------
SUBROUTINE OPENINPFILE(fname,iunit,isil,ierr)
# Open file FNAME for input
# INPUT:
# fname ... full filename (incl. path)
# iuit ... file unit number
# isil ... silence level (no message if isil>0)
# OUTPUT:
# ierr ... <>0 if cannot open file
# FRES ... resulting filename without path
#-------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) fname
integer*4 iunit,ierr,isil
integer*4 is,il,is1,il1,is2,il2
character*256 fpath,fn,fres
character*32 fe
call BOUNDS(fname,is,il)
200 format( ' Open file "',a, '"')
201 format( ' unexpected error in OPENINPFILE: "',a, '"')
open(unit=iunit,file=fname(is:is+il-1),status= 'OLD',
* err=10,iostat=ierr)
if(isil.le.0) then
call FNSPLIT(fname(is:is+il-1),pathdel,fpath,fn,fe)
call BOUNDS(fn,is1,il1)
call BOUNDS(fe,is2,il2)
if (il1.gt.0.and.il2.gt.0) then
fres=fn(is1:is1+il1-1)//fe(is2:is2+il2-1)
if (isil.le.0) write(sout,200) fres(is1:is1+il1+il2-1)
else if (il1.gt.0) then
fres=fn(is1:is1+il1-1)
if (isil.le.0) write(sout,200) fres(is1:is1+il1-1)
else
write(smes,201) fname(is:is+il-1)
endif
endif
10 return
end
#-------------------------------------------------------------------------
SUBROUTINE OPENOUTFILE(fname,iunit,ierr)
# Open file FNAME for output
# INPUT:
# fname ... full filename
# iuit ... file unit number
# OUTPUT:
# ierr ... <>0 if cannot open file
#-------------------------------------------------------------------------
implicit none
character*(*) fname
integer*4 iunit,ierr
ierr=-1
open(unit=iunit,file=fname,err=10,iostat=ierr,status= 'Unknown')
10 return
end
#-------------------------------------------
SUBROUTINE READ_RESCAL(iu,ierr)
# Read RESCAL parameters from unit IU (assume RESCAL format)
# IERR=2 ... error while reading file
#-------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
INCLUDE 'rescal.inc'
integer*4 iu,ierr
character*30 line
integer*4 i
real*8 ver
102 format( 'Error ',i5, ' in RESCAL file, line=',i5)
1 format(a)
ierr=0
i=1
read(iu,1,err=98,end=98,iostat=ierr) line
call READ_R8( 'version',line,ver,ierr)
if(ierr.eq.0.and.ver.ge.4.77) then ! new version
do i=1,res_nvar
read(iu,*,err=98,end=98,iostat=ierr) res_dat(i)
enddo
else ! old version, skip da3
read(line,*,err=98,end=98,iostat=ierr) res_dat(1)
do i=2,i_da3-1
read(iu,*,err=98,end=98,iostat=ierr) res_dat(i)
enddo
res_dat(i_da3)=0.
res_dat(i_da4)=0.
do i=i_da4+1,res_nvar
read(iu,*,err=98,end=98,iostat=ierr) res_dat(i)
enddo
endif
97 ierr=0
return
98 ierr=2
if (silent.le.1) write(smes,102) ierr,i
end
#---------------------------------------------------------------------------------
SUBROUTINE OPENFILE(sarg,ires)
# Procedure for loading an ILL data file or RESCAL parameters into "mf_cur" data set
# 1) Try loading RESCAL file (*.res) (ires=1 on success)
# 2) Try ILL data file (ires=2 on success)
# ires=0 if failed
# Added fo debug:
# filename starting with "channel" causes just creating spectrum data
# (with zero intensities), ires=3
#---------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
integer*4 iu
parameter(iu=24)
character*(*) sarg
character*128 name
integer*4 i,ierr,is,il,ipol,ires,ird
logical*4 CREATEFILE
real*8 dat(mres)
101 format( 'Error ',i4, ': Can' 't open file ',a)
102 format( 'Error ',i4, ': Can' 't read data in ',a, ' ! ')
103 format( 'Can' 't read data, header accepted ! ')
104 format( 'Info: MC events need to recalculate.')
201 format( 'RESCAL paramaters loaded - discards any data!')
ires=0
# write(*,*) 'SILENT=',SILENT
# Get filename from the argument SARG or from the previous value
if (sarg.eq. ' ') then
if (rescal_name.ne. ' ') then
name=rescal_name
else if (datname.ne. ' ') then
name=datname
else
name= ' '
endif
ird=1 ! interactive file-open dialog
else
name=sarg
ird=0 ! use SARG as filename
endif
call BOUNDS(name,is,il)
# special name: create empty dataset named 'channel'
if (il.ge.7.and.name(1:7).eq. 'channel') then
if (CREATEFILE(name)) ires=3
return
endif
# open the file
call OPENRESFILE(name(is:is+il-1), ' ',iu,ird,silent,name,ierr)
if (ierr.ne.0) goto 90
call BOUNDS(name,is,il)
# make a copy of RESCAL parameters
do i=1,mres
dat(i)=res_dat(i)
enddo
is=1
# RESCAL file format
if (il.gt.4.and.name(is+il-4:is+il-1).eq. '.res') then
# write(*,*) 'OPENRES: ',NAME(IS:IS+IL-1),IERR
call READ_RESCAL(iu,ierr)
close(iu)
if (ierr.eq.0) then ! success
ires=1
datname= ' '
rescal_name=name(is:is+il-1)
call DELDATA(1,mf_max) ! delete all data
mf_name(mf_cur)= ' '
call BEFORE
if (silent.le.1) write(smes,201)
return
else
goto 91
endif
else
# ILL data file
ipol=0
call READ_ILLDATA(iu,ipol,ierr) ! try ILL data format
close(iu)
if (ierr.eq.0) then ! data file, complete
datname=name(is:is+il-1)
rescal_name= ' '
ires=2
mf_active(mf_cur)=.true.
mf_loaded(mf_cur)=.true.
mf_name(mf_cur)=datname
else if (ierr.eq.2) then ! only header, no data values
if (silent.lt.2) write(smes,103)
rescal_name=name(is:is+il-1)// '.res'
datname= ' '
call DELDATA(1,mf_max) ! delete all data
mf_name(mf_cur)= ' '
call BEFORE
ires=1
return
else ! another problem with data file
goto 91
endif
call BEFORE
if (silent.le.0.and.mf_changed(mf_cur)) write(smes,104)
endif
return
# on error: restore RESCAL parameters and exit
90 if (silent.le.1) write(smes,101) ierr,name(is:is+il-1)
goto 95
91 if (silent.le.1) write(smes,102) ierr,name(is:is+il-1)
95 do i=1,mres
res_dat(i)=dat(i)
enddo
end
#-----------------------------------------------------------------------
logical*4 FUNCTION CREATEFILE(name)
# has the same effect as OPENFILE, but does not really read a file.
# All data are just copied from the current data set.
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
character*60 name
#// copy data from current data set
call CopyDatFile
datname=name
rescal_name= ' '
mf_active(mf_cur)=.true.
mf_loaded(mf_cur)=.true.
mf_name(mf_cur)=datname
CREATEFILE=.true.
end
#-----------------------------------------------------------------------
SUBROUTINE WRITE_RESCAL(sarg,ires)
# Write RESCAL parameters to a *.res file
# IRES=0 ... not saved
# IRES=1 ... saved
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
character*(*) sarg
integer*4 ires,iu
parameter(iu=24)
character*128 name
integer*4 i,l,iread,iover,ierr
2 format(a)
3 format( ' Parameters saved in "',a, '"')
4 format( ' Cannot open file for output: "',a, '"')
ires=0
iread=0
iover=0
if (sinp.eq.5) iover=1 ! overwrite prompt = on for standard input
name= ' '
l=len_trim(sarg)
if (l.gt.0) then
if (l.eq.2.and.sarg(1:2).eq. 'as') then
iread=1
name=rescal_name
else
name=sarg(1:l)
endif
else
iread=1
name=rescal_name
endif
call DLG_FILESAVE(name, ' ', 'res',iread,iover,ires,name)
if (ires.le.0) return
l=len_trim(name)
call OPENOUTFILE(name(1:l),iu,ierr)
if (ierr.ne.0) goto 99
write(iu,2) 'version=4.77'
do i=1,res_nvar
write(iu,*) res_dat(i)
enddo
close(unit=iu)
ires=1
write(smes,3) name(1:l)
rescal_name=name
return
99 write(smes,4) name(1:l)
end
#-------------------------------------------------------------------
SUBROUTINE WriteMap(outf,a,n,projx,projy,sx1,sx2,sy1,sy2,q,e)
# writes matrix to a file
#-------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
integer*4 n,i,j,ix,iy,lx,ly
real*4 a(n,n)
real*4 sx1,sx2,sy1,sy2
real*8 q(3),e
character*60 outf
character*(*) projx,projy
1 format(a)
9 format(64(1x,g10.4))
13 format( 'scale (',g12.5, ',',g12.5, ',',g12.5, ',',g12.5, ')')
104 format( 'QE = [',4(g12.5,1x), ']')
open(unit=22,file=outf,err=999,status= 'Unknown')
call BOUNDS(projx,ix,lx)
call BOUNDS(projy,iy,ly)
write(22,1,err=998)
& 'projection ('//projx(ix:ix+lx-1)// ','//projy(iy:iy+ly-1)// ')'
write(22,13,err=998) sx1,sx2,sy1,sy2
write(22,104,err=998) (q(i),i=1,3),e
do j=1,n
write(22,9,err=998) (a(i,j),i=1,n)
enddo
998 close(22)
999 continue
end
#-----------------------------------------
SUBROUTINE WriteHist(outf)
# writes results to the file "outf"
#-------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_grf.inc'
INCLUDE 'exciimp.inc'
record /MODEL/ rm
integer*4 nfit,i_io
parameter(i_io=23)
parameter(nfit=10)
character*80 cline
character*(*) outf
character*128 rname
character*5 fix,fix0,fix1
integer*4 i,j,ierr,item0,item,ibs,ib,lr,ires
real*8 qq(4),dqq(4),wq(4),da3
real*4 vq(3)
integer*4 nima,nm
parameter(nima=128)
real*4 aima(nima,nima)
real*8 xmax,ymax,xmin,ymin,a4ref,dum
character*50 s
record /VIEWSET/ port
data fix1,fix0 / ' ', 'fixed'/
1 format( ' Results filename [restrax.dat] : ',$)
2 format(a)
5 format(2x, 'Fit',i2,4x, ' ',$)
7 format( 'AMP=',e10.3,5x, 'BCG=',e10.3)
81 format( 'Nonlinear least squares & MC ray tracing: ',i9, ' events')
82 format( 'Nonlinear least squares & TRAX : ',i9, ' events')
9 format(2x,a10, ' a(',i2, ') = ',e10.4, ' +-',e8.2,
1 ' initial = ',e10.4,2x,a5)
91 format(2x,a10, ' a(',i2, ') = ',e10.4)
10 format( ' Output file: ',a30, ' Data file: ',a30)
11 format( ' QE = [',4(1x,f8.3), ']')
14 format(2x,e10.3,$)
15 format(2x,e10.3,$)
3 format( 'h',8x, 'k',8x, 'l',8x, 'E',10x, 'Fit',13x,$)
13 format(4(f8.3,1x),2x,e10.3,$)
33 format(2x, 'a3 ',$)
133 format(f8.3,2x,$)
6 format(2x, 'QH',8x, 'QK',8x, 'QL',8x, 'EN',8x, 'CNTS',6x, 'Err',$)
16 format(2x,4(f8.4,2x),f8.0,2x,f8.2,$)
66 format(7x, 'A3 ',$)
166 format(2x,f8.4,2x,$)
17 format(a80)
18 format(a)
19 format(a60)
20 format($)
lr=len_trim(outf)
if (lr.le.0) then
call DLG_FILESAVE( ' ', ' ', 'dat',1,1,ires,rname)
else
call DLG_FILESAVE(outf, ' ', 'dat',0,1,ires,rname)
endif
if (ires.le.0) goto 998
lr=min(len_trim(rname),128)
call OPENOUTFILE(rname(1:lr),i_io,ierr)
if (ierr.ne.0) goto 999
resname=rname(1:lr)
call getmodel(rm)
#* write names of dependent files:
write(i_io,10) rname, datname
#* list content of EXCI parameter file if EXCI is used
if (iand(whathis,4).eq.4) then
call OPENRESFILE(rm.phonname, 'par',2,0,2,rm.phonname,ierr)
if(ierr.eq.0) then
write(i_io,*) 'EXCI parameters from '//trim(rm.phonname)
do 30 while(ierr.eq.0)
read(2,18,iostat=ierr,err=30) cline
write(i_io,17) cline
30 continue
close(2)
endif
endif
#* Parameter values:
101 format( 'CHISQR: ',g11.5)
write(i_io,101) chisqr
if(jfit.eq.2) then ! save fitting results if available
if(swraytr.eq.0) then
write(i_io,82) nxr
else
call KSTACK_N(i,1)
write(i_io,81) i
endif
do i = 1,nfpar
if (jfixed(i).eq.1) then
fix = fix1
else
fix = fix0
endif
write(i_io,9) rm.parname(i),i,fpar(i),sigmaa(i),fpari(i),fix
enddo
else
do i = 1,nfpar
write(i_io,91) rm.parname(i),i,fpar(i)
enddo
endif
#/// START TO WRITE RESULTS FOR ALL DATA IN RHIST ....
item0=0
nm=nhist(mdat)
if (cfgmode.eq.1) nm=nhist(1) ! only 1st channel for flat-cone
do i=1,nm
item=ihist(i)
#* Write headers for each data set
if(item.ne.item0) then ! starts new dataset
item0=item
#* (Q,w) and scan step :
do j=1,4
qq(j)=mf_par(i_qh+j-1,item)
dqq(j)=mf_par(i_dqh+j-1,item)
enddo
da3=mf_par(i_da3,item)
write(i_io,*)
write(i_io,*) 'Resolution calculated at: '
write(i_io,11) (qq(j),j=1,4)
write(i_io,*)
j=index(mf_name(item), ' ')
102 format( 'CHISQR(I): ',g11.5, ' data: ',a)
write(i_io,102) dchisq(item), mf_name(item)(1:j)
#* Table header :
if (da3.gt.0) write(i_io,33)
write(i_io,3)
if (rm.nbr.gt.1) then
do j=1,rm.nbr
write(i_io,5) j
end do
endif
if(npt(item).gt.npt(item-1)) then
if (da3.gt.0) write(i_io,66)
write(i_io,6)
endif
ibs=npt(item-1)+1 ! base index for SPX etc..
ib=nhist(item-1)+1 ! base index for RHIST etc..
write(i_io,*)
endif
#* Result table:
if (da3.gt.0) then
do j=1,3
vq(j)=mf_par(i_qh+j-1,item)
enddo
call ROTA3(vq,xhist(i)*da3,wq)
wq(4)= mf_par(i_en,item)+xhist(i)*mf_par(i_den,item)
else
do j=1,4
wq(j)=mf_par(i_qh+j-1,item)+xhist(i)*mf_par(i_dqh+j-1,item)
enddo
endif
if (da3.gt.0) write(i_io,133) xhist(i)*da3
write(i_io,13) (wq(j),j=1,4),rhist(i)
if (rm.nbr.gt.1) then
do j=1,rm.nbr
write(i_io,15) fpar(1)*dhist(j,i)*hnorm(item)/sumamc(item)
end do
endif
if(npt(item).gt.npt(item-1).and.i-ib.le.npt(item)-ibs) then
if (da3.gt.0) then
do j=1,3
vq(j)=qq(j)
enddo
call ROTA3(vq,spx(i-ib+ibs)*da3,wq)
wq(4)= spx(i-ib+ibs)*dqq(4)+qq(4)
else
do j=1,4
wq(j)=spx(i-ib+ibs)*dqq(j)+qq(j)
enddo
endif
if (da3.gt.0) write(i_io,166) spx(i-ib+ibs)*da3
write(i_io,16) (wq(j),j=1,4),spy(i-ib+ibs),spz(i-ib+ibs)
endif
write(i_io,*)
enddo
#/// add matrix with flat-cone scan:
if (cfgmode.eq.1) then
call GET_A3A4(1,mf_par(i_qh,1),dum,a4ref,i)
210 format(72( '-'))
write(i_io,210)
211 format( 'FLAT_CONE scan: a4=',g12.6, 'da3=',g12.6, 'da4=',g12.6)
write(i_io,211) a4ref/deg,mf_par(i_da3,1),mf_par(i_da4,1)
call FCONE_RANGE(xmin,xmax,ymin,ymax,.true.)
port.wx1=xmin
port.wx2=xmax
port.wy1=ymin
port.wy2=ymax
port.ix=1
port.iy=2
call FILL_FCONE(port,aima,nima,nima,1) ! 1 .. from RHIST
call FORMAT_HKL(mf_par(i_ax,1),s,50)
write(i_io,*) 'X-axis :',s
call FORMAT_HKL(mf_par(i_bx,1),s,50)
write(i_io,*) 'Y-axis :',s
213 format( 'range (XxY) (',g10.4, ',',g10.4, ')x(',g10.4, ',',g10.4, ')')
214 format(128(1x,g10.4))
write(i_io,213) xmin,xmax,ymin,ymax
do j=1,nima
write(i_io,214) (aima(i,j),i=1,nima)
enddo
endif
close(i_io)
return
998 write(smes,*) 'Data not saved '
return
999 write(smes,*) 'Cannot save to file '//rname(1:lr)
return
end
#-------------------------------------------------------------------------------------------------
SUBROUTINE ReadHeader(io,ili,colhd,datline,ires)
# Read data file header
# parameters are identified by their names (in capital letters) followed by = ,
# e.g. DM = 3.135
# The parameter names = those listed by the LIST command with an exception for step names
#
# End of the header:
# (a) line starts with the 'DATA_:' string - ILL data format (IRES=1)
# (b) line starts with three nummbers - three-column format (IRES=2)
# (c) the end of file is reached - no data section found (IRES=0)
# (d) error has occured while reading a line (IRES=-1)
#
# Returns:
# ires ... result indicator (see above)
# ili ... number of lineas read
# UsePar(i) ... bolean array to indicate which parameters where found
# ValPar(i) ... parameter values (only those for UsePar(i)=.true.)
# datahd ... assumed string with header to data columns
# cun ... energy unit=THz if cun='T', otherwise meV
#-------------------------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'res_rdf.inc'
integer*4 io,ili,ires
character*256 colhd,datline
1 format(a)
#// local variables
character*32 cpar
character*256 cline
integer*4 i,ios,is,il,ierr
logical*4 log1
real*8 vals(3),z
#// define variables identificators, equal to the RES_NAM(i) array ....
do i=1,res_nvar
respar(i)=res_nam(i)
enddo
#// with some exceptions ....
respar(i_dqh)= 'QH'
respar(i_dqk)= 'QK'
respar(i_dql)= 'QL'
respar(i_den)= 'EN'
respar(i_da3)= 'A3'
respar(i_da4)= 'A4'
#// intialize variables, set default results
cun= 'm'
title= 'not found'
comnd= 'not found'
ios=0 ! io-error status
do i=1,res_nvar
usepar(i)=.false.
end do
ires=0 ! rILL format (1), 3-column format (2), not found(0), error (-1)
ili=0 ! line counter
colhd= ' '
datline= ' '
#// start analyzing the file line by line
#// Set UsePar(i)=true if i-th parameter has been read
do while ((ios.eq.0).and.(ires.eq.0))
10 ili=ili+1
read(io,1,iostat=ios,err=110,end=100) cline
# write(*,*) 'line: ',ili,CLine(1:20)
log1=.false.
#// ignore certain lines
log1=(log1.or.cline(1:6).eq. 'VARIA:')
log1=(log1.or.cline(1:6).eq. 'FORMT:')
log1=(log1.or.cline(1:6).eq. 'ZEROS:')
if (log1) goto 10
#// identify title and command line , just echo the contents
call BOUNDS(cline,is,il)
log1=(cline(1:6).eq. 'TITLE:')
if (log1) title=cline(7:il)
if (log1) goto 10
log1=(cline(1:6).eq. 'COMND:')
if (log1) comnd=cline(7:il)
if (log1) goto 10
#// check for the start of data section
call SpaceDel(cline) ! replace delimiters with spaces
#// ILL format?
if (ires.eq.0) then
i=index(cline, 'DATA_:')
if (i.eq.1) then ! ILL format found
ires=1
do while (index(cline, 'CNTS').eq.0) ! continue up to a table header
read(io,1,iostat=ios,err=110,end=100) cline
ili=ili+1
call SpaceDel(cline)
enddo
colhd=cline
read(io,1,iostat=ios,err=110,end=100) cline ! read the first line with data values
ili=ili+1
call SpaceDel(cline)
datline=cline
return
endif
endif
#// 3-column format?
if (ires.eq.0) then
read(cline,*,err=20) (vals(i),i=1,3)
if (index(cline, '.').le.0) goto 20 ! MUST CONTAIN AT LEAST ONE DOT !!!
datline=cline
ires=2 ! 3-column format found
return
endif
20 colhd=cline ! this might have been the table header, save it for the next loop
#/// search for step values, only in STEPS: fields:
log1=(cline(1:6).eq. 'STEPS:')
if(log1) then
do i=i_dqh,i_da4
if(.not.usepar(i)) then
valpar(i)=0.d0
usepar(i)=.true.
call BOUNDS(respar(i),is,il)
call READ_R8(respar(i)(is:is+il-1),cline,z,ierr)
if (ierr.eq.0) then
valpar(i)=z
else ! try also DQH,DQK ... old data format version
call READ_R8( 'D'//respar(i)(is:is+il-1),cline,z,ierr)
if (ierr.eq.0) valpar(i)=z
endif
endif
enddo
endif
#/// search for position values, only in POSQE: fields:
log1=(cline(1:6).eq. 'POSQE:')
if(log1) then
do i=i_qh,i_en
if(.not.usepar(i)) then
call BOUNDS(respar(i),is,il)
call READ_R8(respar(i)(is:is+il-1),cline,z,ierr)
if (ierr.eq.0) then
valpar(i)=z
usepar(i)=.true.
endif
endif
enddo
endif
if (log1) goto 10
#/// read unit name
call READ_STR( 'UN',cline,cpar,ierr)
if (ierr.eq.0) then
cun=cpar(1:1)
endif
#/// search for other parameters identified as RES_NAM(i)
do i=1,res_nvar
if(.not.usepar(i)) then
call BOUNDS(res_nam(i),is,il)
call READ_R8(res_nam(i)(is:is+il),cline,z,ierr)
if (ierr.eq.0) then
# write(*,*) CLINE(1:72)
valpar(i)=z
usepar(i)=.true.
# write(*,*) 'READHEADER: ',ili,' ',res_nam(i)(IS:IS+IL),
# & '=',ValPar(i)
endif
endif
enddo
#// Set DH..DE zero for scans in A3
if (usepar(i_da3).and.valpar(i_da3).ne.0) then
do i=i_dqh,i_den
usepar(i)=.true.
valpar(i)=0.
enddo
endif
100 continue
enddo
return
110 ires=-1
end
#-------------------------------------------------------------------------------------------------
SUBROUTINE INDEXHEADER(line,ind,nind,ncol,maxcol)
# Index items in a table header using ColID identifiers from res_rdf.inc
# Consider only the columns range 1..CNTS
# LINE ... table header
# IND(i) ... column number of the identifier ColID(i) (=0 if not present)
# ncol ... number of indexed items in the header
# maxcol ... max. column number = MAX(ind(i)) <=32
#-------------------------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'res_rdf.inc'
character*(*) line
integer*4 nind,ind(nind),ncol,maxcol,i1,l1,i2,l2,j,ll
integer*4 TRUELEN
maxcol=0
ncol=0
do j=1,nind
ind(j)=0
end do
l1=1
ll=TRUELEN(line)
if (ll.le.0) goto 99 ! empty line
do while (l1.gt.0.and.ind(c_cnts).eq.0)
i1=1
maxcol=maxcol+1
call FINDPAR(line(1:ll),maxcol,i1,l1)
if (l1.gt.0) then
do j=1,nind
if (ind(j).eq.0) then
call BOUNDS(colid(j),i2,l2)
if (line(i1:i1+l1-1).eq.colid(j)(i2:i2+l2-1)) then
ind(j)=maxcol
ncol=ncol+1
endif
endif
enddo
endif
enddo
#// get maxcol = max. column number to be read (<=32)
maxcol=ind(1)
do j=2,c_max
maxcol=max(maxcol,ind(j))
enddo
maxcol=min(maxcol,32)
99 continue
end
#-------------------------------------------------------------------------------------------------
SUBROUTINE READ_ILLDATA(i_io,ipol,ierr)
# Subroutine for reading parameters from data files. New (UNIX) ILL format is accepted.
#
# IPOL ... polarization loop (MUST BE A WRITABLE PARAMETER !)
# if IPOL=0, procedure would ask for the No. of polarization loop and return its value in IPOL
# otherwise use this value. POL column is used to identify polarization loop index
#
# Actual format restrictions are rather relaxed. The rules are:
# 1) Data section must start with a line containing 'DATA_', followed by another
# line with column names
# 2) Meaning of variables is taken from column names (e.g. EN for energy transfer, etc...)
# 3) The file must contain at least one monotonously varying variable (QH,QK,QL or EN) +
# PNT (point index) and CNTS (counts) columns
# 4) OPTIONALLY, parameters of instrument setting can be read from the file header,
# if they are identified by their names (in capital letters) followed by = (e.g. DM = 3.135)
#---------------------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
INCLUDE 'res_rdf.inc'
integer*4 i_io,i_mv,ilines,ipol,ipmax
real*4 spec(c_max,mhis),x(0:32),spx0
character*256 cline,colhd
real*4 dxx(nhi*mdat),xx(nhi*mdat),yy(nhi*mdat),zz(nhi*mdat),qi(3)
integer*4 np,npold,ii(nhi*mdat),ierr,i,ios
integer*4 i_col,j,ib,ihead,l,k,TRUELEN
real*8 dd,x0
logical*4 moves
integer*4 ind(c_max),ncol ! index to columns with QH,QK,... in the data section
integer*4 idbg
data idbg/0/ ! for debug purposes - set IDBG>0 to see debug messages
save x,ind
1 format(a)
202 format( ' ',a,a)
203 format( ' ',a,i6)
204 format(i3,2x,10(g10.4,1x))
205 format(a,2x,10(g10.4,1x))
# 206 FORMAT(a,2x,10(a,1x))
207 format( ' ', '3-column data format: ',a5, ' INT STDEV ')
208 format( ' ', 'ILL data format')
209 format( ' ', 'STEP :',$)
210 format(1x,a3,g10.3,$)
211 format( ' ', 'QHKLE:',4(1x,a3,g10.3))
# 215 FORMAT(' ',a)
216 format( ' ', 'POSQE:',$)
217 format(a5, ' ',$)
218 format(g10.4, ' ',$)
idbg=0
# some initializations
# make a local copy of RES_DAT array in ValPar
do i=1,res_nvar
valpar(i)=res_dat(i)
enddo
do j=1,mhis
do i=1,c_max
spec(i,j)=0.d0
enddo
enddo
ios=0
np=0
ncol=0
i_mv=0
#/// **** READ DATA HEADER ****
ierr=1
call ReadHeader(i_io,ilines,colhd,cline,ihead)
if (idbg) write(*,*) 'header OK: ',ihead,ilines
if (idbg) write(*,*) colhd(1:60)
if (idbg) write(*,*) cline(1:60)
if (idbg) then
write(sout,209)
do i=i_dqh,i_da4
if (usepar(i)) write(sout,210) res_nam(i),valpar(i)
enddo
write(sout,*)
write(sout,216)
do i=i_qh,i_en
if (usepar(i)) write(sout,210) res_nam(i),valpar(i)
enddo
write(sout,*)
endif
#/// ReadHeader should have provided the table header (colhd) + the 1st row (CLine)
#/// analyze the result
if (ihead.lt.0) goto 199 ! error in header => return with ierr=1
ierr=2 ! at least the file header was found
if (ihead.eq.0) goto 180 ! no data section => skip to the epilog
#/// **** INTERPRET TABLE HEADER ****
call INDEXHEADER(colhd,ind,c_max,ncol,i_col)
# if (idbg) write(*,*) 'table header: ',(ind(i),i=1,c_max)
#// 3-column format
#// ===============
#// Use the 1-st column as x-variable.
if (ihead.eq.2) then
j=0
if (i_col.le.0) then ! no table header => use ValPar
j=0
do i=c_qh,c_a3
if (valpar(i-c_qh+i_dqh).ne.0.) then
j=j+1
i_mv=i
endif
enddo
else ! identify the first column
do i=c_qh,c_a3
if (ind(i).eq.1) i_mv=i
enddo
endif
if (i_mv.le.0.or.j.gt.1) goto 198 ! cannot identify scan variable
ind(i_mv)=1
ind(c_cnts)=2
ind(c_err)=3
i_col=3
ipol=0
goto 200
endif
#// ILL format
#// ===============
#// Data MUST contain 'PNT' and 'CNTS' columns and at least one column with a variable
if ((ind(c_pnt).eq.0).or.
& (ind(c_cnts).eq.0).or.
& (ncol.lt.3)) goto 170
#// Check for polarization analysis loop.
#// This section ends with the 2nd data row in CLine.
#// 1) Find number of pol. loops, if any
#// 2) Select, which one to read
j=1
if (ind(c_pal).gt.0) then
ipmax=0
do while( j.eq.1)
read(cline,*,iostat=ios,err=170) (x(i),i=1,i_col)
j=nint(x(ind(c_pnt))) ! get actual PNT index
if (j.eq.1) then
k=nint(x(ind(c_pal)))
if (ipmax.lt.k) ipmax=k
do i=1,c_max
if(ind(i).gt.0) spec(i,k)=x(ind(i))
end do
if (idbg) write(*,204) j,(x(i),i=1,i_col)
140 read(i_io,1,iostat=ios,err=170,end=170) cline
if (cline(1:1).eq. '#') goto 140
endif
enddo
if (ipol.le.0.or.ipol.gt.ipmax) then ! ask for the loop number to be read
call DLG_INTEGER( 'Polarization Analysis Loop',ipol,0,1,ipmax)
endif
do i=1,c_max
if(ind(i).gt.0) spec(i,1)=spec(i,ipol)
end do
else ! Suppose there are NO loops
read(cline,*,iostat=ios,err=170) (x(i),i=1,i_col)
do i=1,c_max
if(ind(i).gt.0) spec(i,j)=x(ind(i))
end do
150 read(i_io,1,iostat=ios,err=170,end=170) cline ! read also the 2nd line !!
if (cline(1:1).eq. '#') goto 150
endif
np=1 ! one row has been read
#// Common to both formats:
#// READ REMAINING LINES
200 do while((ios.eq.0).and.(np.lt.nhi*4).and.np.lt.mhis)
read(cline,*,iostat=ios,err=170) (x(i),i=1,i_col) ! read values from CLine
if (idbg) write(*,204) np,(x(i),i=1,2)
if (ipol.le.0.or.nint(x(ind(c_pal))).eq.ipol) then ! select only required IPOL
np=np+1
do i=1,c_max
if(ind(i).gt.0) spec(i,np)=x(ind(i))
end do
if (idbg) write(*,204) np,(x(i),i=1,i_col)
endif
160 read(i_io,1,iostat=ios,err=199,end=170) cline ! read another CLine from IO
ilines=ilines+1
if (cline(1:1).eq. '#') goto 160 ! ignore comments
enddo
170 continue
#------------------------------------------------------------------
# ***** Data read finished, file closed. *****
#------------------------------------------------------------------
if (idbg) write(*,*) 'data OK: ',np
#// correct QH..QL, because POSQE gives the 1st point, not the middle !!
do i=c_qh,c_en
if (usepar(i-c_qh+i_dqh).and.usepar(i-c_qh+i_qh)) then
dd=valpar(i-c_qh+i_dqh)
if (dd.ne.0) then
valpar(i-c_qh+i_qh)=valpar(i-c_qh+i_qh)+dd*(np-1.d0)/2.d0
endif
endif
enddo
# Find the first monotonously varying parameter from QH..EN,A3
# Corresponding column must be on the left from CNTS!
if (np.lt.2) goto 180 ! must have at least 2 data points
#// Try steps in QHKL,E
do i=c_qh,c_en
if (ind(i).ne.0.and.(ind(i).lt.ind(c_cnts))) then
dd=spec(i,2)-spec(i,1)
moves=.true. ! test if the variable varies monotonously
j=2
do while (moves.and.(j.lt.np))
moves=(moves.and.(spec(i,j+1)-spec(i,j))*dd.gt.0.d0)
j=j+1
end do
if (moves) then
valpar(i-c_qh+i_qh)= (spec(i,np)+spec(i,1))/2 ! scan center
valpar(i-c_qh+i_dqh)=(spec(i,np)-spec(i,1))/(np-1) ! average scan step
if (.not.usepar(i-c_qh+i_dqh)) usepar(i-c_qh+i_dqh)=.true.
if (idbg) write(*,*) 'moves along ',colid(i),valpar(i-c_qh+i_dqh)
if (i_mv.eq.0) i_mv=i ! get index for the first varying parameter
endif
endif
end do
#// Try steps in A3 if there is no step in QHKLE
i=c_a3
if (i_mv.eq.0.and.ind(i).gt.0.and.(ind(i).lt.ind(c_cnts))) then
dd=spec(i,2)-spec(i,1)
moves=.true. ! test if the variable varies monotonously
j=2
do while (moves.and.(j.lt.np))
moves=(moves.and.(spec(i,j+1)-spec(i,j))*dd.gt.0.d0)
j=j+1
end do
if (moves) then
valpar(i_da3)=(spec(i,np)-spec(i,1))/(np-1)
if (idbg) write(*,*) 'moves along ',colid(i),valpar(i-c_qh+i_dqh)
if (.not.usepar(i_da3)) usepar(i_da3)=.true.
i_mv=c_a3
endif
endif
# set ierr=0 if everything is OK
if (i_mv.gt.0) ierr=0 ! there MUST be at least one varying parameter
# from now on, the data are correctly read and the RESCAL fields can be updated:
#-----------------------------------------------------------------------------
#// convert energy to meV if needed
180 if (cun.eq. 'T') then
call UNITS(cun) ! set EUNI for conversion THz->meV
if (usepar(i_en)) valpar(i_en)=valpar(i_en)/euni
if (usepar(i_den)) valpar(i_den)=valpar(i_den)/euni
if (usepar(i_gmod)) valpar(i_gmod)=valpar(i_gmod)/euni
if (i_mv.eq.c_en) then
do i=1,np
spec(i_mv,i)=spec(i_mv,i)/euni
enddo
endif
call UNITS( 'm') ! set EUNI back to 1
endif
#// copy modified parameters to the RES_DAT array
do i=1,res_nvar
if (usepar(i)) res_dat(i)=valpar(i)
enddo
#// update dependent fields
call RECLAT ! compute reciprocal lattice parameters and matrices
call SCATTRIANGLE ! compute and check KI,KF,Q and tras. matrix Lab -> CN
if (ierr.eq.2) goto 299 ! no data, but header was read
# for A3 scan: adjust QH,QK,QL, because POSQE gives the position at the 1st scan step !
if (i_mv.eq.c_a3.and.np.gt.1) then
if (usepar(i_qh).and.usepar(i_qk).and.usepar(i_ql)) then
do j=1,3
qi(j)=res_dat(i_qh+j-1)
enddo
if (idbg) write(*,205) 'center from: ',qi
call ROTA3(qi,res_dat(i_da3)*(np-1.d0)/2.d0,res_dat(i_qh))
if (idbg) write(*,205) 'center to: ',(res_dat(i_qh+j-1),j=1,4)
endif
endif
#/// *** write new values to DSPX,SPX,SPY,SPZ arrays: ****
#/// DSPX(i) contains the missfits with respect to equidistant points.
#/// SPX(i) contains row numbers + DSPX(i), but is modified later to account for
#/// differences in the scan size and spectrometer position (QHKL, E)
#-----------------------------------------------------------------------------
#* first make a copy of the stack at and above the current data:
ib=npt(mf_cur-1)+1 ! base index
do i=ib,npt(mdat)
dxx(i)=dspx(i)
xx(i)=spx(i)
yy(i)=spy(i)
zz(i)=spz(i)
ii(i)=ipt(i)
end do
npold=npt(mf_cur)-npt(mf_cur-1)
#* write new data to SPX
if (i_mv.le.c_en) then
spx0=res_dat(i_qh+i_mv-c_qh)
else
spx0=(spec(i_mv,np)+spec(i_mv,1))/2.d0
endif
spx0=spx0/res_dat(i_dqh+i_mv-c_qh) ! scan center in step units
do i=1,np
spx(i+ib-1)=spec(i_mv,i)/res_dat(i_dqh+i_mv-c_qh)-spx0
dspx(i+ib-1)=spx(i+ib-1)-(i-1-(np-1)/2.)
spy(i+ib-1)=spec(c_cnts,i)
if (ihead.eq.2) then ! 3-column format
spz(i+ib-1)=spec(c_err,i)
else if (spy(i+ib-1).le.0) then
spz(i+ib-1)=1.
else
spz(i+ib-1)=sqrt(spy(i))
endif
ipt(i+ib-1)=mf_cur
end do
#* repartition the SPX,... arrays
do i=mf_cur,mdat
npt(i)=npt(i)+np-npold
end do
#* put the rest on top:
do i=npt(mf_cur)+1,npt(mdat)
dspx(i)=dxx(i-np+npold)
spx(i)=xx(i-np+npold)
spy(i)=yy(i-np+npold)
spz(i)=zz(i-np+npold)
ipt(i)=ii(i-np+npold)
end do
#* store new reference values for the scan step and position
#* corrsponding to the current data set
do i=1,4
qe0(i,mf_cur)=res_dat(i_qh+i-1)
dqe0(i,mf_cur)=res_dat(i_dqh+i-1)
enddo
do i=5,6 ! DQE0(5..6) are the steps in A3 and A4
dqe0(i,mf_cur)=res_dat(i_dqh+i-1)
enddo
#/// set defaults if necessary
#-------------------------------------------------------------
299 continue
# set gradient of the dispersion surface
if(.not.(usepar(i_gh).and.usepar(i_gk).and.usepar(i_gl))) then
if (abs(dqe0(1,mf_cur))+abs(dqe0(2,mf_cur))+
* abs(dqe0(3,mf_cur)).gt.0) then ! scan is in Qhkl
res_dat(i_gh)=res_dat(i_dqh)
res_dat(i_gk)=res_dat(i_dqk)
res_dat(i_gl)=res_dat(i_dql)
else
res_dat(i_gh)=res_dat(i_ax) ! scan Qhkl=const.
res_dat(i_gk)=res_dat(i_ay)
res_dat(i_gl)=res_dat(i_az)
endif
endif
# set sample size
if(res_dat(i_sdi).le.1.d-6) res_dat(i_sdi)=1.d0
if(res_dat(i_shi).le.1.d-6) res_dat(i_shi)=1.d0
# set horizontal crystal curvature for perfect crystals
if(abs(res_dat(i_romh)).le.1.d-6.and.res_dat(i_etam).le.sec) then
res_dat(i_romh)=1.d-1
endif
if(abs(res_dat(i_roah)).le.1.d-6.and.res_dat(i_etaa).le.sec) then
res_dat(i_roah)=1.d-1
endif
#/// print additional information about data
if (silent.le.1) then
# write(smes,*) ' OK'
l=TRUELEN(title)
if (l.gt.0) write(sout,202) 'TITLE: ',title(1:l)
l=TRUELEN(comnd)
if (l.gt.0) write(sout,202) 'COMND: ',comnd(1:l)
write(sout,203) 'No. of data points : ',np
if (ihead.eq.2) then
write(sout,207) colid(i_mv)
else
write(sout,208)
endif
write(sout,211) ((res_nam(i),res_dat(i)),i=i_qh,i_en)
write(sout,209)
if (res_dat(i_da3).ne.0) then
write(sout,210) res_nam(i_da3),res_dat(i_da3)
else
do i=i_dqh,i_da4
if (res_dat(i).ne.0) write(sout,210) res_nam(i),res_dat(i)
enddo
endif
write(sout,*)
endif
# idbg=1
if (idbg) then ! print the data table
write(*,217) colid(c_pnt)
do i=c_qh,c_a3
dd=dqe0(i-c_qh+1,mf_cur)
if (dd.ne.0) write(*,217) colid(i)
enddo
write(*,217) colid(c_cnts)
write(*,217) colid(c_err)
write(*,*)
do j=npt(mf_cur-1)+1,npt(mf_cur)
write(*,218) spx(j)
do i=c_qh,c_a3
dd=dqe0(i-c_qh+1,mf_cur)
x0=0
if (i.lt.c_a3) x0=qe0(i-c_qh+1,mf_cur)
if (dd.ne.0) write(*,218) spx(j)*dd+x0
enddo
write(*,218) spy(j)
write(*,218) spz(j)
write(*,*)
enddo
endif
call ANGSCAN(res_dat(i_da3),0.d0) ! scan in DA3 => adjust DH,DK,DL and set DE=0
return
198 ierr=1
close(i_io) ! No spectrum read
if (silent.le.2) write(sout,*) 'cannot determine scan step'
return
199 ierr=1
close(i_io) ! No spectrum read
if (silent.le.2) write(sout,*) 'not a regular data file'
return
end
#-----------------------------------------------------------------------
SUBROUTINE CopyDatFile
# As ReadDatFile, but doesn't read the file, only inserts a new data set
# before the current one with the same data
# QHKL and scan steps are taken from the RES_DAT() field
#-----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
real*4 dxx(nhi*mdat),xx(nhi*mdat),yy(nhi*mdat),zz(nhi*mdat)
integer*4 np,npold,i,ii(nhi*mdat),ib
# NP=NPT(mf_cur)-NPT(mf_cur-1) ! get number of points from curret data set
# IF (NP.EQ.0) NP=91 ! if there are no data, set NP=91
np=91
#* first make a copy of the stack at and above the current data:
ib=npt(mf_cur-1)+1 ! base index to current data
do i=ib,npt(mdat)
dxx(i)=dspx(i)
xx(i)=spx(i)
yy(i)=spy(i)
zz(i)=spz(i)
ii(i)=ipt(i)
end do
#* repartition the SPX,... arrays
npold=npt(mf_cur)-npt(mf_cur-1)
# write(*,10) 'cur, NPOLD, NP',mf_cur,NPOLD,NP
do i=mf_cur,mdat
# write(*,10) 'NP partition: ',i, NPT(I),NPT(I)+NP-NPOLD
npt(i)=npt(i)+np-npold
end do
#* fill spectrum:
if (np.ne.npold) then
do i=1,np
spx(i+ib-1)=i-(np+1)/2
dspx(i+ib-1)=0.
spy(i+ib-1)=0.
spz(i+ib-1)=1
ipt(i+ib-1)=mf_cur
end do
endif
#* put the rest on top:
do i=npt(mf_cur)+1,npt(mdat)
dspx(i)=dxx(i-np+npold)
spx(i)=xx(i-np+npold)
spy(i)=yy(i-np+npold)
spz(i)=zz(i-np+npold)
ipt(i)=ii(i-np+npold)
end do
#* store new reference values for the scan step and position
#* corresponding to the current data set
do i=1,4
qe0(i,mf_cur)=res_dat(i_qh+i-1)
dqe0(i,mf_cur)=res_dat(i_dqh+i-1)
enddo
do i=5,6 ! DQE0(5..6) are the steps in A3 and A4
dqe0(i,mf_cur)=res_dat(i_dqh+i-1)
enddo
#10 format(a,3(' ',I),4(1x,G12.6))
# write(*,*) 'RDF: ',mf_cur,NP,NPT(mf_cur)-NPT(mf_cur-1),
# & (QE0(I,mf_cur),I=1,4)
# pause
end
#------------------------------------------------------------------
SUBROUTINE SpaceDel(cline)
# writes spaces instead of other delimiters (, ; TAB NULL)
#------------------------------------------------------------------
implicit none
integer*4 ip,ip1,l
character*(*) cline
l=len(cline)
ip1=1
ip=1
do while (ip1.ne.0)
ip1=index(cline(ip:), ';')
if (ip1.eq.0) ip1=index(cline(ip:), ',')
if (ip1.eq.0) ip1=index(cline(ip:), ' ')
if (ip1.eq.0) ip1=index(cline(ip:),char(0))
if(ip1.ne.0) then
cline(ip1+ip-1:ip1+ip-1)= ' '
ip=ip+ip1
endif
enddo
end
#------------------------------------------------------------------
SUBROUTINE ILLNameParse(namefile,icom)
# if NameFile is an integer, convert it to ILL data filename
#------------------------------------------------------------------
implicit none
integer*4 i,n,icom,ios
integer*4 is,il
character*(*) namefile
character*128 cstr,nfile
1 format(i5)
3 format(i7)
call BOUNDS(namefile,is,il)
if(il.ge.1) then
nfile=namefile(is:is+il-1)// ' '
read(nfile,*,iostat=ios) n
if((ios.eq.0).and.(n.gt.0).and.(n.lt.100000)) then ! name is a positive integer
# write(*,*) n
if(icom.eq.0) then ! ILL name - old VMS format
write(cstr,1,iostat=ios) n
if(n.lt.10) then
namefile= 'sv000'//cstr(5:5)// '.scn '
else if(n.lt.100) then
namefile= 'sv00'//cstr(4:5)// '.scn '
else if(n.lt.1000) then
namefile= 'sv0'//cstr(3:5)// '.scn '
else
namefile= 'sv'//cstr(2:5)// '.scn '
endif
else if(icom.eq.1) then ! ILL name - Unix
write(cstr,3,iostat=ios) n
do i=1,7
if(cstr(i:i).eq. ' ') cstr(i:i)= '0'
end do
namefile=cstr(2:7)// ' '
endif
else
# write(*,*) NameFile(IS:IS+IL-1)//'.'
endif
endif
end
#----------------------------------------------------------------------
SUBROUTINE GetXSpec
# correct the spectrum x-scale if the scan parameters
# differ from the RESTRAX setting DH,DK,DL,DE
# (Takes projection on the DH,DK,DL,DE direction)
# J.S., June 1997,1999
# SPX(I)*DE + EN must give correct data points (etc. for QH,QK,QL)
# mod. by J.S., Sept 2002
#----------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
INCLUDE 'restrax.inc'
integer*4 i,np,ibase
real*8 dqr(3),dq0(3),z,en,de
real*8 dstep,fstep,fstep1,zctr,snorm,snorm0
real*8 QxQ
1 format(a8,4(1x,g10.4))
if(res_dat(i_da3).eq.0) then ! only for a linear QHKLE scan
if(npt(mf_cur).gt.npt(mf_cur-1)) then
en=res_dat(i_en)
de=res_dat(i_den)
do i=1,3
dq0(i)= dqe0(i,mf_cur)
dqr(i)=qe0(i,mf_cur)-qhkl(i) ! relative shift btw. spectrum
end do ! and nominal setting is calculated
snorm=QxQ(delq,delq)+de**2
snorm0=QxQ(dq0,dq0)+dqe0(4,mf_cur)**2
# scan centre missfit
dstep=(QxQ(dqr,delq)+(qe0(4,mf_cur)-en)*de)/snorm
# scan step projected on DH,DK,DL,DE
z=QxQ(dq0,delq)
fstep=(z+dqe0(4,mf_cur)*de)/snorm
fstep1=(z+dqe0(4,mf_cur)*de)/sqrt(snorm*snorm0)
np=npt(mf_cur)-npt(mf_cur-1)
ibase=npt(mf_cur-1)+1
zctr=(np-1)/2.
#// correct the spectrum x-scale if the scan parameters are different
do i=ibase,npt(mf_cur)
spx(i)=(i-ibase-zctr+dspx(i))*fstep+dstep
enddo
# warning if scan directions in data and RESTRAX differ
# IF (ABS(1.D0-FSTEP1).GT.0.01.AND.RES_DAT(i_DA3).EQ.0) THEN
if (abs(1.d0-fstep1).gt.0.01) then
write(smes,*)
* 'Warning! INCONSISTENT SCAN DIRECTIONS in data ',mf_cur
write(smes,1) 'Data: ',(dq0(i),i=1,3),dqe0(4,mf_cur)
write(smes,1) 'Calc: ',(delq(i),i=1,3),de
endif
endif
endif
end