Source module last modified on Sat, 21 May 2005, 18:37;
HTML image of Fortran source automatically generated by
for2html on Mon, 23 May 2005, 21:29.
#//////////////////////////////////////////////////////////////////////
#////
#//// R E S T R A X 4.1
#////
#//// Some subroutines for I/O operations:
#////
#////
#//////////////////////////////////////////////////////////////////////
#--------------------------------------------------
SUBROUTINE CHECKRESFILE(fname,ires,fres,isil)
# Test existence of a file for input in RESTRAX
# return:
# IRES=1 ... current directory
# IRES=2 ... RESPATH/NAME
# IRES=3 ... CFGPATH/NAME
# IRES=-1 ... not found
# FRES ... resulting filename (incl. path), does not check length !
# ISIL ... silence level
#--------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
integer*4 ires,is,il,is1,il1,isil,is2,il2
logical*4 log1
character*(*) fname
character*128 fn,ffn,cfn,fres
ires=-1
call BOUNDS(fname,is,il)
call BOUNDS(respath,is1,il1)
call BOUNDS(cfgpath,is2,il2)
fn=fname(is:is+il-1)
ffn=respath(is1:is1+il1-1)//fname(is:is+il-1)
cfn=cfgpath(is2:is2+il2-1)//fname(is:is+il-1)
is1=1
il1=il+il1
is2=1
il2=il+il2
#// Try the current directory first
inquire(file=fn,exist=log1)
if(log1) then
ires=1
fres=fn
return
endif
#// Otherwise try RESPATH directory
# write(*,*) FFN
inquire(file=ffn,exist=log1)
if(log1) then
ires=2
fres=ffn
return
endif
#// Otherwise try CFGPATH directory
# write(*,*) CFN
inquire(file=cfn,exist=log1)
if(log1) then
ires=3
fres=cfn
return
endif
if(isil.lt.2)
* write(smes,*) 'Cannot find file for input: ',fn(is:is+il-1)
return
end
#--------------------------------------------------
SUBROUTINE OPENRESFILE(fname,iunit,ires,isil)
# Open file for input in RESTRAX
# returns IRES>0 if open, otherwise IRES<0
#--------------------------------------------------
implicit none
integer*4 iunit,ires,isil,ierr
character*(*) fname
character*128 fn
call CHECKRESFILE(fname,ires,fn,isil)
if (ires.gt.0) then
# write(*,*) IRES,FN(1:60)
open(unit=iunit,file=fn,status= 'OLD',err=10,iostat=ierr)
endif
return
10 ires=-ierr
end
#-------------------------------------------
SUBROUTINE READ_RESCAL(name,ires)
# Read RESCAL parameters from a *.res file
# IRES>0 ... read OK (=value returned by OPENRESFILE)
# IRES=-1 ... cannot open RESCAL file
# IRES<=-2 ... error while reading file
#-------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
integer*4 iu,ires
parameter(iu=24)
character*60 name,line,fn
integer*4 i,ierr,is,il,l
real*8 dat(mres),ver
102 format( 'Error ',i5, ' in RESCAL file, line=',i5)
1 format(a)
ierr=0
is=1
l=len(name)
call FINDPAR(name,1,is,il)
fn=name(is:is+il-1)
if (il.le.4.or.fn(il-3:il).ne. '.res') then ! requires *.res file extension
if (l.ge.il+4) then
fn=name(is:is+il-1)// '.res' ! append the extension if possible
il=il+4
else
write(smes,*) 'Can' 't append .res extension'
ires=-1
return
endif
endif
# make a copy of RESCAL parameters
do i=1,mres
dat(i)=res_dat(i)
enddo
# open file
call OPENRESFILE(fn(1:il),iu,ires,0)
if(ires.le.0) goto 90
read(iu,1,err=98,end=97,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=97,iostat=ierr) res_dat(i)
enddo
else ! old version, skip da3,da4
read(line,*,err=98,end=97,iostat=ierr) res_dat(1)
do i=2,i_da3-1
read(iu,*,err=98,end=97,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=97,iostat=ierr) res_dat(i)
enddo
endif
97 close(unit=iu)
rescal_name=fn(1:il)
return
98 ires=-ierr
close(unit=iu)
write(smes,102) ierr,i
90 do i=1,mres
res_dat(i)=dat(i)
enddo
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 'rescal.inc'
INCLUDE 'inout.inc'
integer*4 iu
parameter(iu=24)
character*(*) sarg
character*60 name
character*2 UPCASE,ch2
integer*4 i,l,TRUELEN,ires
1 format( ' Save to file : ',$)
2 format(a)
3 format( ' Parameters saved in "',a40)
4 format( ' Cannot save parameters in "',a40)
ires=0
l=TRUELEN(sarg)
ch2=UPCASE(sarg(1:2))
if(l.eq.0.and.rescal_name.ne. ' ') then
name=rescal_name
else if((l.eq.0.and.rescal_name.eq. ' ')
* .or.(l.eq.2.and.ch2.eq. 'AS')) then
write(smes,1)
read(sinp,2) name
else
name=sarg
endif
l=TRUELEN(name)
if (l.le.0) then
return
endif
l=TRUELEN(name)
open(unit=iu,file=name(1:l),status= 'UNKNOWN',err=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 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 "create" causes just creating spectrum data (with zero intensities), ires=3
#---------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
character*(*) sarg
character*60 name,tmpname
integer*4 i,ierr,is,il,ires
real*8 dat(mres)
1 format( ' Name of a parameter or data file: ',$)
11 format( ' Name of a parameter or data file [',a, '] : ',$)
2 format(60a)
201 format( ' RESCAL paramaters loaded: ',a)
202 format( ' Can' 't open RESCAL file ',a, ', trying data file ...')
203 format( ' Can' 't read RESCAL file ',a, ', trying data file ...')
101 format( 'Error ',i4, ': File ',a, ' doesn' 't exist !')
102 format( 'Error ',i4, ': Can' 't read data in ',a, ' ! ')
103 format( 'Error ',i4, ': Can' 't read data, header accepted ! ')
ires=0
# store default filename in TMPNAME
if (rescal_name.ne. ' ') then
tmpname=rescal_name
else
tmpname= ' '
endif
# Get filename from dialog or from the argument SARG
call BOUNDS(tmpname,is,il)
if (sarg.eq. ' ') then
if (il.le.0) then
write(smes,1)
read(sinp,2) name
else ! offer a default filename
write(sout,11) tmpname(is:is+il-1)
read(sinp,2) name
if (name.eq. ' ') name=tmpname(is:is+il-1)
endif
else
name=sarg
endif
# debug test
if (name.eq. ' ') return
# try first to read RESCAL file *.res
call READ_RESCAL(name,ires)
call BOUNDS(name,is,il)
if (ires.gt.0) then
ires=1
write(smes,201) name(is:is+il-1)
return
else if (ires.eq.-1) then
ires=0
write(smes,202) name(is:is+il-1)
else
ires=0
write(smes,203) name(is:is+il-1)
endif
# make a copy of RESCAL parameters
do i=1,mres
dat(i)=res_dat(i)
enddo
#// try first to read parameters from data file
call ReadDatFile(datpath,name,ierr) ! try ILL data format
call BOUNDS(name,is,il)
if(ierr.eq.0) then ! data file, complete
rescal_name=datname// '.res'
ires=2
else if (ierr.eq.2) then ! only header, no data values
if (silent.lt.2) write(smes,103) ierr
rescal_name=datname// '.res'
ires=1
else ! another problem with data file
if (silent.lt.2) then
if (ierr.eq.29) then
write(smes,101) ierr,name(is:is+il-1)
else
write(smes,102) ierr,name(is:is+il-1)
endif
endif
goto 90
endif
return
# on error: restore RESCAL parameters and exit
90 do i=1,mres
res_dat(i)=dat(i)
enddo
return
end
#-------------------------------------------------------------------------------------------------
SUBROUTINE ReadDatFile(namedir,namefile,ierr)
# Subroutine for reading parameters from data files. ILL UNIX format is accepted.
# Simplified from RESTRAX for SIMRES: only data header is evaluated
#---------------------------------------------------------------------------------------------
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'rescal.inc'
integer*4 i_io,is,il,ilines
parameter(i_io=23)
character*1 cun,cdl
character*(*) namefile,namedir
character*128 pathname
character*256 cline,cmdline,titleline
integer*4 ierr,nuse,i,ios,l,id,lf,iif
integer*4 idata,ip,ip1,ld
real*8 valpar(res_nvar)
logical*4 usepar(res_nvar),lun
character*6 s,respar(res_nvar)
integer*4 idbg
data idbg/0/ ! for debug purposes - set IDBG>0 to see debug messages
201 format( ' trying ILL data format on ',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))
#/// **** READ DATA HEADER ****
#// define variables identificators, equal to the RES_NAM(i) array:
do i=1,res_nvar
s=res_nam(i)// '='
call STRCOMPACT(s,is,il)
respar(i)=s(is:is+il-1)
enddo
#// UsePar(i) serves to identify actually read parameters
#// lun = true if energy unit has been found
#// nuse is the number of identified parameters
nuse=0
ierr=1
do i=1,res_nvar
usepar(i)=.false.
end do
lun=.false.
idata=0
ilines=0
1 format(a129)
2 format(a5)
# 3 format(3(2x,F12.3))
#// Find correct datafile name:
call SpecFileName(namefile,1)
call BOUNDS(namedir,id,ld)
call BOUNDS(namefile,iif,lf)
datname=namefile(iif:iif+lf-1) ! set global variable to the new name
pathname=namedir(id:id+ld-1)//namefile(iif:iif+lf-1)
ld=ld+lf
write(smes,201) namefile(iif:iif+lf-1) ! trying this
open(unit=i_io,file=pathname(id:id+ld-1),
* status= 'old',iostat=ios,err=999)
ierr=ios
#-----------------------------------------------------------------------------
# ***** Try to read file HEADER *****
#/// repeat searching cycle until:
#/// (a) the start of data section is reached ('DATA_' string is found),
#/// (b) the end of file is reached.
#----------------------------------------------------------------------------
do 100 while ((ios.eq.0).and.(idata.eq.0))
read(i_io,1,iostat=ios,err=100,end=110) cline
ilines=ilines+1
call SpaceDel(cline)
idata=index(cline, 'DATA_')
call BOUNDS(cline,is,il)
is=index(cline, 'TITLE:')
if (is.gt.0) titleline= cline(is+6:il)
is=index(cline, 'COMND:')
if (is.gt.0) cmdline= cline(is+6:il)
#/// search for unit name:
ip=index(cline, 'UN') ! energy units
if((ip.ne.0).and.(.not.lun)) then
cdl=cline(ip-1:ip-1)
if(cdl.eq. ' ') then ! ' ' delimiter must precede
ip1=index(cline(ip:), '=')
if(ip1.ne.0) then
read(cline(ip+ip1:),2,iostat=ios) cun
if(ios.eq.0) then
lun=.true.
else
ios=0
endif
endif
endif
endif
#/// search for QH,QK,QL,EN,DQH,DQK,DQL,DE in old format ('HKLE ' ident.) :
ip=index(cline, 'HKLE ')
if((ip.ne.0).and.(.not.usepar(i_qh))) then
read(cline(ip+5:),*,iostat=ios) (valpar(i),i=i_qh,i_den)
if(ios.eq.0) then
do i=i_qh,i_den
usepar(i)=.true.
end do
nuse=nuse+8
else
ios=0
endif
endif
#/// search for other parameters identified by ResPar(i) strings
do i=1,res_nvar
if(.not.usepar(i)) then
l=index(respar(i), '=')-1
ip=index(cline,respar(i)(1:l))
if(ip.ne.0) then
cdl= ' '
if (ip.gt.1) cdl=cline(ip-1:ip-1)
if(cdl.eq. ' ') then ! space must precede the identifier
ip1=index(cline(ip:), '=')
if(ip1.ne.0) then ! search for the value after =
read(cline(ip+ip1:),*,iostat=ios) valpar(i)
if(ios.eq.0) then
usepar(i)=.true.
nuse=nuse+1
if (idbg.gt.0) write(*,205) respar(i),valpar(i) ! for debug
else
ios=0
endif
endif
endif
endif
endif
end do
100 continue
if (nuse.gt.0) ierr=2 ! something from the header was read
close(i_io)
110 if((ios.ne.0).or.(idata.eq.0)) then
if (ierr.eq.2) then ! no data, but header was read
goto 180
else
goto 199
endif
endif
#// convert energy to meV if needed
180 if (lun) then
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
call UNITS( 'm')
endif
do i=1,res_nvar
if (usepar(i)) res_dat(i)=valpar(i)
enddo
# CALL RECLAT ! compute reciprocal lattice parameters and matrices
# CALL SCATTRIANGLE ! compute and check KI,KF,Q and tras. matrix Lab -> CN
#/// 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(res_dat(i_dqh))+abs(res_dat(i_dqk))+
* abs(res_dat(i_dql)).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 out information about data and ask for energy units if necessary
if (silent.le.1) then
call BOUNDS(titleline,is,il)
write(sout,202) 'TITLE : ',titleline(is:is+il-1)
call BOUNDS(cmdline,is,il)
write(sout,202) 'COMMAND : ',cmdline(is:is+il-1)
write(sout,202) 'FILE : ',pathname(id:id+ld-1)
endif
return
999 if (silent.le.2) write(sout,*) 'failed'
return
199 ierr=1
close(i_io) ! No spectrum read
if (silent.le.2) write(sout,*) 'not a regular data file'
return
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 10 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
10 continue
return
end
#------------------------------------------------------------------
SUBROUTINE SpecFileName(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
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
endif
endif
return
end