src/sim_rdf.f

Fortran project SIMRES, source module src/sim_rdf.f.

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