Source module last modified on Tue, 9 May 2006, 21:07;
HTML image of Fortran source automatically generated by
for2html on Mon, 29 May 2006, 15:06.
#//////////////////////////////////////////////////////////////////////
#//// $Id: exci_handle.f,v 1.9 2006/05/09 19:07:46 saroun Exp $
#////
#//// R E S T R A X 4.80
#////
#//// Subroutines for handling EXCI library:
#//// initialization, selection dialog etc.
#////
#//////////////////////////////////////////////////////////////////////
#*****************************************************************************
SUBROUTINE EXCTEST
#*****************************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'exciimp.inc'
record /MODEL/ arg
integer*4 i
call getmodel(arg)
1 format( 'EXCTEST_GET :',10(1x,g8.3))
write(*,1) arg.fixparam(1),arg.fixparam(2)
write(*,1) arg.wen
# change arg and send it to EXCI
arg.fixparam(1)=1
arg.fixparam(2)=1
do i=1,6
arg.wen(i)=i+10.d0
enddo
call setmodel(arg)
# change arg locally
arg.fixparam(1)=0
arg.fixparam(2)=0
do i=1,6
arg.wen(i)=1.0d-1
enddo
2 format( 'EXCTEST_CLR :',10(1x,g8.3))
write(*,2) arg.fixparam(1),arg.fixparam(2)
write(*,2) arg.wen
# reload arg from EXCI:
call getmodel(arg)
3 format( 'EXCTEST_SET :',10(1x,g8.3))
write(*,3) arg.fixparam(1),arg.fixparam(2)
write(*,3) arg.wen
end
#*****************************************************************************
SUBROUTINE INITEXCI(iread,isqom)
# Read EXCI parameters and initialize EXCI
# if IREAD>0, read exci parameters even if they are normally not read (EXCREAD<2)
# if ISQOM>0, call GETSQOM to fill QOM arrays with resol. functions
#*****************************************************************************
implicit none
INCLUDE 'config.inc'
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'restrax.inc'
INCLUDE 'exciimp.inc'
record /MODEL/ rm
character*128 fpath,fileph
integer*4 iread,isqom,loadexci
integer*4 i,ires,is,il,is1,il1,is2,il2,is3,il3
logical*4 log1
real*8 dum4(4),dum6(6),dum61(6)
real*8 chkqom,GETSQOM
real*4 exciversion,e
integer*4 init,iu
data init,iu /0,13/
2 format( 'Read a file with EXCI parameters, type <Q> to quit:')
3 format(a)
4 format( 'Error when loading EXCI module: ',a,
& ' error ',i2)
6 format( 'EXCI module ',a, ' has already been loaded ')
5 format( 'WARNING: Incompatible version of EXCI module ',/,
& ' loaded: ', g10.4, 'required: ', g10.4)
# write(*,*) 'call INITEXCI ',IREAD,ISQOM
# Load EXCI module
call BOUNDS(excilib,is,il)
ires= loadexci(excilib(is:is+il-1)//char(0))
# Message and return when loading failed
if(ires.lt.0) then
write(smes,4) excilib(is:is+il-1),ires
return
endif
# Message when loading skipped - identical library name
if(ires.eq.0.and.iread.gt.0) then
write(smes,6) excilib(is:is+il-1)
endif
call RECLAT ! calculate rec. lattice transformation matrices and send them to EXCI
# get model data from EXCI
call getmodel(rm)
# Check module version
e=exciversion()
if (exci_number.ne.e) then
# Warning message if version is different
write(sout,5) e,exci_number
endif
# Read parameters from a file if
# a) required by EXCI author (EXCREAD>1)
# b) allowed by the author (EXCREAD=1) AND
# called for the first time or required by the argument (IREAD>0)
if (rm.excread.gt.1.or.
& (rm.excread.eq.1.and.(init.eq.0.or.iread.gt.0))) then
# create search path
call BOUNDS(rm.phonname,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)
ires=-1
if (rm.phonname(1:3).eq. 'idl') then ! files 'idl..' are read directly
call OPENEXCIFILE(iu,fileph(1:i)//char(0),ires)
log1=.true.
else ! otherwise, ask for the filename
write(smes,2)
call DLG_FILEOPEN(rm.phonname(is:is+il-1),fpath, 'par',1,1,ires,fileph)
i=len_trim(fileph)
log1=(ires.gt.0.and.i.gt.0)
# quit file loading by giving 'Q' as the filename
log1=(log1.and.fileph(1:i).ne. 'Q'.and.fileph(1:i).ne. 'q')
if (log1) call OPENEXCIFILE(iu,fileph(1:i)//char(0),ires)
endif
if (log1.and.ires.eq.0) then
rm.phonname=fileph(1:i)
rm.excunit=iu
call setmodel(rm) ! pass phonname to EXCI
call READEXCIPAR
call CLOSEEXCIFILE(iu)
call getmodel(rm) ! get updated model data from EXCI
else
write(sout,*) 'No EXCI parameter file read ... '
endif
endif
# fill QOM arrays with simulated resolution functions
if (isqom.ne.0) chkqom=GETSQOM(1,mf_max)
# report EXCI status
if (iread.ne.0) call REPEXCIPAR
# initialize EXCI
call EXCI(0,dum4,dum6,dum61)
# get updated model data from EXCI
call getmodel(rm)
init=1
# copy parameters for fitting from EXCI
do i=1,rm.nterm
fpar(i) = rm.param(i)
jfixed(i) = rm.fixparam(i)
end do
nfpar=rm.nterm
# clear histograms
call HISTINIT ! set bit1=0 => no RHIST ready
jfit=0 ! and make previous fit invalid
whathis=ior(whathis,4) ! set bit3=1 => EXCI module can be used to produce RHIST
# test
# call EXCTEST
end
#*****************************************************************************
SUBROUTINE SETEXCI(sarg,initex)
# Get the name of EXCI module, load it and call INITEXCI
# if SARG<>' ', then use SARG as the module name
# if INITEX>0, call INITEXCI
#*****************************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'config.inc'
integer*4 is,il,ires,loadexci,initex
character*(*) sarg
character*128 name
# get module filename
name=sarg
10 call BOUNDS(excilib,is,il)
if (name.eq. ' ') then
name=excilib(is:is+il-1)
call DLG_STRING( 'EXCI library',name,1)
endif
call BOUNDS(name,is,il)
# load the module
# write(*,*) 'SETEXCI: loadexci: ',NAME(IS:IS+IL-1)
if (index(name(is:is+il-1), '.').le.0) then
name=name(is:is+il-1)// '.'//shext
call BOUNDS(name,is,il)
endif
ires= loadexci(trim(name)//char(0))
# if not successful, try again interactively
if(ires.lt.0.and.name.ne. ' ') then
name= ' '
goto 10
endif
# if successful, call INITEXCI
if (ires.ge.0) then
excilib=name(is:is+il-1)
if (initex.gt.0) call INITEXCI(1,1)
endif
end