src/res_rdf.f

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

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