src/exci_handle.f

Fortran project RESTRAX, source module src/exci_handle.f.

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