program feffit
c
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c ---  program feffit
c
c  author   Matthew Newville
c  post     GSECARS, Bldg 434A
c           APS, Argonne National Laboratory
c           Argonne, IL 64309 USA
c  voice    (630) 252-0431
c  fax      (630) 252-0443
c  e-mail   newville@cars.uchicago.edu
c  web      http://cars.uchicago.edu/~newville/feffit/
c
c  version  feffit 2.55
c  update   07-feb-2002
c
c --- copyright 2002  matt newville
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c  feffit will fit the results of a feff (5 and higher) calculation
c  to xafs chi(k) data, allowing parameters in the xafs equation to
c  vary until the least-squares difference between data and theory
c  is minimized.  principle features of feffit are:
c    -  fitting can be done in r-space or backtransformed k-space.
c    -  the xafs equation is evaluated as a sum over paths.
c    -  physical parameters for each path can be easily constrained.
c       the user writes math expressions for these parameters in
c       terms of user-chosen variables which are used in the fit.
c    -  error analysis is done, giving an estimate for the
c       uncertainties in the fit variables, the correlations
c       between these variables, and the goodness-of-fit.
c
c  feffit uses the following inputs:
c      1. an input file named feffit.inp.
c      2. a set of feffnnnn.dat files from feff (5 or higher),
c         for the xafs contribution from a scattering path.
c      3. chi(k) data, which can be in either a uwxafs 'chi' file
c         or an ascii column file.
c  see documentation for further details.
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c version notes:
c     vax versions differ from standard versions by:
c     1. irecl = 128 (standard irecl = 512) for uwxafs binary files
c     2. output log files are opened with status = 'new'
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c major revisions (for a complete revision record, contact matt) :
c    feffit 2.01 july 28 1993 (fit multiple data sets)
c    feffit 2.05 jan  19 1994 ("local"s added, many minor fixes)
c    feffit 2.10 may  15 1994 (added bkg spline option)
c    feffit 2.20 june  1 1994 (fixed bug in uncertainties)
c    feffit 2.30 nov  17 1994 (added fitting in q-space)
c    feffit 2.31 dec   4 1994
c    feffit 2.32 dec  12 1994 (added routine testrf)
c    feffit 2.33 may  10 1995 (added flag for tranquada correction)
c       - minor debugging for g77
c       - fixed rfact
c    feffit 2.34 june  3 1995 (altered inpdat, inpcol, and testrf)
c       - made to accept less strict formatting of ascii data
c    feffit 2.35 june  4 1995 (add constant phase shift)
c       - altered all path parameter handling, using "pointers"
c    feffit 2.36 june 16 1995 (add rm2fg flag)
c       -  to use {reff}^{-2} in xafs eq. instead of {reff+delr}^{-2}
c    feffit 2.37 june 22 1995 (added fixicd, rearranged decoding)
c       -  added routine fixicd to sort integer icodes, so that
c          variables come first, then trivial constants, then locals,
c          and finally the user-defined functions, ordered so that
c          they can be stably determined in one pass.  also altered the
c          handling of local "set" values so that the icdval array
c          holds the pointer to which expression to evaluate.
c   2.38 june 22 1995 (adding derived uncertainties in
c                        used defined functions and path params)
c        .f july 10  changed tranquada correction to integer flag
c        .g july 18  changed tranquada correction to real factor
c   2.39a 31-july-95 altered calculation of the number of
c                    independent points.  now considers amount of
c                    information to be a non-integer, and uses
c                    simple (2/pi) * dk * dr + 2 .
c       b 03-aug-95  fixed serious problem of not resetting
c                    values of xguess after reordering the
c                    variables and "set" values.  easy fix.
c   2.40a 17-aug-95  changed chipth, so that now, as in feff,
c                        p = Re(p) + i / lambda
c                    (was using a "-" before!).
c                    this turned out to be very important for
c                    large disorder!!!!
c       b 27-aug     changed default rm2flag to .false.
c   2.41a 04-oct-95  changed bkgfile to subtract bkg from data
c   2.41b 06-oct-95  altered fftfit to prevent access violation
c                    of qgrid on call to fftout
c   2.42  08-oct-95  added flag "kfull" to write out the full
c                    complex chi(k) (real and imag) for the
c                    theory, without doing 2 fourier tranforms
c                    (not well tested with uwxafs files yet)
c   2.42b 07-may-96  altered outcol & outdat (and xfsout) to
c                    allow arbirtary comment character and
c                    a fixed number of doc lines
c   2.45  31-may-96  added logical flags "pcfit" and "pcout" to
c                    fit and write outputs for phase corrected
c                    FT.  This will use the phase dependence of
c                    the first feffnnnn.dat file,  to alter the
c                    complex chi(k) to be
c                       chi(k)_pc = chi(k) * exp(-i * phase(k))
c                    where phase(k) is the total phase from the
c                    feffnnnn.dat file (col 2 + col 4).
c   2.45b 07-Jun-96  several minor cosmetic changes, including
c                    commenting out all "dafs" references, and
c                    improving and moving around some error
c                    checking and messages.
c   2.45c 18-Jul-96  altered output statements in fitck2
c   2.45d 05-Aug-96  use juser for output path file name,
c                    added routine setsys to set system flags
c   2.45e 07-Aug-96  fixed error in q-space fitting
c                    (number of fit points was incorrect!!)
c   2.46  02-oct-96  chipth made more efficient, dafs removed 
c   2.46b 10-oct-96  added routine fixstr for strings in fitinp,
c                    removed all traces of dafs, changed some 
c                    error messages, and changed toler
c   2.46c 11-oct-96  added routine finmsg to
c                    deal with error messages from fitinp
c   2.50   11-dec-96 added support for feff.bin files written by
c                    feff702m (matt's asci feff.bin file)
c   2.51   16-may-97 ft window arrays now calculated once (in fitdat) 
c                    and stored for use in xafsft. altered routines 
c                    fitfft, xafsft, xfsout, fitout, fitnls, fitfun
c   2.52   20-aug-97 several minor changes for ifeffit compatibility
c       b  16-dec-97 re-implemented "min" and "max" functions!
c       c  17-dec-97 increased sizes for math parsing:
c                       maxval in encod.f   ->  128
c                       micode in const.h   ->   50
c                       strings in fitinp.f -> *128
c       d  06-jan-98 fixed initialization of iunit array in getcom, 
c                    which was preventing include files from working
c       e  13-mar-98 fixed bug introduced in 2.52 for determining feff
c                    path to use for phase-correction. "pcout=t,pcfit=f"
c                    now verified to work.
c       f  25-jun-98 fixed bug in xafsft allowing 0**0.
c       g  26-jun-98 increased line lengths to 128 characters many places, 
c                    and to 256 in others.  128 char lines in feffit.inp
c                    should now always work.  Also increased micode 
c                    and several other params in encod and friends to
c                    allow many more math  expressions. Increased max 
c                    number of paths (mpaths and mdpths) to 512.  
c       h  03-mar-99 fixed bug in fitout naming scheme that could cause
c                    outputs to be written to standard output.
c   2.53   10-mar-99 altered 'nfit' in fitfun for k-space fits to be 
c                    2x number of points.  This effectively makes the 
c                    'real' component of chi(k) 0.00.
c                    -- added 'fit_space' keyword which takes the values
c                       'k', 'r', or 'q'.
c   2.54   06-apr-99 made several alteration to encod and friends to
c                    allow 256-element math expressions (possibly more)
c                    added (but commented out) rpndmp to dump the rpn 
c                    code to screen.
c   2.54   06-apr-99 made several alteration to encod and friends to
c   2.55   07-feb-02 fix parse error for min() and max() functions. 
c----------------------------------------------------------------------
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c  local variables
       character*10 systm
       integer    il, istrln
       external   istrln
       data systm /'unix'/
c system options:  'unix','vax','dos','mac'
       call setsys(systm,vaxflg,dosflg,macflg)
c version & date
       il    = max (1,istrln(systm))
       versn = '  feffit  2.55   07-Feb-2002 ('//systm(:il)//')'
       il    = istrln(versn)
       call messag(versn(1:il))
c initialize
       call fitint
c read input file
       call messag('  - reading inputs ' )
       call fitinp
c read data files
       call messag('  - reading input data files ' )
       call fitdat
c check integer coding of math formulas
       call messag('  - checking math expressions ')
       call fitchk
c read feff files
       call messag('  - reading feff data files')
       call fefsrt( mfffil, mpaths, feffil, iffrec, jpthff)

       call fefinp( mffpts, mfffil, mffttl, maxleg, fefttl, feffil,
     $      iffrec, degflg, degpth, refpth, rwgpth, ratpth, theamp, 
     $      thepha, qfeff,  realp,  xlamb, nlgpth,  izpth, iptpth)
c check that initial guesses for path parameters are "reasonable"
       call fitck2
       call messag('  - finding best-fit values for the variables')
c do non-linear-least-squares fit to determine best-fit values and
c uncertainties in fitted parameters
       call fitnls
c write results to log file and parameter file
       messg = '  - writing results to feffit.log'
       il    = istrln(messg)
       if (prmout) call append(messg,' and feffit.prm',il)
       call messag (messg(1:il))
       call fitlog
       if (prmout) call fitprm
c write results to data files:
       if (noout) then
          call messag('  - *not* writing output data files')
       else
          call messag('  - writing output data files')
          call fitout
       endif
c finished
       call messag('  feffit is finished.  have a nice day.')
c end program feffit
       end
       function istrln(str)
c returns index of last non-blank character,
c         0 if string is null or blank.
       character*(*) str
       istrln = 0
       if ((str(1:1).eq.char(0)) .or. (str.eq.' ')) return
       do 10  istrln = len(str), 1, -1
          if (str(istrln:istrln) .ne. ' ')  return
 10    continue
       return
c end function istrln
       end
      subroutine triml (string)
c removes leading blanks.
      character*(*)  string
      jlen = istrln(string)
c
c-- all blank and null strings are special cases.
      if (jlen .eq. 0)  return
c-- find first non-blank char
      do 10  i = 1, jlen
         if (string (i:i) .ne. ' ')  goto 20
  10  continue
  20  continue
c-- if i is greater than jlen, no non-blanks were found.
      if (i .gt. jlen)  return
c-- remove the leading blanks.
      string = string (i:)
      return
c end subroutine triml
      end
      subroutine smcase (str, contrl)
c  convert case of string *str*to be the same case
c  as the first letter of string *contrl*
c  if contrl(1:1) is not a letter, *str* will be made lower case.
      character*(*) str, contrl, s1*1, t1*1
      s1 = contrl(1:1)
      t1 = s1
      call lower(t1)
      if (t1.eq.s1)  call lower(str)
      if (t1.ne.s1)  call upper(str)
      return
c end subroutine smcase
      end
      subroutine upper (str)
c  changes a-z to upper case.  ascii specific
      character*(*) str
      parameter(iloa= 97, iloz=122, idif= 32)
      external istrln
      jlen = max(1, istrln(str))
      do 10 j = 1, jlen
         i = ichar(str(j:j))
         if ((i.ge.iloa).and.(i.le.iloz)) str(j:j) = char(i-idif)
   10 continue
      return
c end subroutine upper
      end
      subroutine lower (str)
c  changes a-z to lower case.  ascii specific
      character*(*) str
      parameter(iupa= 65, iupz= 90, idif= 32)
      external istrln
      jlen = max(1, istrln(str))
      do 10 j = 1, jlen
         i = ichar(str(j:j))
         if ((i.ge.iupa).and.(i.le.iupz)) str(j:j) = char(i+idif)
   10 continue
      return
c end subroutine lower
      end
      subroutine unblnk (string)
c
c remove blanks from a string
       integer        i, ilen, j
       character*(*)  string, str*2048
       ilen = min(2048, max(1, istrln(string)))
       j   = 0
       str = ' '
       do 10 i = 1, ilen
          if (string(i:i).ne.' ') then
             j = j+1
             str(j:j) = string(i:i)
          end if
 10    continue
       string = ' '
       string = str(1:j)
       return
c end subroutine unblnk
      end
      subroutine untab (string)
c replace tabs with blanks :    tab is ascii dependent
      integer        itab , i, ilen, istrln
      parameter      (itab = 9)
      character*(*)  string, tab*1
      external istrln
      tab  = char(itab)
      ilen = max(1, istrln(string))
 10   continue
        i = index(string(:ilen), tab )
        if (i .ne. 0) then
            string(i:i) = ' '
            go to 10
        end if
      return
c end subroutine untab
      end
       logical function isnum (string)
c  tests whether a string can be a number. not foolproof!
c  to return true, string must contain:
c    - only characters in  'deDE.+-, 1234567890' (case is checked)
c    - no more than one 'd' or 'e'
c    - no more than one '.'
c  matt newville
       character*(*)  string,  number*20
c note:  layout and case of *number* is important: do not change!
       parameter (number = 'deDE.,+- 1234567890')
       integer   iexp, idec, i, j, istrln
       external  istrln
       iexp  = 0
       idec  = 0
       isnum = .false.
       do 100  i = 1, max(1, istrln(string))
          j = index(number,string(i:i))
          if (j.le.0)               go to 200
          if((j.ge.1).and.(j.le.4)) iexp = iexp + 1
          if (j.eq.5)               idec = idec + 1
 100   continue
c  every character in "string" is also in "number".  so, if there are
c  not more than one exponential and decimal markers, it's a number
       if ((iexp.le.1).and.(idec.le.1)) isnum = .true.
 200   continue
       return
c  end logical function isnum
       end
      logical function iscomm(str)
c true if str is a comment line or blank line, false otherwise
      character*(*) str
      iscomm = ((str.eq.' ') .or. (index('*%#',str(1:1)).ne.0))
      return
      end
       subroutine setsys(system,vaxflg,dosflg,macflg)
c simple way of setting flags, describing the operating system used.
c rather than setting all flags by hand, this uses a single string
c and ensures that only one flag is on
       character*(*) system, sys*3
       logical       vaxflg,dosflg,macflg
       vaxflg = .false.
       dosflg = .false.
       macflg = .false.
       call triml(system)
       call smcase(system,'a')
       sys = system(:3)
       if ((sys.eq.'vax').or.(sys.eq.'vms')) then
          vaxflg = .true.
          system = sys
       elseif (sys.eq.'mac') then
          macflg = .true.
          system = sys
       elseif (sys.eq.'dos') then
          dosflg = .true.
          system = sys
       else
          system = 'unix'
       endif
       return
       end
      subroutine messag(messg)
c
c  write message to  standard ouput with (1x,a) format
c
      character*(*) messg
      write(*,10)   messg
 10   format(1x,a)
      return
c end subroutine messag
      end

       subroutine fitint
c
c      initialize the common blocks in feffit at runtime.
c      see also fitbdt, which does this as block data
c
c      copyright 1993 university of washington         matt newville
c----------------------------------------------------------------------
c        include 'fitcom.h'
c{fitcom.h
c  common blocks for feffit
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c fitcom.h}
c  temporary parameters for legths of multiple-dimensioned arrays
       integer lwfft, i, j, k
       parameter (lwfft  = (4*maxpts+15)   )
c
c  single values
       frminp = ' '
       frmout = ' '
       asccmt = '# '
       if (vaxflg) asccmt = '##'
       inpfil = 'feffit.inp'
       mdocxx =  0
       mftfit =  0
       mftwrt =  maxpts
       xnidp  =  zero
       inform =  0
       ndata  =  0
       rlast  =  10.0
       cormin =  0.25
       rwght1 =  15.
       rwght2 =  25.
       tranq  =  2.
       allout = .true.
       final  = .false.
       rm2flg = .false.
       dphflg = .false.
       kspcmp = .false.
       kspout = .true.
       rspout = .true.
       bkgout = .true.
       qspout = .true.
       pcout  = .false.
       pcfit  = .false.
       chkdat = .true.
       prmout = .true.
       noout  = .false.
       nofit  = .false.
       degflg = .true.
       iprint = 1
       chisqr = zero
       usrtol = one
       numvar = 0
       nvuser = 0
       ifxvar = 0
       ierbar = 0
       nerstp = 1
       ixpath = 0
       nmathx = 0
       nconst = 0
c
c loop over mdata
       do 300 i = 1, mdata
          skey(i)   = ' '
          outfil(i) = '_fit'
          chifil(i) = ' '
          bkgfil(i) = ' '
          skeyb(i)  = ' '
          do 30 j = 1, maxdoc
             doc(j,i) = ' '
 30       continue
          do 40 j = 1, mtitle
             titles(j,i) = ' '
 40       continue
          qweigh(i) = zero
          rweigh(i) = zero
          qwin1(i)  = zero
          qwin2(i)  = zero
          rwin1(i)  = zero
          rwin2(i)  = zero
          qmin(i)   = zero
          qmax(i)   = zero
          rmin(i)   = zero
          rmax(i)   = zero
          nqfit(i)  = 0
          nqpts(i)  = 0
          nrpts(i)  = 0
          iqwin(i)  = 0
          irwin(i)  = 0
          ifft(i)   = 1
          jffphs(i) = 0
          q1st(i)   = zero
          qlast(i)  = zero
          sigdtr(i) = zero
          sigdtk(i) = zero
          sigdtq(i) = zero
          sigwgt(i) = zero
          weight(i) = zero
          rfactr(i) = zero
          xinfo(i)  = zero
          ndoc(i)   = 0
          nkey(i)   = 0
          nkeyb(i)  = 0
          nchi(i)   = 0
          bkgfit(i) = .false.
          bkgdat(i) = .false.
          nbkg(i)   = 0
          datain(i) = .false.
          rbkg(i)   = zero
          do 70 j = 1, mtknot
             qknot(j,i) = zero
 70       continue
          chi2dt(i) = zero
          do 100 j = 1, maxpts
             chifit(j,i) = zero
             qwindo(j,i) = zero
             rwindo(j,i) = zero
             bkgq(j,i) = zero
             chiq(j,i) = zero
             thiq(j,i) = zero
 100      continue
          do 200 j = 0, mdpths
             jdtpth(j,i) = 0
             jdtusr(j,i) = 0
 200      continue
          do 240 j = 1, mlocal
             icdloc(1,j,i) = 0
 240      continue
 300   continue

c
c  loop over mvarys
       do 350 i = 1, mvarys
          xguess(i) = zero
          xfinal(i) = zero
          delta(i) = zero
          do 320 j = 1, mvarys
             correl(j,i) = zero
 320      continue
 350   continue

c
       do 500 i = 1, mfffil
          feffil(i) = ' '
          do 410 j =  1, mffttl
             fefttl(j,i) = '  '
 410      continue
          degpth(i) = one
          refpth(i) = zero
          rwgpth(i) = zero
          nlgpth(i) = 0
          iffrec(i) = 0
          do 420 j = 1, mffpts
             qfeff(j,i)  = zero
             theamp(j,i) = zero
             thepha(j,i) = zero
             realp(j,i)  = zero
             xlamb(j,i)  = zero
 420      continue
          do 460 j = 0, maxleg
             izpth(j,i)  = 0
             iptpth(j,i) = 0
             do 440 k = 1, 3
                ratpth(k,j,i) = zero
 440         continue
 460      continue
 500   continue

       do 700 i = 1, maxval
          values(i) = zero
          vnames(i) = ' '
          icdval(1,i) = 0
 700   continue
       do 750 i = 1, mpaths
          pthlab(i) = ' '
          jpthff(i) = 0
          do 720 j = 1, mpthpr
             icdpar(1,j,i) = 0
 720      continue
 750   continue
c
       do 780 i = 1, mpthpr
          defalt(i) = zero
 780   continue
       defalt(jps02) = one
       parnam(jps02) = 's02'
       parnam(jpe0)  = 'e0'
       parnam(jpei)  = 'ei'
       parnam(jpdpha)= 'dphase'
       parnam(jpdelr)= 'delr'
       parnam(jpsig2)= 'sigma2'
       parnam(jp3rd) = 'third'
       parnam(jp4th) = 'fourth'
       do 800 i = 1, mconst
          consts(i) = zero
 800   continue

       do 900 i = 1,   lwfft
          wfftc(i) = zero
 900   continue
c
c end subroutine fitint
       end

       subroutine fitinp
c
c  read inputs for feffit from feffit.inp
c  copyright 1993 university of washington          matt newville
c
c  read inputs from command file with keywords and a lot of elseifs.
c
c        include 'fitcom.h'
c{fitcom.h
c  common blocks for feffit
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c fitcom.h}
c
       integer maxwrd, mfil, i, iinp, iex, ier, nwords, iwrds
       integer ilen, istrln, j, ierr, i2, iv, i3
       integer nfil, jl, iuser, idpath, inpath
       parameter(maxwrd = 30, mfil = 10)
       character*2048 str, string, strdum, stat*10
       character*128 words(maxwrd), wrdsor(maxwrd)
       character     keywrd*128, key*3, prompt*20
       logical       errskp, path0, flag
       integer       itemp, itfeff, ifeff, ititle, idata, iparam
       integer       ilcl, jlcl,icom(mfil)
       external      istrln
       data          itemp, itfeff, ititle, idata,ilcl /0,0,0,1,0/
c-----------------------------------------------------------------------
c     initialization
       prompt = 'f'
       do 10 i = 1, mfil
          icom(i)   = 0
 10    continue
       nfil   = 0
       iunky  = 0
c   input file: if file is found, open it for reading,
       iinp = 1
       ier  = 0
       iex  = 0
       stat = 'old'
       inpfil='feffit.inp'
       call lower(inpfil)
       if (macflg) then
cc#mac
ccc use LS Fortran's '*' syntax and dialog boxes (thanks boyan!)
c          open(unit=iinp,file=*,status='old',iostat=ier)
c          if (ier.ne.0) then
c             call AlertBox('File selection was canceled!')
c             call finmsg(2001,string,' ',0)
c          end if
c          call f_setvolume(jvrefnum(iinp))
c          call f_creator('ttxt')
ccc   this resets fname to the name of the opened file.
ccc   useful for computing output file names, etc.
c           inquire(unit=iinp,name=inpfil,iostat=ier)
c           if (ier.ne.0) inpfil='feffit.inp'
cc#mac
       else
cc          call openfl(iinp, inpfil, stat, iex, ier)
cc          if (iex.lt.0) call finmsg(1001,inpfil,' ',0)
cc          if (ier.ne.0) call finmsg(1002,inpfil,' ',0)
       end if
c---------------------------------------------------------------------
c     read in next line
       jinit  = -1
       string = inpfil
 100   continue
          errskp = .false.
          path0  = .false.
          iparam = jpnull
          strdum = ' '
          keywrd = ' '
          key    = ' '
          call getcom(jinit,string)
          call fixstr(string,str,ilen,words,wrdsor,maxwrd,nwords)
          if (ilen.lt.2) go to 100
          if (str.eq.'getcom_end')  go to 4000
          if (str.eq.'getcom_error') call finmsg(1003,inpfil,' ',0)
          if (str.eq.'getcom_nofile')
     $         call finmsg(1001,inpfil,' ',0)
 150      continue
          keywrd  = words(1)
          key     = keywrd(1:3)
          iwrds   = 2
c     use keyword to get the right value
c--   data set index : ' next data set ' on its own line
          if ( (keywrd.eq.'next').and.(words(2).eq.'data')) then
             iwrds  = maxwrd + 1
c   first write out title lines from previous data set
             messg = '   titles:'
             ilen = istrln(messg)
             write(strdum,'(a,i4)') ' --> data set #',idata
             call append(messg,strdum,ilen)
             call messag( messg(1:ilen))
             do 225 j = 1, mtitle
                if (titles(j,idata) .ne. ' ' )
     $               call messag('      '//titles(j,idata)(1:65))
 225         continue
c    now increment idata, reset ititle, check that idata isn't too big
             idata  = idata  + 1
             ititle = 0
             if (idata.gt.mdata) call finmsg(2220,string,' ',mdata)
c
c     keywords for input/ouput
c--   title  ( on its own line)
          elseif (keywrd.eq.'title') then
             iwrds  = maxwrd + 1
             ititle = ititle + 1
             if ( (ititle.le.mtitle).and.(wrdsor(2).ne.' ')) then
                call strclp(string, wrdsor(1), wrdsor(2),
     $               titles(ititle, idata))
             end if
c--   end reading file : ignore everything in input file past this line
          elseif (( keywrd.eq.'end' ).or.( keywrd.eq.'quit')) then
             go to 4000
c--   file formats for inputs and outputs: defaults are uwxafs,
c     but can be changed to ascii column files with  formin = 'asc'
          elseif ((keywrd.eq.'form').or.(keywrd.eq.'format')) then
             frmout = words(2)
             frminp = frmout
          elseif (keywrd(1:7).eq.'formin') then
             frminp = words(2)
          elseif (keywrd(1:8).eq.'formout')  then
             frmout = words(2)
c comment char for ascii column data files
          elseif ((keywrd.eq.'comment').or.(keywrd.eq.'asccmt')) then
             asccmt  = words(2)
c hardwire number of doc lines for ascii column data files
          elseif (keywrd.eq.'mdocxx') then
             call str2in(words(2), mdocxx, ierr )
c--   input data file        note: for uwexafs files, strdum contains
c     the file name and record specifier (nkey or skey).
          elseif (keywrd.eq.'data')  then
             datain(idata) = .true.
             errskp        = .true.
             i2 = max(1, istrln(wrdsor(2)))
             if (nwords.ge.3) then
                i3 = max(5, istrln(wrdsor(3)))
                strdum = wrdsor(2)(:i2+2)//wrdsor(3)(:i3)
                call filrec(strdum, chifil(idata), skey(idata),
     $                      nkey(idata))
             else
                chifil(idata) = wrdsor(2)
                skey(idata)   = ' '
                nkey(idata)   = 0
             end if
c--   bkg(k) data file     note: for uwexafs files, strdum contains
c     the file name and record specifier (nkey or skey).
          elseif (keywrd(1:6).eq.'bkgfil')  then
             bkgdat(idata) = .true.
             errskp        = .true.
             i2 = max(1, istrln(wrdsor(2)))
             if (nwords.ge.3) then
                i3 = max(5, istrln(wrdsor(3)))
                strdum = wrdsor(2)(:i2+2)//wrdsor(3)(:i3)
                call filrec(strdum, bkgfil(idata), skeyb(idata),
     $                      nkeyb(idata))
             else
                bkgfil(idata) = wrdsor(2)
                skeyb(idata)   = ' '
                nkeyb(idata)   = 0
             end if
c--   output file
          elseif  (keywrd.eq.'out') then
             outfil(idata)   = wrdsor(2)
c--   print level to feffit.run file
          elseif (keywrd.eq.'iprint') then
             call str2in(words(2), iprint, ierr )
c--   flag for doing tranquada correction
          elseif (keywrd(1:5).eq.'tranq') then
             call str2re(words(2), tranq, ierr )
c--   flag for not doing fit and writing output
          elseif (keywrd.eq.'norun') then
             call str2lg(words(2), noout, ierr )
             nofit = noout
c--   flag for not writing output
          elseif (keywrd.eq.'noout') then
             call str2lg(words(2), noout, ierr )
c--   flag for not doing fit
          elseif (keywrd.eq.'nofit') then
             call str2lg(words(2), nofit, ierr )
c--  flag for writing feffit.prm file
          elseif (keywrd.eq.'prmout') then
             call str2lg(words(2), prmout, ierr )
c--  flag for writing phase corrected FT
          elseif (keywrd.eq.'pcout') then
             call str2lg(words(2), pcout, ierr )
c--  flag for using phase corrected FT in fit
          elseif (keywrd.eq.'pcfit') then
             call str2lg(words(2), pcfit, ierr )
c--   flag for fitting background spline to low-r components
          elseif (keywrd.eq.'bkg') then
             call str2lg(words(2), bkgfit(idata), ierr )
c--   flag for writing background spline to output data file
          elseif (keywrd.eq.'bkgout') then
             call str2lg(words(2), bkgout, ierr )
c--   flag for writing out data for all paths
          elseif ((keywrd.eq.'all').or.(keywrd.eq.'allout')) then
             call str2lg(words(2), allout, ierr )
c--   flag for writing out data in k space
          elseif ((keywrd.eq.'kfull').or.(keywrd.eq.'fullk')) then
             call str2lg(words(2), kspcmp, ierr )
c--   flag for writing out data in k space
          elseif (keywrd.eq.'kspout') then
             call str2lg(words(2), kspout, ierr )
c--   flag for writing out data in r space
          elseif (keywrd.eq.'rspout') then
             call str2lg(words(2), rspout, ierr )
c--   flag for writing out data in q space (backtransform)
          elseif ((keywrd.eq.'qspout').or.(keywrd.eq.'envout')) then
             call str2lg(words(2), qspout, ierr )
c--   flags for which space to fit in (default is ifft=1 for r-space)
          elseif (keywrd.eq.'kspfit') then
             call str2lg(words(2), flag, ierr)
             if (flag)  ifft(idata) = 0
          elseif (keywrd.eq.'rspfit') then
             call str2lg(words(2), flag, ierr )
             if (flag)  ifft(idata) = 1
          elseif (keywrd.eq.'qspfit') then
             call str2lg(words(2), flag, ierr)
             if (flag)  ifft(idata) = 2
          elseif (keywrd.eq.'fit_space') then
             if (words(2)(1:1).eq.'k') ifft(idata) = 0
             if (words(2)(1:1).eq.'r') ifft(idata) = 1
             if (words(2)(1:1).eq.'q') ifft(idata) = 2
c--   flag for not using degeneracies from feff
          elseif (keywrd.eq.'degen') then
             call str2lg(words(2), degflg, ierr )
          elseif (keywrd.eq.'nodegen') then
             call str2lg(words(2), degflg, ierr )
             degflg = .false.
c--   relative weights for different data sets
          elseif (keywrd.eq.'weight') then
             call str2re(words(2), sigwgt(idata), ierr )
c--   error bars  measurement uncertainty (default is to specify
c          in k-space, but r-space is also allowed.)
          elseif ( (keywrd.eq.'sigdat').or.(key.eq.'eps')
     $      .or.(keywrd.eq.'sigk').or.(keywrd.eq.'epsk')) then
             call str2re(words(2), sigdtk(idata), ierr )
          elseif ( (keywrd.eq.'sigr').or.(keywrd.eq.'epsr')) then
             call str2re(words(2), sigdtr(idata), ierr )
c--   maximum correlation to report
          elseif (keywrd.eq.'cormin') then
             call str2re(words(2), cormin, ierr )
          elseif (keywrd.eq.'rwght1') then
             call str2re(words(2), rwght1, ierr )
          elseif (keywrd.eq.'rwght2') then
             call str2re(words(2), rwght2, ierr )
c--  hack for playing with user tolerance
       elseif  (keywrd.eq.'toler') then
          call str2re(words(2), usrtol, ierr )
c--  number of iterations to make when evaluating error bars
       elseif  (keywrd.eq.'nerstp') then
         call str2in(words(2), nerstp, ierr )
c     keywords for feff.dats
c--   maximum r to write for r-space data
          elseif (keywrd.eq.'rlast') then
             call str2re(words(2), rlast, ierr )
c     keywords for fft stuff
c--   number of points in fft for fit         ( found from qmin, qmax)
          elseif (keywrd.eq.'max_fft_fit') then
             call str2in(words(2), mftfit, ierr )
c--   number of points in fft for writing out data ( 2048)
          elseif (keywrd.eq.'max_fft_out') then
             call str2in(words(2), mftwrt, ierr )
c--   minimum r for fit range
          elseif (keywrd.eq.'rmin') then
             call str2re(words(2), rmin(idata), ierr )
c--   maximum r for fit range
          elseif (keywrd.eq.'rmax') then
             call str2re(words(2), rmax(idata), ierr )
c--   minimum k for fit range / fourier transform
          elseif ((keywrd.eq.'kmin').or.(keywrd.eq.'qmin')) then
             call str2re(words(2), qmin(idata), ierr )
c--   maximum k for fit range / fourier transform
          elseif ((keywrd.eq.'kmax').or.(keywrd.eq.'qmax')) then
             call str2re(words(2), qmax(idata), ierr )
c--   k weight for fourier transform
          elseif ((key(1:2).eq.'kw').or.(key(1:2).eq.'qw')
     $            .or.(key.eq.'w  ')) then
             call str2re(words(2), qweigh(idata), ierr )
c--   window sill fourier transform window parameter(s)
          elseif (keywrd(1:4).eq.'iwin') then
             call str2in(words(2), iqwin(idata), ierr )
             irwin(idata) = iqwin(idata)
c--   window sill fourier transform window parameter(s)
          elseif ((keywrd.eq.'iqwin').or.(keywrd.eq.'ikwin')) then
             call str2in(words(2), iqwin(idata), ierr )
c--   window sill fourier transform window parameter(s)
          elseif (keywrd.eq.'irwin') then
             call str2in(words(2), irwin(idata), ierr )
cc--   gaussian fourier window
c          elseif (keywrd.eq.'gauss')  then
c             call str2re(words(2), qwin1(idata), ierr )
c             qwin2(idata) = qwin1(idata)
c             iqwin(idata) = 2
c             irwin(idata) = 2
cc--   hanning fraction window
c          elseif ((keywrd.eq.'fhan').or.(keywrd.eq.'hann')) then
c             call str2re(words(2), qwin1(idata), ierr )
c             qwin2(idata) = qwin1(idata)
c             iqwin(idata) = 1
c             irwin(idata) = 1
c-- k-space window parameters
          elseif ((keywrd.eq.'dk2').or.(keywrd.eq.'dq2')) then
             call str2re(words(2), qwin2(idata), ierr )
          elseif ((keywrd.eq.'dk1').or.(keywrd.eq.'dq1')) then
             call str2re(words(2), qwin1(idata), ierr )
          elseif ((key.eq.'dk').or.(key.eq.'dq')) then
             call str2re(words(2), qwin1(idata), ierr )
             qwin2(idata) = qwin1(idata)
c-- r-space window parameters
          elseif (key.eq.'dr2') then
             call str2re(words(2), rwin2(idata), ierr )
          elseif (key.eq.'dr1') then
             call str2re(words(2), rwin1(idata), ierr )
cc          elseif (key.eq.'dr') then
cc             call str2re(words(2), rwin1(idata), ierr )
cc             rwin2(idata) = rwin1(idata)
c-- optical transform phase factors
c          elseif (keywrd.eq.'rpha') then
c             call str2re(words(2), rphas(idata), ierr )
c          elseif (keywrd.eq.'qpha') then
c             call str2re(words(2), qphas(idata), ierr )
c
c     keywords for values: "guess"es and "set"s
c     for variables and functions
c--   variable: definition and initial guess
c--   here we : - increase the number of variables
c--   - set the initial guess of the variable
c--   - find the right value to associate with the variable
c--   - set icdval(1,iv) = -1 (to mark value as a variable)
          elseif (keywrd.eq.'guess')   then
             iwrds  = maxwrd + 1
             numvar = numvar + 1
             nvuser = numvar
c     find if this value was already defined,
c     or find the next avialable slot
c*mn -- make a function to return iv :
c    iv = nofstr(words(2),vnames,maxval)
c    that returns iv , or 0 if unfound
cc             iv  = nofstr(words(2), vnames, maxval)
cc             if (iv.eq.0) call finmsg(2100,string,' ',maxval)

             do 300  iv = 1, maxval
                if  (vnames(iv).eq.' ')       go to 310
                if  (vnames(iv).eq.words(2))  go to 320
 300         continue
             call finmsg(2100,string,' ',maxval)
c     new variable  : store name of value, increment # of variables
 310         continue
             nmathx     = max(iv, nmathx)
             vnames(iv) = words(2)
             if (numvar.gt.mvarys) call finmsg(2130,string,' ',mvarys)
c     previously defined value :
c     make sure it's set as a variable, and get initial value
 320         continue
             if (icdval(1, iv).ge.1) then
                call messag( '  -- feffit warning:  '//
     $               'confusion about variables ')
                messg =   vnames(iv)
                ilen = max(1, istrln(messg))
                call messag( '       '//messg(1:ilen))
                call messag( '        was "guessed" after '//
     $               'being "set".  results may be unstable.')
             elseif (icdval(1, iv).lt.0) then
                call messag( '  -- feffit warning:  '//
     $               'this variable was "guessed" twice:')
                messg =   vnames(iv)
                ilen = max(1, istrln(messg))
                call messag( '       '//messg(1:ilen))
             endif
             icdval(1,iv)   = -1
             call str2re(words(3), xguess(numvar), ierr )
             values(iv)     = xguess(numvar)
c
c--   functions: definition and integer array
c--   here we : - check if value has already been defined.
c--   - find the right value to associate with the variable
c--   - encode the icdval integer array
          elseif (keywrd.eq.'set') then
             iwrds  = maxwrd + 1
             do 550  iv = 1, maxval
                if ( (vnames(iv).eq.words(2)).or.
     $               (vnames(iv).eq.' '     )      ) go to 560
 550         continue
             call finmsg(2200,string,' ',maxval)
 560         continue
             nmathx     = max(iv, nmathx)
             vnames(iv) = words(2)
c     check that this user-defined function was not previously
c     assigned as a local user-defined function. at this point,
c     just stop if it was.
             if (icdval(1,iv).gt.ixlocl)
     $            call finmsg(2110,string,vnames(iv),iv)
             call strclp(str,words(2),words(3),strdum)
             if (icdval(1, iv).lt.0) then
                call messag( '  -- feffit warning:  '//
     $               'confusion about variables ')
                messg =   vnames(iv)
                ilen = max(1, istrln(messg))
                call messag( '       '//messg(1:ilen))
                call messag( '        was "set" after '//
     $               'being "guessed".  results may be unstable.')
                numvar = numvar - 1
             elseif (icdval(1, iv).gt.0) then
                call messag( '  -- feffit warning:  '//
     $               'this variable was "set" twice:')
                messg =   vnames(iv)
                ilen = max(1, istrln(messg))
                call messag( '       '//messg(1:ilen))
             endif
             ierr = istrln(str)
c             print*, 'UBER: fitinp: ilen = ', ierr, ' :: ', str(1:ierr)
c             ierr = istrln(strdum)
c             print*, 'UBER: fitinp: ilen = ', ierr, ' :: ',
c     $            strdum(1:ierr)
             ierr   = 0
             call encod(strdum, vnames, maxval, consts, mconst,
     $            icdval(1,iv), micode, ierr)
             if (ierr.gt.0) call finmsg(2500,string,strdum,0)
c--   local functions: definition and integer array
c--   here we : - check if value has already been defined.
c--   - find the right value to associate with the variable
c--   - encode the icdval integer array
          elseif (keywrd.eq.'local') then
             iwrds  = maxwrd + 1
             iv     = 0
 750         continue
             iv = iv + 1
             if (iv.gt.maxval) call finmsg(2200,string,' ',maxval)
             if ( (vnames(iv).ne.words(2)).and.
     $            (vnames(iv).ne.' ')) go to 750
ccc             do 750  iv = 1, maxval
ccc                if ( (vnames(iv).eq.words(2)).or.
ccc     $               (vnames(iv).eq.' '     )      ) go to 760
ccc 750         continue
ccc             call finmsg(2200,string,' ',maxval)
ccc 760         continue
             nmathx     = max(iv, nmathx)
             vnames(iv) = words(2)
             jlcl = icdval(1,iv) - ixlocl
             if (jlcl.le.0) then
                ilcl  = ilcl + 1
                if (ilcl.gt.mlocal) call finmsg(2105,string,' ',mlocal)
                jlcl  = ilcl
             else
                do 780 jl  = 1, mlocal
                   if ((jlcl.eq.jl)) go to 790
 780            continue
                call finmsg(2105,string,' ',mlocal)
 790            continue
                jlcl = jl
             endif
c
c     check that this local user-defined function was not previously
c     assigned as a global user-defined function. at this point,
c     just stop if it was.
             if ((icdval(1,iv).ne.0).and.(icdval(1,iv).lt.ixlocl))
     $            call finmsg(2110,string,vnames(iv),iv)
             call strclp(str,words(2),words(3),strdum)
             ierr   = 0
             call encod(strdum, vnames, maxval, consts, mconst,
     $            icdloc(1,jlcl,idata), micode, ierr)
             icdval(1,iv) = ixlocl + jlcl
             if (ierr.gt.0) call finmsg(2120,string,strdum,0)
c
c     path parameters
c--   feff file name
          elseif ((keywrd.eq.'path').or.(keywrd.eq.'feff'))  then
             iparam = jppath
c--   user identification label
          elseif (key.eq.'id ')       then
             iparam = jplabl
c--   constant amplitude factor
          elseif ( (keywrd.eq.'s02').or.(keywrd.eq.'amp').or.
     $            (keywrd.eq.'so2')) then
             iparam = jps02
c--   energy shift : real energy correction
          elseif ( (key.eq.'esh').or.(key.eq.'e0 ').or.
     $            (key.eq.'ee ').or.(key.eq.'e0s'))  then
             iparam = jpe0
c--   energy shift : imaginary energy correction
          elseif (key.eq.'ei ') then
             iparam = jpei
c--   energy shift : imaginary energy correction
          elseif ((keywrd.eq.'dphase').or.(keywrd.eq.'phase')) then
             dphflg = .true.
             iparam = jpdpha
c--   delta r , the first cumulant
          elseif ( (keywrd.eq.'dr').or.(keywrd.eq.'deltar').or.
     $             (keywrd.eq.'delr'))   then
             iparam = jpdelr
c--   sigma^2, the debye waller factor, the second cumulant
          elseif ((keywrd(1:4).eq.'sigm').or.(keywrd.eq.'ss2')) then
             iparam = jpsig2
c--   the third cumulant
          elseif ( (keywrd.eq.'3rd').or.(keywrd.eq.'third').or.
     $            (keywrd.eq.'cubic'))  then
             iparam = jp3rd
c--   the fourth cumulant
          elseif ( (keywrd.eq.'4th').or.(keywrd.eq.'fourth').or.
     $            (keywrd.eq.'quartic'))  then
             iparam = jp4th
c--   didn't find anything! a null word or something.
          elseif ((.not.errskp).and.(iparam.eq.jpnull) ) then
             call finmsg(2330,string,keywrd,0)
             iwrds  = maxwrd + 1
             iunky  = iunky + 1
             if (iunky.ge.5) call finmsg(2300,string,' ',0)
          end if
c  keywords all checked now.
c
c  now, if keyword is a path parameter, interpret it.
c  there are a lot of path indices here, and they get confusing. 
c  here's a menu:
c     iuser   "user path index"      what the user wrote in feffit.inp
c     inpath  "internal path index"  which set of path params to use           
c     ifeff   "feff path index"      which feff file to use
c     idpath  "data path index"      which internal path is this for this
c                                    data set, when summing over paths
c  idpath is the key, and gives the rest using pointers in common blocks:
c     inpath = jdtpth(idpath,idata) 
c     iuser  = jdtusr(idpath,idata)
c     ifeff  = jpthff(inpath)
c
c--   iuser set here, and character string extracted
          if ( (iparam.ne.jpnull).and.(nwords.gt.2)) then
             iwrds  = maxwrd + 1
             call str2in(words(2), iuser, ierr )
             if ((iuser.lt.0).or.(iuser.gt.10000))
     $            call finmsg(2200,str,' ',0)
             path0  = (iuser.eq.0)
             call strclp(string,wrdsor(2),wrdsor(3),strdum)
c     assign a data path to the user path:
c--   idpath set here so that jdtusr(idpath,idata) = iuser
             idpath = 0
             if (.not.path0) then
                do 900 idpath = 1, mdpths
                   if (jdtusr(idpath,idata).eq.iuser)   go to 940
                   if (jdtusr(idpath,idata).eq.0) then
                      jdtusr(idpath,idata) = iuser
                      go to 940
                   end if
 900            continue
                call finmsg(2140,string,chifil(idata),mdpths)
 940            continue
             end if
c
c   assign an internal path to the data path:
c-- inpath set here           so that jdtpth(idpath,idata) = inpath
             do 1340 inpath = 1, mpaths
                if (jdtpth(idpath,idata).eq.inpath)  go to 1400
                if (jdtpth(idpath,idata).eq.0)       go to 1380
 1340        continue
             call finmsg(2150,string,' ',mpaths)
 1380        continue
             itemp  = itemp + 1
             inpath = itemp
             jdtpth(idpath,idata) = inpath
 1400        continue
c
c   assign a feff path to the internal path:
c-- ifeff set here          so that jpthff(inpath) = ifeff
             if ( (iparam.eq.jppath).and.(.not.path0)) then
                iffx = 0
                if (nwords.ge.4) call str2in(wrdsor(4),iffx,ie)
                do 1640 ifeff = 1, mfffil
                   if ( (feffil(ifeff) .eq. wrdsor(3)).and.
     $                  (iffrec(ifeff) .eq. iffx)) go to 1700
                   if (  feffil(ifeff) .eq. ' '  ) go to 1680
 1640           continue
                call finmsg(2170,string,feffil(ifeff),mfffil)
 1680           continue
                itfeff         = itfeff  + 1
                ifeff          = itfeff
                feffil(ifeff)  = wrdsor(3)
                iffrec(ifeff)  = iffx
 1700           continue
                if (jpthff(inpath).ne.0) then
                   write(messg,'(2a,i5)')' -- feffit warning: ',
     $                  'overwriting the feff file for path ', iuser
                   ilen = max(1, istrln(messg))
                   call messag( '       '//messg(1:ilen))
                end if
                jpthff(inpath) = ifeff
             elseif ((iparam.eq.jppath).and.path0 ) then
                jpthff(inpath) = -1
                call messag( '  -- feffit warning: giving a '//
     $               'feff file for path 0 has no meaning.')
             elseif((iparam.eq.jplabl).and.(.not.path0)) then
                pthlab(inpath) = strdum
             else
                if (icdpar(1,iparam,inpath).ne.0) then
                   write(messg,'(4a,i5)')' -- feffit warning: ',
     $              'redefining ', parnam(iparam),' of path ',iuser
                   ilen = max(1, istrln(messg))
                   call messag( '       '//messg(1:ilen))
                end if
                call smcase(strdum, 'case')
                ierr      = 0
                call encod(strdum, vnames, maxval, consts, mconst,
     $               icdpar(1,iparam,inpath), micode, ierr)
                if (ierr.gt.0) call finmsg(2120,string,strdum,0)
             end if
          end if
c     decide whether or not to read more inputs from the current string
          if (nwords.gt.iwrds) then
             do 3600 i = 1, nwords
                words(i)  = words(i+iwrds)
                wrdsor(i) = wrdsor(i+iwrds)
 3600        continue
             nwords = nwords - iwrds
             go to 150
          end if
          go to 100
 4000  continue
c  end of reading input file
c  close input file, and write out titles for last data set
       if (iinp.ne.5) close(iinp)
       ndata = idata
       messg = '   titles:'
       ilen = istrln(messg)
       if (ndata.gt.1) then
          write(strdum,'(a,i4)') ' --> data set #',idata
          call append(messg,strdum,ilen)
       end if
       call messag( messg(1:ilen))
       do 5800 j = 1, mtitle
          if (titles(j,idata) .ne. ' ' )
     $         call messag('      '//titles(j,idata)(1:65))
 5800  continue
       return
c end subroutine fitinp
       end
       subroutine getcom(jinit, line)
c
c  return next "real" command line from input file(s)
c    -  allows use of "include file" or "load file" for reading
c       from other files, and manages the set of include files
c    -  checks for and ignores comment lines and blank lines.
c    -  opens and closes all input files, including initial file.
c
c   jinit  initialization flag              [in]
c   line   next command line to parse   [in/out]
c
c notes:
c   1. to initialize, set jinit<0 and line= input_file_name.
c      if line=' ', commands will be read from standard input
c      (unit 5).
c   2. returned line will be sent through triml and untab.
c   3. uses routine iscomm to test if line is a comment line.
c   4. uses routine openfl to open files (which include automatic
c      assignment of next available unit number)
c   5. special returned values:
c        'getcom_end'  = done reading all inputs
c        'getcom_error'= an error has occurred. the calling routine
c                        should probably stop
c        'getcom_nofile'= on initialization, the file named by "line"
c                         could not be found
c matt newville march 1997
       implicit none
       integer mwords, ilen, i, jinit, mfil, nfil
       character*(*) line, stat*8
       parameter (mwords=2, mfil=10, stat = 'old')
       character*128  files(mfil), errmsg, words(mwords)
       integer   iunit(mfil), istrln, nwords, ierr, iex
       integer   iret, iread
       logical   iscomm
       external  istrln, iscomm, iread
       save      files, iunit, nfil
c
       if ((jinit.lt.0)) then
          jinit  = 1
          do 10 i = 1, mfil
             iunit(i) = 0
             files(i) = ' '
 10       continue
          nfil     = 1
          files(1) = line
          call triml(files(1))
          if (files(1) .eq. ' ') then
             iunit(1) = 5
          else
             call openfl(iunit(1), files(1), stat, iex, ierr)
             if (iex.lt.0) then
                line = 'getcom_nofile'
                return
             elseif (ierr.ne.0) then
                line = 'getcom_error'
                return
             end if
          end if
       end if
c  read next line from current input file
 100   continue
       line   = ' '
       iret = iread(iunit(nfil), line)
       if (iret.eq.-1) goto  500
       if (iret.eq.-2) goto 1000
       if (iret.eq. 0) goto  100
c
c  check if command line is 'include filename'.
c  if so, open that file, and put it in the files stack

       call triml(line)
       if (iscomm(line)) go to 100
       nwords = mwords
       words(2) = ' '
       call bwords(line, nwords, words)
       call lower(words(1))
       if (((words(1) .eq. 'include').or.(words(1) .eq. 'load'))
     $      .and. (nwords .gt. 1)) then
          nfil = nfil + 1
          if (nfil .gt. mfil) go to 2000
          call getfln(words(2), files(nfil), ierr)
          if (ierr. ne. 0) go to 2400
c  test for recursion:
          do 400 i = 1, nfil - 1
             if (files(nfil) .eq. files(i)) go to 3000
 400      continue
          call openfl(iunit(nfil), files(nfil), stat, iex, ierr)
          if (iex .lt. 0) go to 2600
          if (ierr.lt. 0) go to 2800
          go to 100
       end if
       return
c
c  end-of-file for command line file: drop nfil by 1,
c  return to get another command line
 500   continue
       if (iunit(nfil) .ne. 5) close(iunit(nfil))
       iunit(nfil) = 0
       files(nfil) = ' '
       nfil = nfil - 1
       if (nfil.gt.0) go to 100
       line = 'getcom_end'
       return
c   error messages
 1000  continue
       call messag(' # getcom error: general read error')
       go to 4500
 2000  continue
       call messag(' # getcom error: too many nested "include"s')
       write(errmsg, '(1x,a,i3)') ' # current limit is ', mfil
       ilen  = istrln(errmsg)
       call messag(errmsg(1:ilen))
       go to 4500
 2400  continue
       call messag(' # getcom error: cannot determine "include" file')
       go to 4500
 2600  continue
       call messag(' # getcom error: cannot find "include"d file')
       go to 4500
 2800  continue
       call messag(' # getcom error: cannot open "include"d file')
       go to 4500
 3000  continue
       call messag(' # getcom error: recursive "include" of file')
       go to 4500
 4500  continue
       errmsg = ' # reading file: '//files(nfil)
       if (files(nfil) .eq. ' ')
     $      errmsg = ' # reading from standard input'
       ilen   = istrln(errmsg)
       call messag(errmsg(1:ilen) )
       line = 'getcom_error'
       return
c end subroutine getcom
       end
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2000 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
       subroutine sclean(str) 
c
c  clean a string so that all: 
c     char(0), and char(10)...char(15) are end-of-line comments,
c        so that all following characters are explicitly blanked.
c     all other characters below char(31) (including tab) are
c        replaced by a single blank
c
c  note that this is mostly useful when getting a string generated
c  by a non-fortran process (say, a C program) and for dealing with
c  dos/unix/max line-ending problems
       character*(*) str, blank*1
       parameter (blank = ' ')
       integer i,j,is
       do 20 i = 1, len(str)
          is = ichar(str(i:i))
          if ((is.eq.0) .or. ((is.ge.10) .and. (is.le.15))) then
             do 10 j= i, len(str)
                str(j:j) = blank
 10          continue
             return
          elseif (is.le.31)  then
             str(i:i)  = blank
          end if
 20    continue 
       return
c end subroutine sclean
       end

       integer function iread(iunit,line)
c
c reads line from an open file unit (iunit)
c  return values:
c   line length on success
c            -1 on 'end'
c            -2 on 'error'
       implicit none
       character*(*) line
       integer    iunit, istrln
       external   istrln
       line = ' '
 10    format(a)
       read(iunit, 10, end = 40, err = 50) line
       call sclean(line)
       iread =  istrln(line)
       return
 40    continue 
       line = ' '
       iread = -1
       return
 50    continue 
       line = ' '
       iread = -2
       return
       end
       integer function iread_ky(iunit,key,line)
c
c reads line from an open file unit (iunit)
c and extracts a 2character key (as for PAD files)
c return values:
c   line length on success
c            -1 on 'end'
c            -2 on 'error'
       implicit none
       character*(*) line, key
       integer    iunit, iread, ilen
       external    iread
       key = ' '
       line = ' '
       ilen = iread(iunit, line)
       if (ilen.gt.2) then
          key  = line(1:2)
          line = line(3:)
          ilen = ilen - 2
       endif
       iread_ky = ilen
       return
       end
       subroutine openfl(iunit, file, status, iexist, ierr)
c
c  open a file,
c   if unit <= 0, the first unused unit number greater than 7 will
c                be assigned.
c   if status = 'old', the existence of the file is checked.
c   if the file does not exist iexist is set to -1
c   if the file does exist, iexist = iunit.
c   if any errors are encountered, ierr is set to -1.
c
c   note: iunit, iexist, and ierr may be overwritten by this routine
       character*(*)  file, status, stat*10
       integer    iunit, iexist, ierr, nxtunt
       logical    exist
       external   nxtunt
c
c make sure there is a unit number
       ierr   = -3
       iexist =  0
       if (iunit.le.0) iunit  = nxtunt(7)
c
c if status = 'old', check that the file name exists
       ierr = -2
       stat =  status
       call lower(stat)
       if (stat.eq.'old') then
          iexist = -1
          inquire(file=file, exist = exist)
          if (.not.exist) return
          iexist = iunit
       end if
c
c open the file
       ierr = -1
       open(unit=iunit, file=file, status=status, err=100)
       ierr = 0
 100   continue
       return
c end  subroutine openfl
       end
      integer function nxtunt(iunit)
c  return next available unit number, greater than or equal to iunit.
c  will not return unit number less than 1, or equal to 5 or 6.
      integer iunit
      logical open

      nxtunt = max(1, iunit)
 10   continue
      inquire (unit=nxtunt, opened=open)
      if (open) then
          nxtunt = nxtunt + 1
          if ((nxtunt.eq.5).or.(nxtunt.eq.6)) nxtunt = 7
          goto 10
      endif
      return
c  end integer function nxtunt
      end
      subroutine bwords (s, nwords, words)
c
c     breaks string into words.  words are separated by a
c     whitespace (blank or tab), comma, or equal sign,
c     plus zero or more whitespaces.
c
c     args        i/o      description
c     ----        ---      -----------
c     s            i       char*(*)  string to be broken up
c     nwords      i/o      input:  maximum number of words to get
c                          output: number of words found
c     words(nwords) o      char*(*) words(nwords)
c                          contains words found.  words(j), where j is
c                          greater then nwords found, are undefined on
c                          output.
c
c      written by:  steven zabinsky, september 1984
c      altered by:  matt newville
c**************************  deo soli gloria  **************************
c-- no floating point numbers in this routine.
      implicit integer (a-z)
      character*(*) s, words(nwords)
      character blank, comma, equal, tab
      parameter (blank = ' ', comma = ',', equal = '=')
      external istrln
c-- betw    .true. if between words
c   comfnd  .true. if between words and a comma or equal has
c                                         already been found
      logical betw, comfnd
c-- define tab character (ascii dependent)
       tab = char(9)
c-- maximum number of words allowed
      wordsx = nwords

c-- slen is last non-blank character in string
      slen = istrln (s)

c-- all blank string is special case
      if (slen .eq. 0)  then
         nwords = 0
         return
      endif

c-- begc is beginning character of a word
      begc = 1
      nwords = 0
      betw   = .true.
      comfnd = .true.
      do 10  i = 1, slen
         if ((s(i:i) .eq. blank).or.(s(i:i).eq.tab))  then
            if (.not. betw)  then
               nwords = nwords + 1
               words (nwords) = s (begc : i-1)
               betw = .true.
               comfnd = .false.
            endif
         elseif ((s(i:i).eq.comma).or.(s(i:i).eq.equal))  then
            if (.not. betw)  then
               nwords = nwords + 1
               words (nwords) = s(begc : i-1)
               betw = .true.
            elseif (comfnd)  then
               nwords = nwords + 1
               words (nwords) = blank
            endif
            comfnd = .true.
         else
            if (betw)  then
               betw = .false.
               begc = i
            endif
         endif
         if (nwords .ge. wordsx)  return
   10 continue
c
      if (.not. betw  .and.  nwords .lt. wordsx)  then
         nwords = nwords + 1
         words (nwords) = s (begc :slen)
      endif
      return
c end subroutine bwords
      end
       subroutine getfln(strin, filnam, ierr)
c  strip off the matched delimeters from string, as if getting
c  a filename from "filename", etc.
       integer idel, iend, istrln, ierr
       character*(*) strin, filnam, tmp*144, ope*8, clo*8
       data ope, clo /'"{(<''[',  '"})>'']'/
c
       ierr  = 0
       tmp   = strin
       call triml(tmp)
       ilen  = istrln(tmp)
       idel  = index(ope,tmp(1:1))
       if (idel.ne.0) then
          iend = index(tmp(2:), clo(idel:idel) )
          if (iend.le.0) then
             ierr = -1
             iend = ilen
          end if
          filnam = tmp(2:iend)
       else
          iend = index(tmp,' ') - 1
          if (iend.le.0) iend  = istrln(tmp)
          filnam = tmp(1:iend)
       end if
       return
c end  subroutine getfln
       end

       subroutine fixstr(string,str,ilen,words,wrdsor,mwords,nwords)
c  simple preparation of string for reading of keywords
       integer       ilen, mwords, nwords, i, lenp1
       integer       iexcla, iperct, ihash, ieolc, istrln
       character*(*) string, str, words(mwords), wrdsor(mwords)
c
c  fix-up string: untab, left-justify, make a lower-case version
       nwords = 0
       call untab(string)
       str   = string
       call triml(str)
       call smcase( str, 'case')
c  remove comments from str:
c   '!', '#', and '%' are end of line comments
c   '*' is a complete comment line if in col 1
       lenp1  = len(str) + 1
       iexcla = index(str,'!')
       if (iexcla.eq.0)  iexcla = lenp1
       iperct = index(str,'%')
       if (iperct.eq.0)  iperct = lenp1
       ihash  = index(str,'#')
       if (ihash.eq.0)  ihash = lenp1
       ieolc  = min(iperct,iexcla,ihash) - 1
       if ((ieolc.lt.1).or.(str(1:1).eq.'*')) ieolc = 1
       str    = str(1:ieolc)
       ilen   = max(1, istrln(str))
       if (ilen.le.2)  return
c  break string into words (up to mwords)
c  words is in lower case,   wrdsor is in original case
       do 120 i = 1, mwords
          words(i)   =  ' '
          wrdsor(i) =  ' '
 120   continue
       nwords = mwords
       call bwords(str   , nwords, words)
       call bwords(string, nwords, wrdsor)
c end  subroutine fixstr
       return
       end
       subroutine finmsg(ikey, str1, str2, i1)
c  error messages from feffit
       integer        ikey, i1, ilen
       character*(*)  str1, str2,lblnk*12,messg*80,s1tmp*90,s2tmp*90
       character*35   inperr, fterr, callme, warn, daterr,fferr,chkerr
       parameter (inperr = '>>error reading input file')
       parameter (chkerr = '>>error in math expressions')
       parameter (daterr = '>>error reading data file')
       parameter (fferr  = '>>error reading feff file')
       parameter (fterr  = '>>feffit error')
       parameter (warn   = '>>feffit warning')
       parameter (callme = 'program error: contact matt')
       parameter (lblnk  = '      ')

       s1tmp = ' '
       s2tmp = ' '
       if (str1.ne.' ') s1tmp = str1
       ilen1 = min(65,max(1,istrln(s1tmp)))
       if (str2.ne.' ') s2tmp = str2
       ilen2 = min(65,max(1,istrln(s2tmp)))

 11    format(a,i4)
 12    format(2a,i4)

       if (i1.lt.0) then
          call messag(lblnk//warn)
       else
          messg = fterr
          if ((ikey.ge.2000).and.(ikey.lt.3000)) messg = inperr
          if ((ikey.ge.3000).and.(ikey.lt.3200)) messg = daterr
          if ((ikey.ge.3200).and.(ikey.lt.3500)) messg = chkerr
          if ((ikey.ge.7000).and.(ikey.lt.8000)) messg = fferr
          call messag(lblnk//messg(1:65))
       end if
       if (ikey.eq.0) then
          call messag(lblnk//'feffit died')
       elseif (ikey.eq.1001) then
          call messag(lblnk//'could not find file: '//s1tmp(:ilen1))
       elseif (ikey.eq.1002) then
          call messag(lblnk//'error opening file: '//s1tmp(:ilen1))
       elseif (ikey.eq.1003) then
          call messag(lblnk//'error reading file: '//s1tmp(:ilen1))
c from fitinp (all fatal)
       elseif (ikey.eq.2100) then
          write(messg,11) 'too many named values! current limit is',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.2105) then
          write(messg, 12) 'too many "local" ',
     $      'user-defined values! current limit is ', i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.2110) then
          call messag('this named value '//
     $      'was assigned as both "local" and "global":')
          call messag(lblnk//s2tmp(1:ilen2))
       elseif (ikey.eq.2120) then
          call messag(lblnk//'error encoding the math expression :')
          call messag(lblnk//'  --> '//s2tmp(:ilen2))
       elseif (ikey.eq.2130) then
          write(messg,12) 'too many variables! ',
     $         'current limit is ', i1
          ilen = istrln(messg)
          call messag( '       '//messg(1:ilen))
       elseif (ikey.eq.2140) then
          write(messg,12) 'too many paths for a ',
     $         'data file! current limit is ',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
          messg = 'for data file: '//s2tmp(:ilen2)
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.2150) then
          write(messg,11) 'too many paths used. current limit is',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.2170) then
          write(messg,12) 'too many feffnnnn.dat ',
     $          'files used! current limit is ',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
          messg = 'file requested was '//s2tmp
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif(ikey.eq.2200) then
          call messag(lblnk//'a Path Index larger than '//
     $      '999 or less than 0 was found! ')
       elseif (ikey.eq.2220) then
          write(messg,11) 'too many data sets. current limit is',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.2300) then
          call messag(lblnk//'too many unknonwn keywords!')
          call messag(lblnk//'something wrong with the input file?')
       elseif (ikey.eq.2330) then
          messg = 'unknown keyword : "'//s2tmp(:ilen2)//
     $         '" at this line '
          ilen  = istrln(messg)
          call messag(lblnk//messg(1:ilen))
          call messag(lblnk//'line:  '//s1tmp(:ilen1))
          call messag(lblnk//'the rest of this line will be ignored')
c from fitdat
       elseif (ikey.eq.3010) then
          call messag(lblnk//'data appears to not be chi(k) data')
          call messag(lblnk//'check data file and consult manual')
       elseif (ikey.eq.3020) then
          call messag(lblnk//'too many variables while adding')
          call messag(lblnk//'adding background spline to fit')
          write(messg,11) 'current limit is',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.3040) then
          call messag(lblnk//'too many named values while adding')
          call messag(lblnk//'adding background spline to fit')
          write(messg,11) 'current limit is',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
c from fitchk
       elseif (ikey.eq.3200) then
          call messag(lblnk//'inconsistent number of variables')
          call messag(lblnk//'some variable is probably both'//
     $         ' "guessed" and "set".')
       elseif (ikey.eq.3220) then
          call messag(lblnk//'this variable name was used but '//
     $             'was not defined:' )
          call messag(lblnk//'  --> '//s1tmp(:ilen1))
       elseif (ikey.eq.3240) then
          call messag(lblnk//'the following value was defined but is')
          call messag(lblnk//'not used in any math expressions:')
          call messag(lblnk//'  --> '//s1tmp(:ilen1))
          call messag(lblnk//'this may cause problems with the fit.')
       elseif (ikey.eq.3300) then
          call messag(lblnk//'bad initial value for an XAFS parameter!')
          call messag(lblnk//'   for '//s1tmp(1:ilen1))
          call messag(lblnk//'       '//s2tmp(1:ilen2))
c from fitnls
       elseif (ikey.eq.3510) then
          call messag(lblnk//'more variables than measurements')
          call messag(lblnk//s1tmp(:ilen1))
       elseif (ikey.eq.3530) then
          call messag(lblnk//'fit gave an impossible error message.')
          call messag(lblnk//callme)
c from fitfun
       elseif (ikey.eq.3590) then
          call messag('routine fitfft failed internal test.')
          call messag(lblnk//callme)
c from fefinp
       elseif (ikey.eq.7010) then
          call messag(lblnk//s1tmp(:ilen1))
          call messag(lblnk//'bad data in feffnnnn.dat file')
       elseif (ikey.eq.7020) then
          write(messg,11) 'too many legs in path. current limit is',i1
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
          call messag(lblnk//s1tmp(:ilen1))
       elseif (ikey.eq.7050) then
          call messag(lblnk//'not enough room '//
     $         'to read all the data from this feff file')
          write(messg,'(a,i3,a)') 'results above k = ',
     $         -i1, ' will not be reliable'
          ilen = istrln(messg)
          call messag(lblnk//messg(1:ilen))
       elseif (ikey.eq.7510) then
          call messag(lblnk//s1tmp(:ilen1))
          call messag(lblnk//'bad data in feff.bin file')
c ??
       else
          write(messg,11) 'unknown error ',ikey
          ilen      = max(1, istrln(messg))
          call messag(lblnk//messg(1:ilen))
       endif
c for fitinp messages, write out last line from feffit.inp
       if ((ikey.ge.2100).and.(ikey.le.3000).and.(i1.ge.0)) then
          call messag(lblnk//'last line read successfully:')
          call messag(lblnk//s1tmp(:ilen1))
       endif
       if ((ikey.le.9999).and.(i1.ge.0)) stop
       return
       end
      subroutine append(str1, str2, ilen)
c   append str2 to str1.
c   str1 and ilen are overwritten
c   str2 is not overwritten
      character*(*)  str1, str2, tmp*2048
      integer        ilen, istrln
      external       istrln
      ilen  = max(1, istrln(str1))
      tmp   = str1(1:ilen)//str2
      ilen  = min(istrln(tmp), len(str1))
      str1  = tmp(1:ilen)
      return
      end
      subroutine strclp(str,str1,str2,strout)
c
c  a rather complex way of clipping a string:
c      strout = the part of str that begins with str2.
c  str1 and str2 are subsrtings of str, (str1 coming before str2),
c  and even if they are similar, strout begins with str2
c  for example:
c   1.  str =  "title title my title" with  str1 = str2 = "title"
c       gives strout = "title my title"
c   2.  str =  "id  1  1st path label" with str1 = "1", str2 = "1st"
c       gives strout = "1st path label"
c
      character*(*)  str, str1, str2, strout
      integer  i1, i2, ibeg, iend, istrln, ilen
      external istrln
      ilen   = len(strout)
      i1     = max(1, istrln(str1))
      i2     = max(1, istrln(str2))
      i1e    = index(str,str1(1:i1)) + i1
      ibeg   = index(str(i1e:),str2(1:i2) ) + i1e - 1
      iend   = min(ilen+ibeg, istrln(str) )
      strout = str(ibeg:iend)
      return
c end subroutine strclp
      end
      subroutine str2dp(str,dpval,ierr)
c  return dp number "dpval" from character string "str"
c  if str cannot be a number, ierr < 0 is returned.
      character*(*) str, fmt*15
      double precision dpval
      integer  ierr , lenmax
      parameter ( lenmax = 40)
      logical  isnum
      external isnum
      ierr = -99
      if (isnum(str)) then
         ierr = 0
         write(fmt, 10) min(lenmax, len(str))
 10      format('(bn,f',i3,'.0)')
         read(str, fmt, err = 20, iostat=ierr) dpval
      end if
      if (ierr.gt.0) ierr = -ierr
      return
 20   continue
      ierr = -98
      return
c end subroutine str2dp
      end
      subroutine str2re(str,val,ierr)
c  return real from character string "str"
      character*(*) str
      double precision dpval
      real     val
      integer  ierr
      call str2dp(str,dpval,ierr)
      if (ierr.eq.0) val = dpval
      return
c end subroutine str2re
      end
      subroutine str2in(str,intg,ierr)
c  return integer from character string "str"
c  returns ierr = 1 if value was clearly non-integer
      character*(*) str
      double precision val, tenth
      parameter (tenth = 1.d-1)
      integer  ierr, intg
      call str2dp(str,val,ierr)
      if (ierr.eq.0) then
         intg = int(val)
         if ((abs(intg - val) .gt. tenth))  ierr = 1
       end if
      return
c end subroutine str2in
      end
      subroutine str2lg(str,flag,ierr)
c  return logical "flag" from character string "str".
c  flag is .true. unless the str(1:1) is 'f' or 'n' (not case-sensitive)
      character*(*) str, test*4
      parameter (test = 'fnFN')
      logical    flag
      integer    ierr
      ierr  = 0
      flag  = .true.
      if (index(test,str(1:1)).ne.0) flag  = .false.
      return
c end subroutine str2lg
      end
      subroutine filrec(string,filnam,skey,nkey)
c
c      takes a character string and reads from it a filename, and an
c  skey and/or nkey for a record. blanks, commas, or equal signs can
c  separate the inputs on the command line.
c
      character*128  temp, words(3)
      character*(*)  string ,   filnam , skey
c
      nkey = 0
      skey = ' '
      nwords = 3
      call bwords(string,nwords,words)
c---- first word is filename
      filnam = words(1)
      nwords = nwords - 1
c---- second word is nkey or skey
      temp   = words(2)
c---- determine if second//third word is nkey/skey
c     skeys are exactly 5 characters long,
c     nkeys are never more than 3 characters long
 50   continue
      nwords = nwords - 1
      call triml(temp)
      ilen = istrln(temp)
      if(ilen.eq.5) then
         skey = temp
         call upper(skey)
      elseif(ilen.eq.4) then
         call messag('error reading skey or nkey from '//temp)
         stop
      else
         call str2in(temp, nkey, ierr)
      end if
c---- the third word, if it exists
      if (nwords.eq.1) then
         temp = words(3)
         call triml(temp)
         go to 50
      end if
 1000 return
c     end subroutine filrec
      end




       subroutine encod(string,vnames,nv,consts,nc,icode,ni,ierr)
c
c   copyright 1993  university of washington      matt newville
c
c   this encodes the integer array 'icode' from an equation in the
c   character string 'string'. the companion function *decod* will
c   decode this integer array, returning the proper number.
c   decod is called by:
c             decod(icode, consts, values, defval)
c   the values of 'values' should correspond to the variables named
c   in 'vnames'.  encod and decod are designed for many repeated
c   evaluations. the encoding is slow and slightly redundant and the
c   decoding is as efficient as possible. icode is a small number of
c   integers representing the rpn notation for the math expression,
c   with special integer values specifing all operations and values.
c
c   the character string contains a fortran-like math expression.
c   variables can be used. their names will be held in the character
c   array 'vnames', and their numerical values will be held in the
c   real array 'values'. variables do not need to be explicitly
c   declared before encoding. if a variable is found that has not
c   already been identified, it will be added to the list. the link
c   between variable name and value, and the actual values used are
c   expected to be managed by the routine(s) calling encod and decod.
c
c  input:
c    string  character string containing fortran-like math expression
c    vnames  character array containing variable names
c    nv      dimension of array vnames          (maximum = 8192)
c    consts  real array of numerical constants in math expressions
c    nc      dimension of array consts
c    ni      dimension of icode consts          (maximum = 512)
c  output:
c    string  math expression as to be evaluated (with parens added)
c    vnames  character array containing variable names
c    consts  real array of numerical constants in math expressions
c    icode   integer array containing code for the math expression
c    ierr    error/warning code - routine will not stop !
c           -2     a new variable was added to the list
c           -1     string empty
c            0     no errors or warnings messages at all
c            1     too many constants
c            2     incorrect dimension of vnames
c            3     improper/ambiguous arithmetic
c            5     one-component math syntax error
c            7     parentheses syntax error
c                             ( unmatched or in improper place)
c            9     too many objects in math expresion
c----------------------------------------------------------------------
c    the real array consts contains all the real numbers used as
c    constants. the first 10 values of consts are set aside for
c    "common" real values: 0, 1, 2, pi, etc. these ten constants
c    can be used for accessing internal parameters. the calling
c    routine can associate any values it likes with the first ten
c    numbers, and by rewriting some of this routine, names can be
c    associated with the values. 'pi', and 'reff' are handled in
c    this way. (though it's not expected that anyone will want to
c    overwrite the value of pi, the same is not true for reff).
c
c----------coding parameters for the math operations------------------
c   icode value             meaning
c  -299 to -100     special functions { add(x,y), debye(temp,theta) }
c   -99 to  -50     two-element math operations (x+y, x**y)
c   -49 to  -10     one-element math operations (1/x, sin(x), et c.)
c    -9 to   -6     control operations (open and close parens, comma)
c    -5 or   -1     not possible! (useful for  overwriting/disabling)
c             0     null string
c     1  to jconst  variables corresponding to vnames strings
c jconst to  xxx    constants (numbers in corresponding to consts)
c---------------------------------------------------------------------
c passed variables
       integer       nv, ni, nc, ierr, icode(ni)
       character*(*) string, vnames(nv)
       real          consts(nc)
c parameters
       real       pi, one, zero
       integer    maxlen, jconst, ileft, iright, icomma
       parameter(one = 1., zero = 0., pi = 3.141592653589793)
       parameter(maxlen = 1024, jconst = 8192)
       parameter(ileft =  -6, iright =  -7, icomma = -8   )
       integer  iexp, ilog, isqrt, isin, icos, itan, iabs
       integer  iasin, iacos, iatan, isinh, icosh, itanh, icoth
       parameter(iexp  = -10, ilog  = -11, isqrt = -12,
     $             isin  = -13, icos  = -14, itan  = -15,
     $             iasin = -16, iacos = -17, iatan = -18,
     $             iabs  = -19, isinh = -23, icosh = -24,
     $             itanh = -25, icoth = -26  )
       integer     iadd, isub, imul, idiv, iy2x
       parameter(iadd  = -50, isub   = -51, imul   = -52,
     $             idiv  = -53, iy2x   = -54                )
       integer     jadd, jsub, jmin, jmax, jdebye, jeins, jeins2
       parameter(jadd =-111, jsub  =-112, jmin  =-85,
     $      jmax =-86, jdebye=-120, jeins =-121, jeins2=-122)
c
c internal variables
       character*2048  str, strnum, strtmp, errmsg, strout, opera*9
       character*1  str1, straft, strbfr, stri3*3, stri4*4, stri5*5
       character    mtherr*22, synerr*34, encerr*33, number*12
       logical      found, strok
       integer      itemp(maxlen), ntemp, ilen, istr, ieqn
       integer      iparen, iexcla, iperct, ieolc, isave
       integer      ibfr, iaft, ibefr, iaftr, ivarln, istrln
       integer      j, jt, jstack, jcomma, ii, it, i
       real         xreal
       external     istrln
       data number,opera /'1234567890 .' , '+-*/^(), '/
       data mtherr /' math encoding error: '/
       data synerr /' math encoding error: syntax error'/
       data encerr /' math encoding error: encod error'/

c-----------------------------------------------------------------------
c  initial error checking of input dimensions
       if (nv.gt.jconst) then
          call messag(mtherr//'incorrect dimension!')
          write (errmsg,'(4x,a,i4,a)') ' more than', jconst,
     $         ' variables are requested '
          ii  = max(1, istrln(errmsg))
          call messag('  '// errmsg(1:ii))
          ierr = 2
          return
       end if
c  initialization
       ierr   = 0
       strtmp = ' '
       str    = ' '
       str1   = ' '
       strnum = ' '
       straft = ' '
       strbfr = ' '
       found  = .false.
c  remove interior blanks from string
       strtmp = string
       ilen   = istrln(strtmp)

       call triml(strtmp)
       call unblnk(strtmp)

       ilen   = istrln(strtmp)
cc       print*, 'UBER #2: ', ilen, ':: ', strtmp(1:ilen)
       maxeol = len(strtmp)
c  remove end-of-line comments:  '!','%'  signify end of line comments
       iexcla = index(strtmp,'!')
       if (iexcla.eq.0) iexcla = maxeol
       iperct = index(strtmp,'%')
       if (iperct.eq.0) iperct = maxeol
       ieolc  = min(iperct,iexcla)
       if (ieolc.eq.1) strtmp = ' '
       if ( (ieolc.ge.2).and.(ieolc.le.maxeol)) then
          str        = strtmp(:ieolc-1)
          str(ieolc:) = ' '
          strtmp     = str
       end if
       ilen   = istrln(strtmp)
cc       print*, 'UBER #3: ', ilen, ':: ', strtmp(1:ilen)
c
c  if string is blank, return
       if ( (strtmp.eq.' ').or.(ilen.le.0).or.(ieolc.eq.1)) then
          icode(1) = 0
          ierr     = -1
          return
       end if
c
c  convert string to the case of this routine :
c    the variable 'case' controls the case of the routine, so it
c    must be the same case as the strings tested for in strtmp.
       call smcase(strtmp, 'c')
       do 40 i = 1, nv
          call smcase(vnames(i), 'c')
 40    continue
c
c  initialized integer arrys to 0
       do 50 i = 1, ni
          icode(i) = 0
 50    continue
       do 60 i=1,maxlen
          itemp(i)  = 0
 60    continue
c
c  set the first values in consts:
c     be careful when changing consts(1) from zero, because the rest
c     of the first ten constants are set to zero also, even though a
c     calling routine may want to overwrite some of them !!!
       consts(1) = zero
       consts(2) = one
       consts(3) = pi
       consts(4) = zero
       consts(5) = zero
       consts(6) = zero
       consts(7) = zero
       consts(8) = zero
       consts(9) = zero
c  initialization done.
c-------------------------------------------------------------------
c  now start dealing with strtmp as a math expression
c  fix multiple "unitary" operations: ++, -- -> +; -+, +- -> -
       do 120 i = 1, ilen-1
          str = strtmp(i:i+1)
          if ((str.eq.'--').or.(str.eq.'++')) strtmp(i:i+1) = ' +'
          if ((str.eq.'-+').or.(str.eq.'+-')) strtmp(i:i+1) = ' -'
 120   continue
       call unblnk(strtmp)
c-----------------------------------------------------------------------
c  insert parens to ensure normal math precedence.
c    note that this is not entirely necessary, but it is convenient
c    to rewrite the string in the way it is intended to be evaluated.
       string = strtmp
       call parens(string)
       call triml(string)
       ilen = max(1, istrln(string))
       string(ilen+1:) = ' '
       strout          = string
       strtmp          = ' '
c-----------------------------------------------------------------------
c  with the string well behaved (parens inserted so there are no
c   ambiguities in the math), let's dechiper it and encode icode
c
c  decipher string into integers
       isave  = 0
       istr   = 0
       ieqn   = 0
       iparen = 0
c  advance string postion, check for end of string
 300   continue
       ieqn = ieqn + 1
 320   continue
       istr = istr + 1
       ibfr = istr - 1
       iaft = istr + 1
       if (ibfr.lt.1) ibfr = 1
       if (istr.gt.ilen) go to 4000
       str1   = string(istr:istr)
       stri3  = string(istr:istr+2)
       stri4  = string(istr:istr+3)
       stri5  = string(istr:istr+4)
       strbfr = string(ibfr:ibfr)
       straft = string(iaft:iaft)
c  ignore blank spaces
       if (str1.eq.' ') go to 320
c-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
c  parse string
c  # constant real number : find length of real number, read it,
c                store it, and advance string to end of number
       if (index(number,str1).ne.0) then
          isave  = istr + nbrstr(string(istr:ilen))
          strnum = string(istr:isave)
          call str2re(strnum, xreal, ierr)
          if (ierr.ne.0) then
             call messag(mtherr//'cannot read number from string')
             errmsg =  '  >> '//string(istr:isave)//' << '
             call messag(errmsg(1:(isave - istr + 10)))
             ierr = 3
             return
          endif
c       check if constant is already stored. don't start adding more
c       until consts(10), to preserve the stored internal constants
          do 450 i = 1, nc
             if (xreal.eq.consts(i)) then
                itemp(ieqn)  = jconst + i
                go to 500
             elseif ((consts(i).eq.0).and.(i.ge.10)) then
                itemp(ieqn)  = jconst + i
                consts(i) = xreal
                go to 500
             end if
 450      continue
 500      continue
c     error : too many constants!
          if (i.ge.nc) then
             call messag(encerr)
             call messag( ' too many real numbers entered.')
             write (errmsg,'(14x,2a,i4,a)') 'the current',
     $            ' limit is ', nc,' unique numbers.'
             call messag( errmsg )
             ierr = 1
             return
          end if
          istr = isave
c     internally stored constants
c
c     'pi' followed by an operation (or a blank or paren)
c     means use the constant stored in address #(jconst + 3).
       elseif ( (string(istr:istr+1).eq.'pi').and.
     $         (index(opera,string(istr+2:istr+2)).ne.0)  ) then
          itemp(ieqn)  = jconst + 3
          istr         = istr + 1
c
c     'reff' followed by an operation (or a blank or paren)
c     means use the constant stored in address #(jconst + 4).
c             (this is useful for feffit)
       elseif ( (stri4.eq.'reff').and.
     $         (index(opera,string(istr+4:istr+4)).ne.0)  ) then
          itemp(ieqn)  = jconst + 4
          istr         = istr + 3
c
c     'ndegen' followed by an operation (or a blank or paren)
c     means use the constant stored in address #(jconst + 5).
c             (this is useful for feffit)
       elseif ( (string(istr:istr+5).eq.'ndegen').and.
     $         (index(opera,string(istr+6:istr+6)).ne.0)  ) then
          itemp(ieqn)  = jconst + 5
          istr         = istr + 5
c
c      '_k_' followed by an operation (or a blank or paren)
c            means use the constant stored in adress #(jconst + 6).
c            (this is useful for feffit)
c       elseif ( (stri3.eq.'_k_').and.
c     $     (index(opera,string(istr+3:istr+3)).ne.0)  ) then
c             itemp(ieqn)  = jconst + 6
c             istr         = istr + 2
c
c  # end constants
c  # math operations
c   parens and comma
       elseif (str1.eq.'(') then
          itemp(ieqn)  = ileft
          iparen = iparen + 1
       elseif (str1.eq.')') then
          itemp(ieqn)  = iright
          iparen = iparen - 1
       elseif (str1.eq.',') then
          itemp(ieqn)  = icomma
c   two component math
       elseif ((str1.eq.'+').or.(str1.eq.'-')) then
          if ( (straft.eq.')')) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             call messag('  "+)"  and "-)" are not correct syntax.')
             ierr = 3
             return
          else
             if (str1.eq.'+') itemp(ieqn) = iadd
             if (str1.eq.'-') itemp(ieqn) = isub
          end if
       elseif ((str1.eq.'/').or.(str1.eq.'*')) then
          ibefr = index('(+-/*^,',strbfr)
          iaftr = index(')*/^,',straft)
          if ( (istr.eq.1).or.(istr.eq.ilen).or.(iaftr.ne.0)
     $         .or.(ibefr.ne.0)) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             if (ibefr.ne.0) then
                errmsg = '  "/" or "*" preceded by one of "+-/*^,("'
             elseif (iaftr.ne.0) then
                errmsg = '  "/" or "*" followed by one of "/*^,)"'
             elseif (istr.eq.1) then
                errmsg = '  "/" or "*" occurs first'
             elseif (istr.eq.ilen) then
                errmsg = '  "/" or "*" occurs last'
             end if
             ii  = max(1, istrln(errmsg))
             call messag('    '//errmsg(1:ii))
             ierr = 3
             return
          else
             if (str1.eq.'*') itemp(ieqn) = imul
             if (str1.eq.'/') itemp(ieqn) = idiv
          end if
       elseif (str1.eq.'^') then
          ibefr = index('(+-/*^,',strbfr)
          iaftr = index(')*/^,',straft)
          if ( (istr.eq.1).or.(istr.eq.ilen).or.(iaftr.ne.0)
     $         .or.(ibefr.ne.0)) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             if (ibefr.ne.0) then
                errmsg = '  "^" preceded by one of "+-/*^,("'
             elseif (iaftr.ne.0) then
                errmsg = '  "^" followed by one of "/*^,)"'
             elseif (istr.eq.1) then
                errmsg = '  "^" occurs first'
             elseif (istr.eq.ilen) then
                errmsg = '  "^" occurs last'
             end if
             ii  = max(1, istrln(errmsg))
             call messag('    '//errmsg(1:ii))
             ierr = 3
             return
          else
             itemp(ieqn) = iy2x
          end if
c
c   special math functions:
       elseif ((stri4.eq.'add(').or.(stri4.eq.'sub(').or.
     $         (stri4.eq.'min(').or.(stri4.eq.'max(')) then
          if (stri4.eq.'add(')   itemp(ieqn)  = jadd
          if (stri4.eq.'sub(')   itemp(ieqn)  = jsub
          if (stri4.eq.'min(')   itemp(ieqn)  = jmin
          if (stri4.eq.'max(')   itemp(ieqn)  = jmax
          istr   = istr + 2
       elseif (string(istr:istr+5).eq.'debye(') then
          itemp(ieqn)  = jdebye
          istr = istr + 4
       elseif (string(istr:istr+5).eq.'eins2(') then
          itemp(ieqn)  = jeins2
          istr = istr + 4
c
c  one component math :
c    the operator must be followed by '(', or the expression will
c    be a variable name:   ln2 is a variable !
       elseif (stri3.eq.'ln(') then
          itemp(ieqn)  = ilog
          istr = istr + 1
       elseif ((stri4.eq.'log(').or.(stri4.eq.'exp(').or.
     $         (stri4.eq.'abs(').or.(stri4.eq.'sin(').or.
     $         (stri4.eq.'cos(').or.(stri4.eq.'tan(')) then
          if (stri4.eq.'log(')   itemp(ieqn)  = ilog
          if (stri4.eq.'exp(')   itemp(ieqn)  = iexp
          if (stri4.eq.'abs(')   itemp(ieqn)  = iabs
          if (stri4.eq.'sin(')   itemp(ieqn)  = isin
          if (stri4.eq.'cos(')   itemp(ieqn)  = icos
          if (stri4.eq.'tan(')   itemp(ieqn)  = itan
          istr = istr + 2
       elseif ((stri5.eq.'sqrt(').or.(stri5.eq.'asin(').or.
     $         (stri5.eq.'acos(').or.(stri5.eq.'atan(').or.
     $         (stri5.eq.'sinh(').or.(stri5.eq.'cosh(').or.
     $         (stri5.eq.'tanh(').or.(stri5.eq.'coth(').or.
     $         (stri5.eq.'eins(')            ) then
          if (stri5.eq.'sqrt(')  itemp(ieqn)  = isqrt
          if (stri5.eq.'asin(')  itemp(ieqn)  = iasin
          if (stri5.eq.'acos(')  itemp(ieqn)  = iacos
          if (stri5.eq.'atan(')  itemp(ieqn)  = iatan
          if (stri5.eq.'sinh(')  itemp(ieqn)  = isinh
          if (stri5.eq.'cosh(')  itemp(ieqn)  = icosh
          if (stri5.eq.'coth(')  itemp(ieqn)  = icoth
          if (stri5.eq.'tanh(')  itemp(ieqn)  = itanh
          if (stri5.eq.'eins(')  itemp(ieqn)  = jeins
          istr = istr + 3
c# end math operations
c# variables
c          end with blank or math symbol from character string opera
       else
          do 750 i = istr, len(string)
             str1 = string(i:i)
             if (index(opera,str1).ne.0) go to 760
 750      continue
 760      continue
c   find which variable it is:
          ivarln = i - 1
          found = .false.
          if (ivarln.le.istr) ivarln = istr
          do 800 i = 1, nv
             if ( string(istr:ivarln).eq.vnames(i)) then
                found = .true.
                itemp(ieqn)  = i
                istr = ivarln
                go to 810
             end if
 800      continue
 810      continue
c     if it isn't already in vnames, put it in first available slot
          if (.not.found) then
             do 830 i = 1, nv
                if ( vnames(i).eq.' ' ) then
                   vnames(i) = string(istr:ivarln)
                   itemp(ieqn)  = i
                   found = .true.
                   istr  = ivarln
                   go to 840
                end if
 830         continue
 840         continue
          end if
c     if found is still false, then vnames is full.
c     this is then a good time to hurl a warning message.
          if (.not.found) then
             call messag(encerr)
             call messag( ' too many variables declared.')
             write (errmsg,'(14x,2a,i4,a)') 'the current',
     $            ' limit is ', nv,' unique variables.'
             call messag( errmsg )
             ierr = 2
             return
          end if
c
c  # end parsing and encoding, go back to line 300 for more
       end if
       go to 300
c-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
c  some more error checking of string
c-- check that the number of parentheses is correct
 4000  continue
c       do i = 1, maxlen, 3
c          if (itemp(i).ne.0) print*,itemp(i),itemp(i+1),itemp(i+2)
c       end do
       if (iparen.ne.0) then
          call messag(synerr)
          call messag( '     '//strout(1:ilen))
          call messag( '  parentheses are not matched ')
          ierr = 7
          return
       end if
c--
c-- check that one component math functions are followed by "("
c-- and that parentheses are not left hanging
       iparen = 0
       do 4400 i = 1, ieqn + 2
          if (i.eq.1) then
             ibfr = ileft
          else
             ibfr = itemp(i-1)
          end if
          iaft = itemp(i+1)
          it   = itemp(i)
          if (it.eq.ileft)  iparen = iparen + 1
          if (it.eq.iright) iparen = iparen - 1
c-- check that iparen is never negative (that is left parens
c                                        before right parens)
          if (iparen.lt.0) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             call messag( '  parentheses not used properly')
             ierr = 7
             return
          end if
          if ( ( (it.eq.ileft).and.
     $         ( (iaft.eq.iright).or.(ibfr.gt.0) ) )
     $         .or.( (it.eq.iright).and.
     $         ( (iaft.eq.ileft) .or.(iaft.gt.0) ) ) ) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             call messag( '  parentheses not used properly')
             ierr = 7
             return
          end if
c-- check that "(," and ",)" are not in string
          if ( (it.eq.icomma).and.((iaft.eq.iright).or.
     $         (ibfr.eq.ileft).or.(ibfr.eq.icomma))) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             call messag('   ",,", "(," and ",)" are not allowed')
             ierr = 3
             return
          end if
c-- check that one-component math operators are followed by "("
          if ( (it.le.-10).and.(it.ge.-49)) then
             if (iaft.ne.ileft) then
                call messag(synerr)
                call messag( '     '//strout(1:ilen))
                call messag('  unary math functions must be '//
     $               'followed by "("')
                ierr = 5
                return
             end if
             if ( (i.gt.1).and.(ibfr.ge.-49).and.(ibfr.le.-1)
     $            .and.(ibfr.ne.ileft).and.(ibfr.ne.icomma))  then
                call messag(synerr)
                call messag( '     '//strout(1:ilen))
                call messag('  a number is preceded by a '//
     $               'unary math function without using "(" ')
                ierr = 5
                return
             end if
          end if
c--  look for a real number preceded or followed by a
c                    either a real number or a variable
          if ( ((it.ge.300).and.(it.le.600)).and.
     $         ((iaft.ge.1).or.(ibfr.ge.1))) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             if (iaft.ge.0) then
                call messag('  a real number is followed by '//
     $               'a real number, variable or fixed value')
             else
                call messag('  a real number is preceded by '//
     $               'a real number, variable or fixed value')
             end if
             ierr = 3
          end if
          if ((it.ge.1).and.(iaft.ge.-49).and.(iaft.le.-10)) then
             call messag(synerr)
             call messag( '     '//strout(1:ilen))
             call messag('   a number is followed by a'//
     $            ' unary math function')
             ierr = 5
             return
          end if
c
c  the special functions debye(,) and eins(,), etc, require
c  a certain number of commas (usually 1)
          if (it.le.-100)  then
             jstack = 1
             jcomma = 0
             do  4200 j = i+2, ieqn
                jt   = itemp(j)
                if (jt.eq.ileft ) jstack = jstack + 1
                if (jt.eq.iright) jstack = jstack - 1
                if ((jstack.eq.1).and.(jt.eq.icomma))
     $               jcomma = jcomma + 1
                strok = .true.
                if (jstack.eq.0) then
                   strok = .false.
                   if ((it.eq.jdebye).and.(jcomma.ne.1)) then
                      errmsg = ' the function "debye" '//
     $                     'requires 2 arguments and 1 comma'
                      strtmp = ' the proper syntax is: '//
     $                     ' "debye(temp, theta)" '
                   elseif ((it.eq.jeins).and.(jcomma.ne.1)) then
                      errmsg = ' the function "eins" '//
     $                     'requires 2 arguments and 1 comma'
                      strtmp = ' the proper syntax is: '//
     $                     ' "eins(temp, theta)" '
                   elseif ((it.eq.jeins2).and.(jcomma.ne.2)) then
                      errmsg = ' the function "eins2" '//
     $                     'requires 3 arguments and 2 comma'
                      strtmp = ' the proper syntax is: '//
     $                     ' "eins2(temp, theta, mass)" '
                   elseif ((it.eq.jmin).and.(jcomma.ne.1)) then
                      errmsg = ' the function "min" '//
     $                     'requires 2 arguments and 1 comma'
                      strtmp = ' the proper syntax is: '//
     $                     ' "min(x,y)" '
                   elseif ((it.eq.jmax).and.(jcomma.ne.1)) then
                      errmsg = ' the function "max" '//
     $                     'requires 2 arguments and 1 comma'
                      strtmp = ' the proper syntax is: "max(x,y)" '
                   else
                      strok = .true.
                   endif
                   if (.not.strok) then
                      call messag(synerr)
                      call messag( '     '//strout(1:ilen))
                      ii = max(1, istrln(errmsg))
                      call messag('  '// errmsg(1:ii))
                      ii = max(1, istrln(strtmp))
                      call messag('  '// strtmp(1:ii))
                      ierr = 5
                      return
                   end if
                endif
 4200        continue
          end if
 4400  continue
c----------------------------------------------------------------------
c  rewrite itemp to reverse polish notation
c  (this allows easier decoding: see h-p calculator manuals on rpn.)
c  then load up icode, and we're all done.
       j = 0
c        ntemp  = min (ni, maxlen)
c        print*, 'ENCOD 1: ntemp = ', ntemp
c        call rpndmp(itemp,ntemp)

       call engrpn(itemp)
       
c        do i = 1, maxlen
c           if (itemp(i).ne.0) then
c              j = j+1
c              print*, i, j, itemp(i)
c           end if
c        end do
       ntemp  = min (ni, maxlen)
cc       call rpndmp(itemp,ntemp)
       if (itemp(ntemp).ne.0) then
          call messag(mtherr//'too many objects!')
          call messag( '     '//strout(1:ilen))
          write (errmsg,'(4x,a,i4,a)') 'there are more than', ntemp,
     $         ' objects in the math expression for the string: '
          ii  = max(1, istrln(errmsg))
          call messag('  '// errmsg(1:ii))
          call messag('   where objects = operations or numbers')
          call messag('   please break up expression, or contact matt')


          ierr = 9
       end if
       
       do 5000 i = 1, ntemp
          icode(i) = itemp(i)
 5000  continue
       return
c
c end subroutine encod
       end
        subroutine engrpn(icode)
c
c  copyright 1993  university of washington      matt newville
c
c      convert english encoded math code to reverse polish code
c
c      this seems to work fairly well when part of encod, but has
c      some difficulty if the input icode is not completely
c      full of parentheses. the code is not extremely well-tested.
c      it is also a bit repetitve.
c
c strategy:
c    first assign class of operation to each argument in icode.
c    then try to convert all unary minus signs to their correct
c    one-component operator.  next, two component function are
c    put after their two arguments. one component operators are
c    then put after thier argument. finally, all parenthese and
c    commas are dropped.
c---------------------------------------------------------------------
       integer   ileft, iright, icomma, ineg, iy2x
       integer   iadd, isub, imul, idiv, maxlen
       parameter(ileft= -6, iright= -7, icomma= -8, ineg= -20,
     $      iy2x= -54, iadd= -50, isub= -51, imul= -52, idiv= -53)
       parameter(maxlen=1024)
       integer   icode(maxlen),  itemp(maxlen) , idone(maxlen)
       integer   iclass(maxlen), icltmp(maxlen), idtemp(maxlen)
       integer   iclo(6), i, ic, ichi, icn, id, j, j0, k, ksave
       integer   ibfr, istack
       logical   opera
c---------------------------------------------------------------------
c-- initialize itemp, and assign class to objects and operators
c
       do 10 j = 1, maxlen
           i = icode(j)
           if (i.eq.0)                      iclass(j) = 0
           if (i.gt.0)                      iclass(j) = 1
           if ((i.le.-10).and.(i.ge.-49))   iclass(j) = 2
           if ((i.eq.iadd) .or.(i.le.isub)) iclass(j) = 3
           if ((i.eq.imul) .or.(i.le.idiv)) iclass(j) = 4
           if (i.eq.iy2x)                   iclass(j) = 5
           if (i.le.-80)                    iclass(j) = 6
           if (i.eq.ileft)                  iclass(j) = 7
           if (i.eq.iright)                 iclass(j) = 8
           if (i.eq.icomma)                 iclass(j) = 9
           itemp(j) = icode(j)
           icltmp(j) = iclass(j)
  10    continue
c---------------------------------------------------------------------
c-- convert unary minus and plus signs to unitary operators
c-- plus signs are easy: simply remove the plus sign.
c-- minus signs are hard: find next operator on this level,
c-- and convert  "- x1" to  "neg ( x1 )", which will then be
c-- converted down below to "x1 neg".
       do 500 j0 = 1, maxlen
          j = j0
 100      continue
          i  = itemp(j)
          ic = icltmp(j)
          if(ic.eq.0) go to 510
          ibfr = 0
          if (j.gt.1)      ibfr = iclass(j-1)
c-- unary plus sign
          if ( ((j.eq.1).or.(ibfr.eq.7).or.(ibfr.eq.4).or.(ibfr.eq.5)
     $         .or.(ibfr.eq.9))    .and.(i.eq.iadd)  )  then
             do 120  k = j, maxlen-1
                icode(k)  = itemp(k+1)
                iclass(k) = icltmp(k+1)
 120         continue
             icode(maxlen)  = 0
             iclass(maxlen) = 0
             do 130  k = j, maxlen
                itemp(k)  = icode(k)
                icltmp(k) = iclass(k)
 130         continue
             go to 100
c-- unary minus sign
c--  change minus sign to unary operator
c--     if next object is (, then we're done.
c--     otherwise, ... - x ... -> ... neg ( x ) ...
          elseif ( ((j.eq.1).or.(ibfr.eq.7).or.(ibfr.eq.9).or.
     $            (ibfr.eq.4).or.(ibfr.eq.5)).and.(i.eq.isub)) then
c  replace '-' with 'neg'
             icode(j)  = ineg
             iclass(j) = 2
c neg number : find next +-,) or end of line, and insert parentheses.
             if (iclass(j+1).eq.1) then
                icn   =  icltmp(j+1)
                opera = (icn.eq.9).or.(icn.eq.8).or.(icn.eq.0)
     $               .or.(icn.eq.3)
c
                if (.not.opera) then
                   istack = 0
                   k      = j
 140               continue
                   k = k + 1
                   if (k.ge.maxlen) go to 150
                   icn   =  icltmp(k)
                   opera =  (icn.eq.9).or.(icn.eq.8).or.(icn.eq.0)
     $                  .or.(icn.eq.3)
                   if ( (istack.eq.0) .and.opera) go to 150
                   if (icn.eq.7) istack = istack + 1
                   if (icn.eq.8) istack = istack - 1
                   go to 140
 150               continue
                   ksave = k -1
c  insert left paren
                   icode(j+1)  = ileft
                   iclass(j+1) = 7
c  bump everything after left paren up by 1
                   do 170  k = j+2, ksave + 1
                      icode(k)  = itemp(k-1)
                      iclass(k) = icltmp(k-1)
 170               continue
c  insert right paren
                   icode(ksave+2)  = iright
                   iclass(ksave+2) = 8
c  bump everything after right paren up by 2
                   do 180  k = ksave+3, maxlen-2
                      icode(k)  = itemp(k-2)
                      iclass(k) = icltmp(k-2)
 180               continue
                end if
c
c neg unary operator : need to find end of argument of operator.
c       then change '-' -> neg and insert parens.
             elseif (((iclass(j+1).eq.2).or.(iclass(j+1).eq.6))
     $               .and.(iclass(j+2).eq.7)) then
c  find end of argument
                istack = 1
                do 200 k = j+3, maxlen
                   if (icltmp(k).eq.7) istack = istack + 1
                   if (icltmp(k).eq.8) istack = istack - 1
                   if (istack.eq.0) go to 220
 200            continue
 220            continue
                ksave = k
c  insert left paren
                icode(j+1)  = ileft
                iclass(j+1) = 7
c  bump everything after left paren up by 1
                do 250  k = j+2, ksave + 1
                   icode(k)  = itemp(k-1)
                   iclass(k) = icltmp(k-1)
 250            continue
c  insert right paren
                icode(ksave+2)  = iright
                iclass(ksave+2) = 8
c  bump everything after right paren up by 2
                do 280  k = ksave+3, maxlen-2
                   icode(k)  = itemp(k-2)
                   iclass(k) = icltmp(k-2)
 280            continue
             end if
             do 380 k = 1, maxlen
                itemp(k) = icode(k)
                icltmp(k) = iclass(k)
 380         continue
             j = j - 1
             if (j.eq.0) j = 1
             go to 100
          end if
c reset itemp and icltmp and go back to beginning
 500   continue
 510   continue
c
       do 600 i = 1, maxlen
          icode(i) = itemp(i)
          iclass(i) = icltmp(i)
 600   continue
c---------------------------------------------------------------------
c-- convert class 5 operators (^ only):
c   x1 ^ x2  -> x1 x2 ^
c    if operator is '^', and is not already followed by ',)+-*/^',
c    then find next place with stack=0 (that is on the current level),
c    that contains an ',)+-*/^'
       ichi = 5
       iclo(1) =  9
       iclo(2) =  8
       iclo(3) =  0
       iclo(4) =  3
       iclo(5) =  4
       iclo(6) =  5
       call class(icode, iclass, ichi, iclo)
c---------------------------------------------------------------------
c-- convert class 4 operators (* and / only):
c   x1 * x2  -> x1 x2 *
c    if operator is '*/', and is not already followed by ',)+-*/',
c    then find next place with stack=0 (that is on the current level),
c    that contains an ',)+-*/'
c  undo iclo(6) = '^' to a repeat of iclo(3) = 0
       ichi    =  4
       iclo(6) =  0
       call class(icode, iclass, ichi, iclo)
c---------------------------------------------------------------------
c-- convert class 3 operators (+ and - only):
c   x1 + x2  -> x1 x2 +
c    if operator is '+-', and is not already followed by ',)+-',
c    then find next place with stack=0 (that is on the current level),
c    that contains an ',)+-'
c  undo iclo(5) = '*/' to a repeat of iclo(3) = 0
       ichi    =  3
       iclo(5) =  0
       call class(icode, iclass, ichi, iclo)
c
       do 900 i = 1, maxlen
          itemp(i) = icode(i)
          icltmp(i) = iclass(i)
 900   continue
c
c---------------------------------------------------------------------
c-- convert class 2 and class 6 operators.
c   all unary operators and special functions have the syntax:
c        f(x1, x2, x3, ...) -> (x1, x2, x3, ...) f
       do 6900 j = 1, maxlen
          idone(j) = 0
          idtemp(j) = 0
 6900  continue
       do 8000 j0 = 1, maxlen - 1
          j  =  j0
 7000     continue
          i  =  itemp(j)
          ic =  icltmp(j)
          id =  idtemp(j)
          if(ic.eq.0) go to 8010
          if ( (id.eq.0).and.
     $         ( (ic.eq.2).or.(ic.eq.6)).and.(iclass(j+1).eq.7)) then
             istack = 1
             do 7200 k = j+2, maxlen
                if (icltmp(k).eq.7) istack = istack + 1
                if (icltmp(k).eq.8) istack = istack - 1
                if (istack.eq.0) go to 7300
 7200        continue
 7300        continue
             ksave = k
             icode(ksave)   = itemp(j)
             iclass(ksave)  = icltmp(j)
             idone(ksave)   = 1
             do 7500  k = j, ksave-1
                icode(k)  = itemp(k+1)
                iclass(k) = icltmp(k+1)
                idone(k)  = idtemp(k+1)
 7500        continue
c     reset itemp and start over again at the same place
             icode(maxlen-1) = 0
             icode(maxlen)   = 0
             idone(maxlen-1) = 0
             idone(maxlen)   = 0
             do 7800 k = 1, maxlen
                itemp(k)  = icode(k)
                icltmp(k) = iclass(k)
                idtemp(k) = idone(k)
 7800        continue
             go to 7000
          end if
 8000  continue
 8010  continue
c---------------------------------------------------------------------
c-- finally, remove all parentheses and commas for icode
       j = 0
       k = 0
       do 8900 i = 1, maxlen
          itemp(i)  = icode(i)
          icltmp(i) = iclass(i)
          icode(i)  = 0
          iclass(i) = 0
 8900  continue
 9000  continue
       j = j + 1
       if (j.gt.maxlen) go to 9100
       ic = icltmp(j)
       if (ic.eq.0) go to 9100
       if ( (ic.ne.7).and.(ic.ne.8).and.(ic.ne.9)) then
          k = k + 1
          icode(k)  = itemp(j)
          iclass(k) = icltmp(j)
       end if
       go to 9000
9100   continue
       return
c end subroutine engrpn
       end
       subroutine parins(strin, ilen , sopt1, sopt2)
c
c  copyright 1993  university of washington      matt newville
c
c  insert parentheses in a string for a fortran math expression
c  to give the normal math precedence :
c          "sopt1" is more important than "sopt2"
c  this gets kind of ugly but appears to never fail.
c--------------------------------------------------------------------
       integer     mstack,i, ilen, j, istart, istack, iopt, ioptst
       parameter ( mstack = 32)
       character*(*) strin, sopt1, sopt2
       character*2048 string, dummy, str1*1, operas*4, digits*10
       logical       paren(mstack)
       integer       idiff, jstk, i1, i2, io, ieon, nbrstr
       integer       iopen(mstack),  istrln
       external      istrln, nbrstr
       data operas, digits / '*/+-', '0123456789'/
c insert a leading blank, initialize stack control and parentheses
       iopt = 0
       dummy = ' '
       dummy(2:ilen+1 ) = strin(1:ilen)
       string = dummy
       istart = 1
       istack = 1
       do 50 i = 1, mstack
          iopen(i)  = 1
          paren(i)  = .false.
 50    continue
 100   continue
       ilen = istrln(string) + 2
       ieon = istart - 1
       do 200 i = istart, ilen
c get current character
c check for exponentiation or parens, update stack index
c and insert parens if they aren't there already
c  note that numbers (found with nbrstr) are skipped over
         str1 = string(i:i)
          if (i.le.ieon) go to 199
          if (index( digits, str1 ).ne.0 ) then
             ieon = i + nbrstr(string(i:))
          elseif (index(sopt1,str1).ne.0) then
             iopt = i
             paren(istack) = .true.
          elseif (str1.eq.'(') then
             istack = istack + 1
             if (istack.gt.mstack) istack = mstack
             iopen(istack) = i
          elseif (str1.eq.')') then
             istack = istack - 1
             if (istack.lt.1) istack = 1
          elseif (index(sopt2, str1 ).ne.0 ) then
             ioptst = i - iopt
             if ( paren(istack)) then
                paren(istack) = .false.
c     normal case: find a far away operation
                if (ioptst.gt.1) then
                   istart = i + 2
                   io = iopen(istack)
                   idiff = i - io
                   if (idiff.gt.1) then
                      dummy = ' '
                      dummy = string(1:io)//'('//
     $                        string(io+1 :i-1)//')'//string(i:)
                      string = dummy
                   end if
c     non-normal case: operation immediately after '^'
                else
                   jstk = 0
                   do 170 j = i + 1, ilen - 2
                      str1 = string(j:j)
                      if (str1.eq.'(') then
                         jstk = jstk + 1
                      elseif (str1.eq.')') then
                         jstk = jstk - 1
                      elseif ( (jstk.eq.0) .and.
     $                        (index(operas,str1).ne.0)) then
                         go to 180
                      end if
 170               continue
 180               continue
                   dummy = ' '
                   dummy = string(:i-1)//'('//string(i: j-1)
     $                  //')'//string(j:)
                   string = dummy
                end if
                go to 100
             else
                iopen(istack) = i
             end if
          end if
 199      continue
 200   continue
c     if needed, insert a last set of parens at the end
       if ( paren(1).and.(iopen(1).ne.1)) then
          i1 = iopen(istack)
          i2 = istrln(string) + 1
          dummy  = ' '
          dummy  = string(1:i1)//'('//
     $         string(i1+1:i2-1)//')'//string(i2:)
          string = dummy
       end if
       call triml(string)
       strin = string
       ilen  = istrln(string)
300    continue
       return
c end soubroutine parins
       end
      subroutine parens(string)
c
c  copyright 1993  university of washington      matt newville
c  insert parentheses in a string for a fortran math expression
c  to give the normal math precedence :
c   ^   before   *,/,+,-          and  *,/    before   +,-
c  also:  ** is replaced by ^
c
c  this calls parins, which does the real work of inserting parens.
c--------------------------------------------------------------------
       character*(*) string,  strtmp*2048
       integer       i, ilen, istrln
       external      istrln
c
c  first replace '**' with '^ '
       strtmp = string
       ilen = max(2, istrln(strtmp))
       do 10 i = 1, ilen-1
          if (strtmp(i:i+1).eq.'**') then
             strtmp(i:i+1) = '^ '
          end if
 10    continue
       call unblnk(strtmp)
       ilen = istrln(strtmp)
       if ((strtmp.ne.' ').and.(ilen.gt.0)) then
c
c then put parentheses in to make sure that exponentiation is
c done before multiplication, division, addition, or subtraction.
          if (index(strtmp,'^').ne.0)
     $         call parins(strtmp,ilen,'^','*/+-')
c
c then put parentheses in to make sure that multiplication and
c division are done before addition and subtraction.
          if ((index(strtmp,'*').ne.0).or.(index(strtmp,'/').ne.0))
     $         call parins(strtmp,ilen,'*/','+-')
c
c   put new string into output and return
       endif
       string = strtmp
       return
c end subroutine parens
       end
        subroutine class(icode, iclass, ichi, iclo)
c
c    copyright 1993  university of washington   matt newville
c
c    this is a subroutine of engrpn. operators are moved around
c    to convert english math to reverse polish.
c    if operator is of class icin, and is not already followed by
c    an operator with class in iclo,  then find next place with
c    stack=0 (that is on the current level), that contains an
c    operator with class in iclo
c---------------------------------------------------------------------
       integer i, maxlen, j0, ksave, ic, icn, j, k, istack
       parameter(maxlen =1024)
       integer icode(maxlen),  iclass(maxlen), ichi , iclo(6)
       integer itemp(maxlen),  icltmp(maxlen)
       logical opera
       do 100 i = 1, maxlen
          itemp(i)  = icode(i)
          icltmp(i) = iclass(i)
  100  continue
       do 2000 j0 = 1, maxlen - 1
          j  =  j0
  500     continue
          ic =  icltmp(j)
          if (ic.eq.0) go to 2010
          if (ic.eq.ichi) then
             icn   =  icltmp(j+1)
             opera = .false.
             do 550 i = 1, 6
                if  ( icn.eq.iclo(i)) opera = .true.
 550         continue
             if (.not.opera) then
                istack = 0
                k      = j
 600            continue
                   k = k + 1
                   if (k.ge.maxlen) go to 700
                   icn   =  icltmp(k)
                   opera = .false.
                   do 650 i = 1, 6
                      if  ( icn.eq.iclo(i)) opera = .true.
 650               continue
                   if ( (istack.eq.0) .and. opera) go to 700
                    if (icn.eq.7) istack = istack + 1
                   if (icn.eq.8) istack = istack - 1
                   go to 600
 700            continue
                ksave = k -1
                icode(ksave)   = itemp(j)
                iclass(ksave)  = icltmp(j)
                do 1000  k = j, ksave-1
                   icode(k)  = itemp(k+1)
                   iclass(k) = icltmp(k+1)
1000            continue
c     reset itemp and start over again at the same place
                icode(maxlen-1) = 0
                icode(maxlen)   = 0
                do 1200 k = 1, maxlen
                   itemp(k) = icode(k)
                   icltmp(k) = iclass(k)
1200            continue
                go to 500
             end if
          end if
2000   continue
2010   continue
c finish it up
       do 3000 i = 1, maxlen
          icode(i) = itemp(i)
          iclass(i) = icltmp(i)
3000   continue
c
      return
c end subroutine class
      end
      integer function nbrstr(string)
c
c  find a number in a string
c  given a string that is known to begin with a digit or sign.
c  return the position of the end of the number.
c  nbrstr : position of end of number
      integer   istrln, i, ilen, iback
      character*(*)  string
      character*1    digit*10, plus, minus, d, e, decml, s, sp
      logical     lexp, ldecml
      data digit  /'1234567890'/
      data minus,plus,d,e,decml /'-','+','d','e','.'/
c------
      ldecml = .false.
      lexp   = .false.
      ilen   = istrln(string)
      nbrstr = ilen
      if (ilen.gt.1) then
         iback  = 1
c find end of number :  digits are always ok.
c stop at second d, e, decml, or sign that's not preceded by (d,e)
         do 200 i = 2, ilen
            sp = string(i-1:i-1)
            s  = string(i:i)
            if (index(digit,s).eq.0) then
               if ( (((s.ne.plus).and.(s.ne.minus).and.(s.ne.d)
     $                 .and.(s.ne.e).and.(s.ne.decml)))
     $          .or.((lexp.and.((s.eq.d).or.(s.eq.e))))
     $          .or.((ldecml.and.(s.eq.decml)))
     $          .or.((((s.eq.plus).or.(s.eq.minus)).and.
     $                (sp.ne.d).and.(sp.ne.e))) )     go to 210
               lexp   = lexp.or.(s.eq.d).or.(s.eq.e)
               ldecml = ldecml.or.(s.eq.decml)
            end if
 200     continue
         iback = 0
 210     continue
         nbrstr = i - 1 - iback
      end if
      return
c  end function nbrstr
      end
       subroutine fitdat
c
c      this routine reads the input data files for feffit.
c
c    - if given, each data file will be opened and the chi(k)
c      data and documentation will be read with the routine inpdat.
c    - all the numbers for qmin, qmax, rmin, rmax, etc. are also
c      set here, using defaults from the values in the data files.
c    - as the data is read in, it is interpolated here onto a evenly
c      spaced k grid ( with dk = qgrid = 0.05).
c    - if backgound removal is requested, the number of knots in the
c      spline will be found and set here, rmin will be used as rbkg,
c      and the fit will be done on r=[0,rmax]. the variables for the
c      spline coeffs will be added to the end of the variable list,
c      so that the first nvuser variables will be those explicitly
c      "guess"ed, and the rest (numvar-nvuser) will be those implicitly
c      guessed by asking for background removal.
c    * the feffnnnn.dat files will be read in fefinp.
c
c      copyright 1993 university of washington         matt newville
c
c----------------------------------------------------------------------
cc       implicit  none
c  common blocks for feffit
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c---------------------------------------------------------------------
       character*10  ftype, frmtmp, strtmp*128
       character*100 docb(maxdoc)
       real          qtemp(maxpts), chitmp(maxpts), rrmmax
       real          qbtemp(maxpts), bkgtmp(maxpts), qrange
       real          tmp1(maxpts), tmp2(maxpts), tmp3(maxpts)
       real          drinfo(mdata) , xlog2, percnt, two, rsmall
       real          drmin, q, qsmall, xexpo, dr_1k, rgrid
       real          xqmin, xqmax
       integer       mftmin, id, ilen, istrln, isky, ist, ndocb
       integer       nexpo, nrmin, nrmax,  ntmp, ii, iv
       integer       nbkgf, ipos, iposb, i,  nq1st, nqmin, nqmax
       parameter     (xlog2 = 0.69314718056, percnt = 0.01, two = 2.)
       parameter  (xqmin = 20., xqmax = 35.)
c-----------------------------------------------------------------------
c   drmin is used as the spacing in r-space to use in the fit,
c   and so dictates the number of points to use in the fit fft (mftwrt)
c   the smallest mftfit used will be 256
       mftmin = 256
       drmin  = pi/( qgrid * mftmin)
c----------------------------------------------------------------------
c  open data files and get chi data
       do 500 id = 1, ndata
          ftype     = 'chi'
          nchi(id)  = maxpts
          q1st(id)  = qgrid
          qlast(id) = 30.
          if (datain(id)) then
             ndoc(id) = maxdoc - 1
             call inpdat(ftype, frminp, chifil(id), vaxflg, skey(id),
     $            nkey(id), ndoc(id), doc(1,id), nchi(id),
     $            qtemp, chitmp, tmp1, tmp2, tmp3)
c
c  write output message that this file was successfully read
             ilen = max(1, istrln( chifil(id)))
             call smcase(frminp, 'a')
             messg = chifil(id)(1:ilen)
             strtmp = ' '
             if (frminp(1:2).eq.'uw') then
                if (skey(id).ne.' ') then
                   isky  = max(1, istrln(skey(id)))
                   if (nkey(id).ne.0) then
                      strtmp = ' , '//skey(id)(1:isky)
                   else
                      write (strtmp, 9010) nkey(id), skey(id)(1:isky)
                   endif
                elseif (nkey(id).ne.0) then
                   write (strtmp, 9015) nkey(id)
                endif
             endif
             ist = istrln(strtmp)
             if (ist.ge.1) call append(messg, ' '//strtmp(:ist) ,ilen)
             call messag( '        '//messg(1:ilen))
c
c  if a bkg(k) file was specified, subtract this from the chi(k) data
             if (bkgdat(id)) then
                ndocb = maxdoc - 1
                ftype   = 'chi'
                nbkgf    = maxpts
                frmtmp = ' '
                call inpdat(ftype, frmtmp, bkgfil(id), vaxflg,
     $               skeyb(id), nkeyb(id), ndocb, docb(1),
     $               nbkgf, qbtemp, bkgtmp, tmp1, tmp2, tmp3)
c
c  write output message that this file was successfully read
                ilen = max(1, istrln( bkgfil(id)))
                call smcase(frmtmp, 'a')
                messg = bkgfil(id)(1:ilen)
                strtmp = ' '
                if (frmtmp(1:2).eq.'uw') then
                   if (skeyb(id).ne.' ') then
                      isky  = max(1, istrln(skeyb(id)))
                      if (nkeyb(id).ne.0) then
                         strtmp = ' , '//skeyb(id)(1:isky)
                      else
                         write(strtmp,9010) nkeyb(id),
     $                        skeyb(id)(1:isky)
                      endif
                   elseif (nkeyb(id).ne.0) then
                      write(strtmp, 9015) nkeyb(id)
                   endif
                endif
                ist = istrln(strtmp)
                if (ist.ge.1)
     $               call append(messg,' '//strtmp(:ist),ilen)
                call messag( '              '//messg(1:ilen))
             end if
c  put chi data into single array, chiq, on qgrid spacing,
c  starting at q = qgrid : linear interpolation
             ipos      = 1
             iposb     = 1
             q1st(id)  = max(qgrid, qtemp(1))
             qlast(id) = qtemp(nchi(id))
             if ((q1st(id).ge.xqmin).or.(qlast(id).ge.xqmax)) then
                imsg = -1
                if (chkdat)  imsg = 1
                call finmsg(3010,' ',' ',imsg)
             end if
             do 150 i = 1, maxpts
                q = (i-1)*qgrid
                if ( (q.lt.q1st(id)).or.(q.gt.qlast(id))) then
                   chiq(i,id) = zero
                else
                   call qintrp( qtemp, chitmp, nchi(id), q,
     $                  ipos, chiq(i,id))
                   if (bkgdat(id)) then
                      call qintrp( qbtemp, bkgtmp, nbkgf, q,
     $                     iposb, bkgq(i,id))
                      chiq(i,id) = chiq(i,id) - bkgq(i,id)
                   end if
                end if
 150         continue
          end if
c
c  recover from incomplete inputs
          if (((outfil(id).eq.' ').or.(outfil(id).eq.'xxfitxx'))
     $        .and.(chifil(id).ne.' ')) outfil(id) = chifil(id)
c
c
c miscellaneous fiddling with input numbers:
c     find maximum path index
c     put q1st, qmin, qmax on qgrid, etc.
c     calculate number of points in various ranges
c-- put q1st, qmin, qmax on qgrid, get nqpts
          qsmall    = qgrid * percnt
c q1st
          nq1st     = int( (q1st(id) + qsmall) / qgrid)
          q1st(id)  = qgrid * nq1st
c qmin : make sure it is on the data range and larger than qgrid
          nqmin     = max(1, int( (qmin(id) + qsmall) / qgrid))
          qmin(id)  = max(qgrid * nqmin, q1st(id))
c qmax : truncate nqmax
          nqmax     = int( (qmax(id) + qsmall) / qgrid)
          qmax(id)  = qgrid * nqmax
          if (qmax(id).le.qmin(id))  then
             qmax(id) = qlast(id)
          else
             qmax(id) = min(qmax(id), qlast(id))
          end if
c nqpts, nqfit
          nqpts(id) = nqmax - nqmin + 1
          nqfit(id) = int( ( qlast(id) + qsmall + two) / qgrid )
cc          print*, ' mid fitdat:  '
cc          print*, q1st(1),qmin(1),qmax(1), qlast(1), nqpts(1), nqfit(1)
c
c-- r values (mostly in next loop)
          if (rmax(id).le.rmin(id))    rmax(id)  = rmin(id)
c
c define drinfo as spacing between independent points in r-space
c and keep smallest drinfo found so far
          drinfo(id) = pi / ( qmax(id) - qmin(id) )
          drmin      =  min(drmin, drinfo(id))
c
c done with this data set, for now
 500   continue
c----------------------------------------------------------------------
c  get mftfit (number of points for fit in fft range)
c  as the smallest power of 2 available :
c  drmin gives the smallest value, now we just round so that mftfit
c  is 2**n  with  8 <= n <= 11 .
c
       if (mftfit.le.0) then
          mftfit = 1024
          dr_1k  = pi/(qgrid * mftfit)
          if (drmin.le.dr_1k)    mftfit = 1024
       else
          xexpo  = log ( float (mftfit)) / xlog2
          nexpo  = min(11, max(8, nint(xexpo)) )
          mftfit = 2**nexpo
       end if
cc       print*, ' fitdat - mftfit = ', mftfit
c
c  now reset all r-ranges to be on the r-rgrid defined by mftfit
c  calculate # of independent points in data range
c    and keep running total
       rgrid  = pi/( qgrid * mftfit)
ccc       print*, ' fitdat #2  -  rgrid = ', rgrid
       rsmall = rgrid * percnt
       do 700  id  = 1, ndata
          nrmin     = int( (rmin(id) + rsmall) / rgrid )  + 1
          nrmax     = int( (rmax(id) + rsmall) / rgrid )
          if (nrmax.le.nrmin) nrmax = nrmin + 1
          nrpts(id) = nrmax - nrmin + 1
          rmax(id)  = rgrid * nrmax
          rmin(id)  = rgrid * nrmin
          if (bkgfit(id)) then
             rbkg(id) = rgrid * nrmin
             rmin(id) = zero
          end if
          xinfo(id) = two * (one + ((rmax(id)-rmin(id)) / drinfo(id)))
c
c  if bkg removal is requested, figure out how many spline knots to
c  use, where to put them, and add these knots to the variable list.
          if (bkgfit(id)) then
c
c-bkg how many splines
             nbkg(id) = 1 + 2 * int( rbkg(id) / drinfo(id) )
             nbkg(id) = min(mtknot-korder-1, max(korder+1, nbkg(id)))
c-bkg where to put knots
             do 600 i = 1, korder
                qknot(i,id)          = qmin(id) - (korder-i) * qgrid
                qknot(nbkg(id)+i,id) = qmax(id) + (i-1) * qgrid
 600         continue
             qrange = qmax(id) - qmin(id)
             ntmp   = nbkg(id) - korder + 1
             do 620 i = korder+1, nbkg(id)
                qknot(i, id) = qmin(id) + (i-korder)*qrange/ntmp
 620         continue
c-bkg add spline coefs to the variable list, initialize to zero
             do 640  ii = 1, maxval
                if  (vnames(ii).eq.' ') go to 650
 640         continue
 650         continue
             iv = ii - 1
             do 680  i = 1, nbkg(id)
                numvar  = numvar + 1
                iv      = iv + 1
                if (numvar.gt.mvarys) call finmsg(3020,' ',' ',mvarys)
                if (iv.gt.maxval)     call finmsg(3040,' ',' ',maxval)
                xguess(numvar)= zero
                write(vnames(iv), 660)  '_bkg_#',id,'_',i
 660            format (a,i2.2,a,i2.2)
                icdval(1,iv)   = -1
 680         continue
          endif
c
c  figure out amount of information for this data set, and add to total
c  note: if rmin=0. we're doing bkg subtraction - there is only
c        one piece of information at r=0. at r > 0, the information
c        comes in pairs.
          xnidp  = xnidp + xinfo(id)
c
c finally, make the qwindo and rwindo (ie, the fft widnows)
c  for this data set.
c
          call window(maxpts, iqwin(id), qwin1(id),
     $         qwin2(id), qmin(id), qmax(id), qgrid, qwindo(1,id) )

          call window(maxpts, irwin(id), rwin1(id),
     $         rwin2(id), rmin(id), rmax(id), rgrid, rwindo(1,id) )
c
 700   continue
       if (xinfo(1).lt.two) xinfo(1) = two
       if (xnidp.lt.two)    xnidp    = two
       inform  = int(xnidp)
c
c now set mftwrt to  2**n , with (8.le.n.le.11)
       if (mftwrt.le.0) mftwrt = maxpts
       if (mftwrt.ne.maxpts) then
          xexpo  = log ( float (mftwrt)) / xlog2
          nexpo  = min(11, max(8, nint(xexpo)) )
          mftwrt = 2**nexpo
       end if
c
c make sure rlast is smaller than 10pi = pi/2/qgrid
       rrmmax = (pi/two) / qgrid
       if (rlast.gt.rrmmax) rlast = rrmmax
cc       print*, ' end  of fitdat:  '
cc       print*, q1st(1), qmin(1), qmax(1), qlast(1), nqpts(1)
       return
c end subroutine fitdat
 9010  format (a, ' , ', i4, ' (', a,')' )
 9015  format (a, ' , ', i4 )
       end
c----------------------------------------------------------------------
c          input/output routines for data files
c               for the uwxafs programs
c
c   input/output routines for data files for the uwxafs programs
c
c   copyright 1992  university of washington, seattle, washington
c   written by      matthew newville
c                   department of physics, fm-15
c                   university of washington
c                   seattle, wa   usa 98195
c   phone           (206) 543-0435
c   e-mail          newville@u.washington.edu
c
c  these routines are the basic input/output routines for getting
c  numerical and document data from files into the uwxafs programs.
c  there are currently two data formats supported:
c
c 1. 'uw' :  a binary file format known as the uwxafs file handling
c            routines. this is very efficient way to store data, and
c            can store several (191) data sets in a single file. the
c            drawback is that the files are not extremely portable.
c
c 2. 'asc':  these are column files in a format that is fairly easy
c            for anything to deal with. the files have several lines
c            of documents. if the first character of the document is
c            '#' this character will be removed. after the documents
c            is a line with minus signs for characters(3:6), then an
c            ignored line (for column labels), and then the data. up
c            to five columns are used. the expected order is:
c                  x, real(y), imag(y), ampl(y), phase(y).
c            if any column representing y is zero, the appropriate
c            value will be calculated and returned. the files in this
c            format hold only one data set, and use more memory than
c            the uwxafs files, but are portable and convenient.
c
c  other file types can be added without too much difficulty.
c  the routines listed here are:
c      inpdat : retrieve data and documents from a file
c      inpcol : retrieve data and documents from an ascii file
c      inpuwx : retrieve data and documents from a uwxafs file
c      outdat : write data and documents to a file
c      outcol : write data and documents to an ascii file
c      outuwx : write data and documents to a uwxafs file
c
c  note: the fortran input/output unit number 11 is used for all
c        unit numbers in these routines. conflicts between these
c        routines will not happen, but conflicts may arise if
c        unit = 11 indicates an open file in a calling subprogram.
c----------------------------------------------------------------------
       subroutine inpdat(filtyp, format, filnam, vax, skey, nkey,
     $       ndoc, doc, ndata, xdata, yreal, yimag, yampl, yphas )
c
c   copyright 1992  university of washington :          matt newville
c
c    retrieve data and documents from a file acording
c    to the format specified by 'format'.
c inputs:
c   filtyp    file type to open. if may be ' '
c   format    file format (uwxafs, ascii, column)
c   filnam    file name
c   vax       logical flag for being on a vax machine (binary file)
c   skey      symbolic key for record in uwxafs file
c   ndata     maximum number of elements in data arrays
c   nkey      numeric key for record in uwxafs file
c   ndoc      maximum number of document lines to get
c               note:   ndoc cannot be less than or equal to zero!
c outputs:
c   skey      symbolic key of record in uwxafs file
c   ndoc      number of document lines returned
c   doc       array of document lines
c   ndata     number of elements in data arrays
c   xdata     array of x values of data
c   yreal     array of real part of y data values
c   yimag     array of imaginary part of y data values
c   yampl     array of amplitude part of y data values
c   yphas     array of phase part of y data values
c---------------------------------------------------------------------
       character*(*)  filtyp, format, skey, filnam, doc(*)
       character*10   type, symkey, form, formin, errmsg*128
       dimension      xdata(*), yreal(*), yimag(*)
       dimension      yampl(*), yphas(*)
       logical        vax
       integer        irecl, ndatmx, ndocmx
       data  irecl, ndocmx, ndatmx  / 512 , 19, 4096/
c---------------------------------------------------------------------
c some initializations
       if (vax) irecl = 128
       type = filtyp
       call triml(type)
       call upper(type)
       symkey = skey
       call triml(symkey)
       call upper(symkey)
c
c determine format of the input file
       formin = format
       call triml(formin)
       call smcase(formin, 'a')
       call testrf(filnam, irecl, form, ier)
       call smcase(form, 'a')
       if (ier.eq.-1) then
          call messag('  inpdat error: file not found  ')
       elseif (ier.eq.-2) then
          call messag('  inpdat error: unknown file format = '//formin)
       elseif (ier.eq.-3) then
          call messag('  inpdat error: poorly formatted ascii data?  ')
       elseif (ier.eq.-4) then
          call messag('  inpdat error: no data in ascii format file? ')
       end if
       if (ier.ne.0) then
          errmsg =    '    for file ' // filnam
          ilen   = istrln(errmsg)
          call messag( errmsg(1:ilen) )
          stop
       endif
       if ((formin.ne.' ').and.(formin(1:2).ne.form(1:2))) then
          call messag('  inpdat warning: the requested format was'//
     $         ' incorrect!')
          call messag('  form    = '//form(1:5)  )
          call messag('  formin  = '//formin(1:5)  )
       end if
c  now call the appropriate routine to get the data,
c  according to the format.
       ndata = max(1, min(ndata, ndatmx) )
       ndoc  = max(1, min(ndoc , ndocmx) )
       if (form(1:2).eq.'uw') then
          ndoc = ndocmx
          call inpuwx(type, filnam, skey, nkey, irecl, ndoc, doc,
     $         ndata, xdata, yreal, yimag, yampl, yphas )
       elseif ((form(1:2).eq.'co').or.(form(1:2).eq.'as')) then
          call inpcol(filnam, ndoc, doc,
     $         ndata, xdata, yreal, yimag, yampl, yphas )
          skey   = 'ascii'
          call upper(skey)
       else
          call messag('  inpdat error: unknown file format = '// form)
          ilen   = min(54, max(1, istrln(filnam)))
          errmsg = '                for file ' // filnam(1:ilen)
          call messag( errmsg(1:ilen+26) )
          stop
       end if
       filtyp = type
       format = form
c
       return
c end subroutine inpdat
       end
       subroutine inpcol(filnam, ndoc, doc, ndata,
     $                   xdata, yreal, yimag, yampl, yphas)
c
c   copyright 1992  university of washington :       matt newville
c
c   open and get all information from a column file. document
c   lines are read until a line of '----', then a label line is
c   skipped and the column data are read in.  the data is read
c   and stored in the following order:
c                xdata  yreal  yimag  yampl  yphas
c inputs:
c   filnam    file name containing data
c   ndoc      maximum number of document lines to get
c   ndata     maximum number of elements in data arrays
c outputs:
c   ndoc      number of document lines returned
c   doc       array of document lines
c   ndata     number of elements in data arrays
c   xdata     array of x values of data
c   yreal     array of real part of y data values
c   yimag     array of imaginary part of y data values
c   yampl     array of amplitude part of y data values
c   yphas     array of phase part of y data values
c---------------------------------------------------------------------
       integer   ilen , istrln, j, i, mxword, ndoc, ndata, iounit
       integer   iexist, ierr, nwords, idoc, id
       real      zero , small
       parameter( zero = 0.e0 , small = 1.e-6, mxword = 5)
       real      xdata(*), yreal(*), yimag(*), yampl(*), yphas(*)
       real      xinp(mxword)
       logical   isdat
       character*(*) filnam, doc(*)
       character*30  words(mxword), line*100, status*10, file*128
       external      istrln, isdat
c---------------------------------------------------------------------
 10    format(a)
       file = filnam
       ilen = istrln(file)
       if (ilen.le.0)  then
           call messag( ' inpcol:  no file name given')
           stop
       end if
c  initialize buffers
       do 80 j = 1, ndoc
          doc(j) = ' '
  80   continue
       do 100 i = 1, mxword
          words(i) = '0. '
          xinp(i)  = zero
 100   continue
       do 120 j = 1, ndata
          xdata(j) = zero
          yreal(j) = zero
          yimag(j) = zero
          yampl(j) = zero
          yphas(j) = zero
 120   continue
c  open data file
      iounit = 7
      status ='old'
      call openfl(iounit, filnam, status, iexist, ierr)
      if ((iexist.lt.0).or.(ierr.lt.0)) go to 900
c
c  get documents from header: up to ndoc
c       read file header, save as document lines,
c       remove leading '#' and '%' both of which are
c       known to be extraneous comment characters.
       nwords = 5
       idoc = 0
       id   = 1
 200   continue
          read(iounit, 10, end = 950, err = 960) line
          call sclean(line)
          call triml (line)
c  if line is '----', read one more line, go read numerical data
          if (line(3:6) .eq. '----')  then
             read(iounit, 10, end = 950, err = 960) line
             call sclean(line)
             call triml (line)
             goto 400
          end if
c  remove leading '#' or '%' from line
          if ( (line(1:1).eq.'#').or.(line(1:1).eq.'%') ) then
             line(1:1) = ' '
             call triml(line)
c  if the line is all numbers, then this is data!
          elseif (isdat(line)) then
             goto 410
          end if
c  save line in doc if there's room
          if ((idoc .lt. ndoc) .and. (istrln(line).gt.0) ) then
             idoc = idoc + 1
             doc(idoc) = line
          endif
          goto 200
c
c  read numerical data
 400   continue
          nwords = 5
          read(iounit, 10, end = 600, err = 980) line
 410      continue
          call sclean(line)
          call bwords(line,nwords,words)
          if (nwords.le.1) goto 600
          do 450 i = 1, nwords
              call str2re(words(i), xinp(i), ierr)
              if (ierr.ne.0) goto 600
 450      continue
          xdata(id) = xinp(1)
          yreal(id) = xinp(2)
          yimag(id) = xinp(3)
          yampl(id) = xinp(4)
          yphas(id) = xinp(5)
          if (id.ge.ndata) go to 610
          id = id + 1
          goto 400
 600   continue
       id    = id - 1
       if (id.lt.1) go to 950
 610   continue
       ndata = id
       if (idoc.le.0) then
          ndoc =  1
          doc(1) = 'inpdat: no document line found'
       else
          ndoc = idoc
       end if
c  make sure that all columns are filled:
c   if yampl and yphas are both zero, compute them from yreal, yimag
c   if yreal and yimag are both zero, compute them from yampl, yphas
       do 800 i = 1, ndata
          if ( ( (yampl(i).eq.zero).and.(yphas(i).eq.zero) ) .and.
     $         ( (yreal(i).ne.zero).or. (yimag(i).ne.zero) ) ) then
            yampl(i) = sqrt( yreal(i)**2 + yimag(i)**2 )
            yphas(i) = atan2( yimag(i), yreal(i) )
             if (i.gt.1) call pijump( yphas(i), yphas(i-1) )

          elseif ( (yreal(i).eq.zero).and.(yimag(i).eq.zero)
     $        .and.(yampl(i).ne.zero)   ) then
            yreal(i) = yampl(i) * cos ( yphas(i) )
            yimag(i) = yampl(i) * sin ( yphas(i) )

          end if
 800   continue
c  close data file and return
       close(iounit)
       return
c error handling
c  open file - error
 900   continue
         call messag(' inpcol: error opening file '//file(1:ilen) )
         go to 990
c  end or error at reading documents
 950   continue
 960   continue
         call messag( ' inpcol: error reading file '//file(1:ilen) )
         call messag('         during reading of documents.')
         go to 990
c  error at reading numerical data
 980   continue
         call messag( ' inpcol: error reading file '//file(1:ilen) )
         call messag('         during reading of numerical data.')

 990     continue
         close(iounit)
         stop
c end error handling
c end subroutine inpcol
       end
       subroutine inpuwx(ftypin, filein, skey, nkey, irecl, ndoc,
     $           documt, ndata, xdata, yreal, yimag, yampl, yphas )
c
c   copyright 1992  university of washington :          matt newville
c
c     open and get all information from a uwxafs file
c
c inputs:
c   ftypin   file type to open, checked for compatibility, may be ' '
c   filein   file name containing data
c   skey     symbolic key for record in data file (only one of these)
c   nkey     numeric key for record in data file  (two is needed    )
c   ndoc     maximum number of document lines to get
c outputs:
c   skey      symbolic key of record in uwxafs file
c   ndoc      number of document lines returned
c   docu      array of document lines
c   ndata     number of elements in data arrays
c   xdata     array of x values of data
c   yreal     array of real part of y data values
c   yimag     array of imaginary part of y data values
c   yampl     array of amplitude part of y data values
c   yphas     array of phase part of y data values
c
c notes:
c  1   the full 'noabort' error checking is done for the calls to
c      the uwxafs routines, which means that marginally useful
c      error messages will be given when one of the uwxafs
c      filehandling routines dies.
c
c  2    currently, the following file types are supported:
c           xmu,  chi,  rsp,  env,  rspep, rip
c
c  3    uwxafs file handling routines only do single precision.
c       this routine can be made implicit double precision if the
c       array buffer is maintained as single precision:
c           implicit double precision(a-h,o-z)
c           real           buffer(maxpts)
c---------------------------------------------------------------------
       parameter( maxpts = 2048, zero = 0. )
       character*(*)  ftypin, skey, filein, documt(*)
       character*10   type, ftype, safefl*8, abrtfl*8
       character*128  filnam, messg
       dimension      xdata(*), yreal(*), yimag(*)
       dimension      yampl(*), yphas(*)
       real           buffer(maxpts)
c---------------------------------------------------------------------
c initialize
 10    format(a)
 20    format(2x,2a)
 30    format(2x,a,i3)
       safefl = ' '
       abrtfl = 'noabort'
       call upper(abrtfl)

       ftype = ftypin
       filnam= filein

       call upper(skey)
       call triml(skey)
       call triml(ftype)
       call triml(filnam)
       ilen = max(1, istrln(filnam))
c note: uwxafs requires ftype to be upper case.
       call upper (ftype)
        do 100 i = 1,ndata
            xdata(i)  = zero
            yreal(i)  = zero
            yimag(i)  = zero
            yampl(i)  = zero
            yphas(i)  = zero
100    continue
       do 110 i = 1, maxpts
            buffer(i) = zero
110    continue
c  call uwxafs file handling routines:
c : open data file
       iounit = 11
       call openrf(iounit, filnam, abrtfl, safefl, ftype, irecl, ier)
       if (ier.ne.0) then
                messg = 'inpuwx: error opening file '
           call messag(messg//filnam(:ilen))
                write (messg, '(9x,a,i4)') 'openrf error code ',ier
           call messag(messg)
           stop
       end if
c : check file type
       call gftype(iounit, type, ier)
       if (ier.ne.0) then
                messg = 'inpuwx: error getting file type for '
           call messag(messg//filnam(:ilen))
                write (messg, '(9x,a,i4)') 'gftype error code ',ier
           call messag(messg)
           stop
       end if
       call upper(type)

       if (ftype.eq.' ') then
           ftype = type
       elseif (ftype.ne.type) then
                messg = 'inpuwx: incorrect file type for '
           call messag(messg//filnam(:ilen))
                messg = '     file type for this file is '
           call messag(messg//type)
                messg = '     file type requested was '
           call messag(messg//ftype)
           stop
       endif
       ftypin = ftype

c : find out how many records there are in the file
       call gnie (iounit, nie, ier)
       if (nie.le.0) then
               messg = 'inpuwx:  no data records in '
          call messag(messg//filnam(:ilen) )
          stop
       end if
c : get skey if it wasn't given as input
       if (skey.eq.' ') then
           call gskey(iounit, nkey, skey, ier)
           if (ier.ne.0) then
                  messg = 'inpuwx: error getting skey for '
             call messag(messg//filnam(:ilen))
                  write (messg, '(9x,a,i4)') 'gskey error code ',ier
             call messag(messg)
             stop
           end if
           if (skey.eq.' ') then
             write (messg, '(1x,2a,i4)') 'inpuwx: found no skey ',
     $                                  'for nkey =',nkey
             call messag(messg)
             call messag('        in file = '//filnam(:ilen))
             stop
           end if
       end if

c : get nkey if it wasn't given as input
       if (nkey.eq.0) then
           call gnkey(iounit, skey, nkey, ier)
           if (ier.ne.0) then
                  messg = 'inpuwx: error getting nkey for '
             call messag(messg//filnam(:ilen))
                  write (messg, '(9x,a,i4)') 'gnkey error code ',ier
             call messag(messg)
             stop
           end if
       end if
c
c : get documents : up to ndoc
c   first check how many document lines there are
       call gdlen(iounit, nkey, ndocln, ier)
       if (ier.ne.0) then
               messg = 'inpuwx: error getting document length for '
          call messag(messg//filnam(:ilen))
               write (messg, '(9x,a,i4)') 'gdlen error code ',ier
          call messag(messg)
          stop
       end if
       if (ndoc.gt.ndocln) ndoc = ndocln
c   then get the documents
       call getdoc(iounit, documt, ndoc, skey, nkey, ndsent, ier)
       if (ier.eq.6) then
               messg = 'inpuwx error: reading file '
          call messag(messg//filnam(:ilen) )
               messg = '  no skey or nkey given to specify record, '
          call messag(messg)
               messg = '  or an incorrect skey or nkey given '
          call messag(messg)
          stop
       elseif (ier.ne.0) then
               messg = 'inpuwx: error getting documents for '
          call messag(messg//filnam(:ilen))
               write (messg, '(9x,a,i4)') 'getdoc error code ',ier
          call messag(messg)
          stop
       end if
       ndoc = ndsent

c : get data
       call getrec(iounit, buffer, maxpts, skey, nkey, nbuff, ier)
       if (ier.ne.0) then
               messg = 'inpuwx: error getting data for '
          call messag(messg//filnam(:ilen))
               write (messg, '(9x,a,i4)') 'getrec error code ',ier
          call messag(messg)
          stop
       end if

c : close file
       call closrf(iounit,ier)
       if (ier.ne.0) then
               messg = 'inpuwx: error closing data file '
          call messag(messg//filnam(:ilen))
               write (messg, '(9x,a,i4)') 'closrf error code ',ier
          call messag(messg)
          stop
       end if
c-----------------------------------------------------------------
c finished with uwxafs routines, so now sort the data into
c xdata, re(y), imag(y), ampl(y), phase(y) according to file type
c
c convert ftype to the case of this routine.
c   'case' controls the the case of this routine
       call smcase (ftype, 'case')
c- xmu: nbuff energy, then nbuff y-values
       if (ftype.eq.'xmu') then
            ndata   = nbuff/2
            do 400 i = 1, ndata
               xdata(i) = buffer(i)
               yreal(i) = buffer(ndata + i)
               yampl(i) = yreal(i)
400         continue
c-  chi: xmin, deltax, chi(kmin + i*deltak)
       elseif (ftype.eq.'chi') then
            ndata   = nbuff - 2
            do 500 i = 1, ndata
               xdata(i) = buffer(1) + (i-1)*buffer(2)
               yreal(i) = buffer(2 + i)
               yampl(i) = yreal(i)
500         continue
c-  env,rspep: kmin, deltak, phase, amplitude pairs (kmin + i*deltak)
       elseif ( (ftype.eq.'env').or.(ftype.eq.'rspep')  ) then
            ndata   = (nbuff - 1) / 2
            do 600 i = 1, ndata
               xdata(i) = buffer(1) +(i-1)*buffer(2)
               yphas(i) = buffer(2*i+1)
               yampl(i) = buffer(2*i+2)
               yreal(i) = yampl(i) * cos ( yphas(i) )
               yimag(i) = yampl(i) * sin ( yphas(i) )
600         continue
c  rsp, rip: kmin, deltak, real, imaginary pairs (kmin + i*deltak)
       elseif ( (ftype.eq.'rsp').or.(ftype.eq.'rip')  ) then
            ndata   = (nbuff - 1) / 2
            do 700 i = 1, ndata
               xdata(i) = buffer(1) +(i-1)*buffer(2)
               yreal(i) = buffer(2*i+1)
               yimag(i) = buffer(2*i+2)
               yampl(i) = sqrt( yreal(i)**2 + yimag(i)**2 )
               yphas(i) = atan2( yimag(i), yreal(i) )
                 if (i.gt.1) call pijump( yphas(i), yphas(i-1) )
700         continue
       else
                  messg = 'inpuwx: unrecognized file type for '
             call messag(messg//filnam(:ilen))
                  messg = '        file type for this file is '
             call messag(messg//ftype)
             stop
       end if
       return
c end subroutine inpuwx
       end
       subroutine outdat(filtyp, format, filnam, vax,
     $     comm, skey, nkey, ndoc, ndocx, doc,
     $     ndata, xdata, yreal, yimag, yampl, yphas, iexist)
c
c   copyright 1992  university of washington :          matt newville
c
c    write data and documents to a file acording to the
c    format specified
c inputs:
c   filtyp    file type to open, may be ' '.
c   format    file format (uwxafs, ascii, column)
c   filnam    file name
c   vax       logical flag for being on a vax machine (binary file)
c   comm      comment character for ascii output files
c   ndoc      number of document lines to write
c   ndocx     if non-zero, ndocx  document lines will be written
c               to ascii files, even if "blank" lines are needed.
c   doc       array of document lines
c   ndata     number of elements in data arrays
c   xdata     array of x values of data
c   yreal     array of real part of y data values
c   yimag     array of imaginary part of y data values
c   yampl     array of amplitude part of y data values
c   yphas     array of phase part of y data values
c   iexist    flag for whether to write redundant data to uwxafs file
c             iexist = 1 : do not write redundant data
c             iexist = 0 : do write redundant data
c outputs:
c   skey      symbolic key for record in uwxafs file
c   nkey      numeric key for record in uwxafs file
c   ndoc      number of document lines written
c
c---------------------------------------------------------------------
       character*(*)  filtyp, format, filnam, skey, doc(*), comm
       character*30   type, form
       dimension      xdata(*), yreal(*), yimag(*)
       dimension      yampl(*), yphas(*)
       logical        vax
       integer        irecl
c---------------------------------------------------------------------
       irecl  = 512
       if (vax) irecl = 128
c
       idoc = ndoc
       skey = ' '
       form = format
       type = filtyp
       call upper(type)
       call triml(type)
       call triml(form)
c convert form to the case of this routine.
c   'case' controls the the case of this routine
       call smcase (form, 'case')
c
       if (form(1:2).eq.'uw') then
          if ( (idoc.le.0).or.(idoc.gt.19) )  idoc = 19
          call outuwx(type, filnam, skey, nkey, irecl, idoc, doc,
     $         ndata, xdata, yreal, yimag, yampl, yphas, iexist)
       elseif ( (form(1:3).eq.'col').or.(form(1:3).eq.'asc') ) then
          call outcol(type, filnam, comm, idoc, ndocx, doc,
     $         ndata, xdata, yreal, yimag, yampl, yphas)
          skey = 'ascii'
       else
          call messag('outdat: unknown file format = '//form)
          stop
       end if
c
       return
c end subroutine outdat
       end
       subroutine outcol(filtyp, filnam, comm, ndoc, ndocx, doc, ndata,
     $                  xdata, yreal, yimag, yampl, yphas)
c
c   copyright 1992  university of washington :          matt newville
c
c  open and write all information to a column file. document lines are
c  written, followed by a line of '----', then a label line, and then
c  the data are written.  the file type tells what to use for the label
c  and how many columns to write. it may be left blank.
c
c inputs:
c   filtyp    file type to write (may be ' ' : used for label only)
c   filnam    file name to write (' ' and '*' mean write to unit 6)
c   comm      comment character to specify title lines (up to char*2)
c   ndoc      maximum number of document lines to write
c   doc       array of document lines
c   ndocx     if non-zero, exactly ndocx doc lines will be written
c   ndata     number of elements in data arrays
c   xdata     array of x values of data
c   yreal     array of real part of y data values
c   yimag     array of imaginary part of y data values
c   yampl     array of amplitude part of y data values
c   yphas     array of phase part of y data values
c outputs:
c   ndoc      number of document lines written
c---------------------------------------------------------------------
       parameter (zero = 0, mxl   = 76)
       dimension      xdata(*), yreal(*), yimag(*)
       dimension      yampl(*), yphas(*)
       character*(*)  filtyp, filnam, doc(*), comm
       character*128  filout, errmsg
       character*35   xmutit, chitit, lines, blank
       character*42   envt1, envt2*32, rspt1, rspt2*32, xyt1,xyt2*32
       character*10   type, status, cmt*2, cmtdef*2,contc*5
       parameter (cmtdef = '# ', contc = '  +  ')
       parameter (lines  ='-----------------------------------')
       parameter (blank  ='    empty comment line')
       parameter (xmutit ='    energy          xmu')
       parameter (chitit ='    k              chi(k)')
       parameter (envt1  ='    k          real[chi(k)]   imag[chi(k)]')
       parameter (envt2  ='   ampl[chi(k)]   phase[chi(k)]')
       parameter (rspt1  ='    r          real[chi(r)]   imag[chi(r)]')
       parameter (rspt2  ='   ampl[chi(r)]   phase[chi(r)]')
       parameter (xyt1   ='    x          real[y(x)]     imag[y(x)]')
       parameter (xyt2   ='   ampl[y(x)]     phase[y(x)]')
c---------------------------------------------------------------------
 20    format(2a)
 30    format(3a)
       type   = filtyp
       call triml(type)
c convert type to the case of this routine.
       call smcase(type, 'a')
       filout = filnam
       call triml(filout)
       if (ndata.le.0) ndata = 2
       if ((ndocx.gt.0).and.(ndocx.lt.ndoc))  ndoc = ndocx
c decide comment character
       cmt  = comm
       if ((cmt.eq.'  ').or.(istrln(cmt).le.0)) cmt = cmtdef
c open data file
c     if file name is ' ' or '*', write to standard output (unit 6)
       iounit = 6
       if ((filout.ne.' ').and.(filout.ne.'*')) then
          iounit = 0
          status ='unknown'
          call openfl(iounit, filout, status, iexist, ierr)
          if ((ierr.lt.0).or.(iexist.lt.0)) go to 990
       endif
c
c write documents
       jdoc  = 0
       mxlp1 = mxl + 1
       do 200 idoc = 1, ndoc
          call triml(doc(idoc))
          ilen = istrln(doc(idoc))
          if (ilen.ge.1) then
             jdoc = jdoc + 1
             if (ilen.gt.mxl) then
                write(iounit, 20) cmt,doc(idoc)(1:mxl)
                write(iounit, 30) cmt,contc,doc(idoc)(mxlp1:ilen)
             else
                write(iounit, 20) cmt,doc(idoc)(1:ilen)
             end if
          elseif (ndocx.gt.0) then
             jdoc = jdoc + 1
             write(iounit, 20) cmt, blank
          end if
 200   continue
       if (ndocx.gt.ndoc) then
          do 210 idoc = ndoc+1,ndocx
             jdoc = jdoc + 1
             write(iounit, 20) cmt, blank
 210      continue
       endif
       ndoc = jdoc
c
c  write line of minus signs and column label
       write(iounit, 30) cmt,lines,lines
       if (type.eq.'xmu') then
          write(iounit, 20) cmt,xmutit
       elseif (type.eq.'chi') then
          write(iounit, 20) cmt,chitit
       elseif (type.eq.'env') then
          write(iounit, 30) cmt,envt1,envt2
       elseif (type.eq.'rsp') then
          write(iounit, 30) cmt,rspt1,rspt2
       else
          write(iounit, 30) cmt,xyt1,xyt2
       end if
c
c  write data: some file types only write out a few columns
       if ( (type.eq.'xmu').or.(type.eq.'chi') ) then
          do 400 i = 1, ndata
             if ((yreal(i).eq.zero).and.(yampl(i).ne.zero))
     $            yreal(i) = yampl(i) * cos(yphas(i))
             write(iounit, 520) xdata(i), yreal(i)
 400      continue
       else
          do 450 i = 1, ndata
c make sure that all of re(y), im(y), amp(y), and phase(y) are known
             if ( ((yampl(i).eq.zero).and.(yphas(i).eq.zero)) .and.
     $            ((yreal(i).ne.zero).or. (yimag(i).ne.zero)) ) then
                yampl(i) = sqrt( yreal(i)**2 + yimag(i)**2 )
                yphas(i) = atan2( yimag(i), yreal(i) )
                if (i.gt.1) call pijump( yphas(i), yphas(i-1) )
             elseif ((yreal(i).eq.zero).and.(yimag(i).eq.zero)
     $               .and.(yampl(i).ne.zero) ) then
                yreal(i) = yampl(i) * cos ( yphas(i) )
                yimag(i) = yampl(i) * sin ( yphas(i) )
             end if
             write(iounit, 550) xdata(i), yreal(i), yimag(i),
     $                          yampl(i), yphas(i)
 450      continue
       end if
 520   format(2x,e13.7,3x,e13.7)
 550   format(2x,e13.7,2x,e13.7,2x,e13.7,2x,e13.7,2x,e13.7)
c
c  close data file and return
       close(iounit)
       return
 990   continue
       ilen   = max(1, istrln(filnam))
       errmsg = 'outcol: error opening file '//filnam(:ilen)
       imsg   = istrln(errmsg)
       call messag(errmsg(:imsg))
       stop
c end subroutine outcol
       end
       subroutine outuwx(ftypin, filein, skey, nkey, irecl, ndoc, doc,
     $           ndata, xdata, yreal, yimag, yampl, yphas, iexist)
c
c     write out data and documents to a uwxafs file
c
c inputs:
c   ftypin    file type to write to, may be ' ' if filnam exists.
c   filein    file name to write to
c   skey      symbolic key of record in uwxafs file
c   ndoc      number of document lines returned
c   doc       array of document lines
c   ndata     number of elements in data arrays
c   xdata     array of x values of data
c   yreal     array of real part of y data values
c   yimag     array of imaginary part of y data values
c   yampl     array of amplitude part of y data values
c   yphas     array of phase part of y data values
c   iexist    flag for whether to write redundant data to file
c               iexist = 1 : do not write redundant data
c               iexist = 0 : do write redundant data
c
c   copyright 1992  university of washington :          matt newville
c-----------------------------------------------------------------------
       parameter(maxpts = 2048, maxdoc = 19, zero = 0.)
       character*(*)  filein, ftypin, doc(*), skey
       character*10   skyout, ftype, type, filnam*128, messg*128
       character*100  docout(maxdoc), abrtfl*8, safefl*8
       dimension      xdata(*), yreal(*), yimag(*)
       dimension      yampl(*), yphas(*)
       real           buffer(maxpts)
c-----------------------------------------------------------------------
c initialize
 10    format(a)
       safefl = ' '
       abrtfl = 'noabort'
       call upper(abrtfl)
       skyout = ' '
       type   = ' '
       filnam = filein
       call triml(filnam)
       ilen   = max(1, istrln(filnam))
       ftype  = ftypin
       call upper(ftype)
       do 60 i = 1, maxdoc
          docout(i) = ' '
 60    continue
c output documents
       idoc = 0
 80    continue
          idoc  = idoc + 1
          if ((idoc.ge.maxdoc).or.(idoc.gt.ndoc)) then
             idoc  = idoc - 1
             go to 100
          end if
          docout(idoc) = doc(idoc)
          call triml(docout(idoc))
          go to 80
100    continue
ccccc       ndoc = idoc
c  open data file to check file type
       iounit = 11
       call openrf(iounit, filnam, abrtfl, safefl, ftype, irecl, ier)
       if (ier.ne.0) then
               messg = 'outuwx: error opening file '//filnam(:ilen)
               imsg  = max(1, istrln(messg))
          call messag(messg(:imsg))
               write(messg, '(9x,a,i3)' ) 'openrf error code ',ier
          call messag(messg)
          stop
       end if

c  check file type
       call gftype(iounit, type, ier)
       call upper(type)
c  if file type was not given, close and the re-open data file
c           with file type just found, so we can write to file
       if (ftype.eq.' ')  then
           ftype = type
           call closrf(iounit,ier)
           call openrf(iounit, filnam, abrtfl, safefl, ftype,irecl,ier)
c  if file type was given but it was wrong, stop
       elseif (ftype.ne.type) then
                 messg = 'outuwx: incorrect file type for '
            call messag(messg//filnam(:ilen))
                 messg = '        file type for this file is '
            call messag(messg//type)
                 messg = '        file type requested was '
            call messag(messg//ftype)
            stop
       endif
c
c  make sure that all of re(y), im(y), amp(y), and phase(y) are known
       do 300 i = 1, ndata
          if ( ( (yampl(i).eq.zero).and.(yphas(i).eq.zero) ) .and.
     $         ( (yreal(i).ne.zero).or. (yimag(i).ne.zero) ) ) then
            yampl(i) = sqrt( yreal(i)**2 + yimag(i)**2 )
            yphas(i) = atan2( yimag(i), yreal(i) )
             if (i.gt.1) call pijump( yphas(i), yphas(i-1) )

          elseif ( (yreal(i).eq.zero).and.(yimag(i).eq.zero)
     $        .and.(yampl(i).ne.zero)   ) then
            yreal(i) = yampl(i) * cos ( yphas(i) )
            yimag(i) = yampl(i) * sin ( yphas(i) )

          end if
300    continue
c
c  put data into a single buffer according to data type
c convert ftype to the case of this routine.
c   'case' controls the the case of this routine
       call smcase(ftype, 'case')
c  usually buffer(1) and buffer(2) are xdata(1) and xdata(2) -xdata(1)
       buffer(1) = xdata(1)
       buffer(2) = xdata(2) - xdata(1)
c   xmu: nbuff energy, then nbuff y-values
       if (ftype.eq.'xmu') then
            nbuff    = 2*ndata
            do 400 i = 1, ndata
               buffer(i)         = xdata(i)
               buffer(ndata + i) = yreal(i)
400         continue
c   chi: kmin, deltak, chi(kmin + i*deltak)
       elseif (ftype.eq.'chi') then
            nbuff     = ndata + 2
            do 500 i  = 1, ndata
               buffer(2 + i)     = yreal(i)
500         continue
c   env: kmin, deltak, phase, amplitude pairs (kmin + i*deltak)
       elseif ( (ftype.eq.'env').or.(ftype.eq.'rspep') ) then
            nbuff     = 2* (ndata + 1)
            do 600 i  = 1, ndata
               buffer(2*i+1)     = yphas(i)
               buffer(2*i+2)     = yampl(i)
600         continue
c   rsp: kmin, deltak, real, imaginary pairs (kmin + i*deltak)
       elseif ( (ftype.eq.'rsp').or.(ftype.eq.'rip') ) then
            nbuff     = 2* (ndata + 1)
            do 700 i = 1, ndata
               buffer(2*i+1)     = yreal(i)
               buffer(2*i+2)     = yimag(i)
700         continue
c   other data types not yet supported
       else
            call messag('outuwx: not able to decipher ftype ='//ftype)
            stop
       end if
c
c  generate skyout for data with hash
       call hash(buffer, nbuff, docout, idoc, skyout)

c  check if this record is already in the file,
c    and decide whether or not to write data and
c    documentation for the record to the file

       call gnkey(iounit, skyout, nkey, ier)
       if ( (iexist.eq.1).and.(nkey.ne.0) ) then
          skey = ' '
       else
          call putrec(iounit, buffer, nbuff, skyout, 0, ier)
          call putdoc(iounit, docout, idoc,  skyout, 0, ier)
          skey = skyout
       end if

       ftypin = ftype
c  close file and leave
       call closrf(iounit, ierr)
       return
c end subroutine outuwx
       end
       subroutine testrf(flnam, irecl, flform, ier)
c
c   test whether a data file can be interpreted as  uwxafs binary
c   data file or  ascii column data file.
c
c   uwxafs binary files use direct access binary files
c   with word size irecl, which is a machine dependent parameter
c
c ier = -1 : file not found
c ier = -2 : broken uwxafs file?
c ier = -3 : not uwxafs file, but can't find data.
c ier = -4 : looks like ascii, saw line  of minus signs,
c             but 2nd following line doesn't have data
c
c   copright 1994 university of washington   matt newville
c -----------------------------------------------------
      integer   i, irecl, iunit
      character*(*) flnam, flform, line*128
      integer*2    indx(4)
      logical    exist, opend, isdat, prevdt, lisdat
      external  isdat
c -----------------------------------------------------
      flform = 'none'
      ier    = -1
      iunit  = 7
 10   continue
      inquire(unit=iunit, opened = opend)
      if (opend) then
         if (iunit.gt.20) return
         iunit = iunit + 1
         go to 10
      endif
      inquire(file = flnam, exist = exist)
      if (.not.exist) return
      ier    = -2
c -----------------------------------------------------
c try reading file as a uwxafs binary file
c     which have patriotic magic numbers embedded in them
      indx(3) = 0
      indx(4) = 0
      open(iunit, file= flnam, recl = irecl, err = 20,
     $      access = 'direct', status = 'old' )
 20   continue
      read(iunit, rec=1, err = 25) (indx(i), i=1,4)
 25   continue
      if ((indx(3).eq.1776).and.(indx(4).eq.704)) then
         flform = 'uwxafs'
         ier  = 0
         go to 900
      end if
c -----------------------------------------------------
c try to read file as ascii data file
      close(iunit)
      open(iunit, file=flnam, status='old')
      prevdt = .false.
 200  continue
         ier  = -3
         read(iunit, '(a)', end = 900, err = 900) line
         call sclean (line)
         call triml (line)
         if (line(3:6) .eq. '----') then
            ier = -4
            read(iunit, '(a)', end = 900, err = 900) line
            call sclean (line)
            read(iunit, '(a)', end = 900, err = 900) line
            call sclean (line)
            lisdat = isdat(line)
            if (lisdat ) then
               flform = 'ascii'
               ier = 0
            end if
            go to 900
         end if
c if two lines in a row have all words being numbers, it is  data
         lisdat = isdat(line)
         if (lisdat.and.prevdt)  then
            flform = 'ascii'
            ier = 0
            go to 900
         end if
         prevdt = lisdat
         go to 200
c---------------------
 900  continue
      close(iunit)
      return
c end subroutine testrf
      end
       logical function isdat(string)
c  tests if string contains numerical data
c    returns true if the first (up to eight) words in string can
c    all be numbers. requires at least two words, and tests only
c    the first eight columns
       integer nwords, mwords, i
       parameter (mwords = 8)
       character*(30)  string*(*), words(mwords), line*(256)
       logical isnum
       external isnum
c
       isdat = .false.
       do 10 i = 1, mwords
          words(i) = 'no'
 10    continue
c
       nwords = mwords
       line   = string
       call triml(line)
       call untab(line)
       call bwords(line, nwords, words)
       if (nwords.ge.2) then
          isdat = .true.
          do 50 i = 1, nwords
             if (.not. ( isnum( words(i) ) ) ) isdat = .false.
 50       continue
       end if
c
       return
       end
      subroutine pijump (ph, old)
c
c     removes jumps of 2*pi in phases
c     ph = current value of phase (may be modified on output, but
c          only by multiples of 2*pi)
c     old = previous value of phase
      parameter (pi = 3.14159 26535 89793 23846 26433)
      parameter (twopi = 2 * pi)
      dimension xph(3)

      isave  = 1
      xph(1) = ph - old
      jump =  (abs(xph(1))+ pi) / twopi
      xph(2) = xph(1) - jump*twopi
      xph(3) = xph(1) + jump*twopi

      xphmin = min (abs(xph(1)), abs(xph(2)), abs(xph(3)))
      do 10  i = 1, 3
         if (abs (xphmin - abs(xph(i))) .le. 0.01)  isave = i
 10   continue

      ph = old + xph(isave)

      return
c end subroutine pijump
      end
      subroutine cabort(messg, abortf)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c  conditional abort;  if abortf is .true.
c
      character*(*) messg
      logical abortf
      call messag(messg)
      if (abortf)  then
         call messag('* uwxafs data file handling abort *')
         stop
      endif
      return
c end subroutine cabort
      end
      subroutine putrec(iounit,array,nw,skey,nkey,ier)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c        put data record to a random access data file
c
c         iounit : i/o unit no(integer,input)
c         array  : data to be put(any type,input)
c         nw     : no of words in array(integer,input)
c         skey   : symbolic key for the record(character,input)
c         nkey   : numeric key for the record(integer,input)
c         ier    : error code(integer,output)
c           1 - unit not declared
c           2 - nw .lt. 0
c           3 - file protection violated
c           4 - skey is blank
c           5 - rewrite interlock not cleared
c           6 - record length is different for rewrite
c           7 - nkey does not exist
c           8 - index full
c
c         skey must be given always and nkey should be zero for new record
c         non zero nkey means rewrite. - nw should be equal to current one
c
      implicit integer(a-z)
c
      parameter (indxl=191, nu=2, iword = 128 )
c
      character*(*) skey
      character*80 fname(nu),ctmp
      character*2048 cindx(nu)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt,modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
      real array(nw)
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('putrec: unit not declared',abortf)
        ier=1
        return
      endif
c
      if(nw.lt.0) then
        call cabort('putrec:  no data to write',abortf)
        ier=2
        return
      endif
c
      if(modify(u)) then
        call cabort('putrec: '//fname(u)//
     $                    ' has no write permission',abortf)
        ier=3
        return
      endif
c
      if(skey.eq.' ') then
        call cabort('putrec:  skey not given',abortf)
        ier=4
        return
      endif
c
      last=indx(2,0,u)
      if(nkey.ne.0) then
c        rewrite
        if(.not.rewrt) then
          call cabort('putrec:  rewrite interlock not cleared',abortf)
          ier=5
          return
        endif
        rewrt=.false.
c          rewrite
        if(nkey.gt.last) then
          call cabort('putrec: old nkey does not exist',abortf)
          ier=7
          return
        endif
        if(nw.ne.indx(2,nkey,u)) then
          call cabort('putrec: old/new record length dont match',abortf)
          ier=6
          return
        endif
        pru=indx(1,nkey,u)
c
c        new record
      else
        if(last.ge.indxl) then
          call cabort('putrec: index full',abortf)
          ier=8
          return
        endif
        pru=indx(1,0,u)
      endif
c
      nblk  = (nw + iword - 1)/iword
      do 10 i = 1 , nblk
        l = min(i*iword, nw)
        write(iounit, rec=i+pru-1)(array(j),j=(i-1)*iword+1,l)
   10 continue
c
c          new index for rewrite
      if(nkey.ne.0) then
        call messag('putrec:  symbolic key overwritten'//
     $              cindx(u)(nkey*10+1:nkey*10+10))
        cindx(u)(nkey*10+1:nkey*10+10)=skey
      else
c          new index for new record
        cindx(u)(last*10+11:last*10+20)=skey
        indx(1,last+1,u)=indx(1,0,u)
        indx(2,last+1,u)=nw
      endif
c          new no of entries and eof block no
      indx(1,0,u)=indx(1,0,u)+nblk
      indx(2,0,u)=last+1
      ier=0
c      check duplicate key
      ctmp=skey
      ntmp=nkey
  100 continue
      do 500 n=1,last
      if(ctmp.ne.cindx(u)(n*10+1:n*10+10)) go to 500
      if(n.ne.ntmp) go to 510
  500 continue
c         no duplicate key
      go to 600
c      put an asterisk, if one is not there already
  510 continue
      do 520 i=6,10
        if(cindx(u)(n*10+i:n*10+i).eq.'*') go to 520
        cindx(u)(n*10+i:n*10+i)='*'
c      check again if new skey is duplicate
        ctmp=cindx(u)(n*10+1:n*10+10)
        ntmp=n
        go to 100
  520 continue
      call cabort('putrec:  same skey occured five times',abortf)
  600 continue
      if(safe) then
        call wrindx(iounit)
      else
        modify(u)=.true.
      endif
      return
c end subroutine putrec
      end
      subroutine putdoc(iounit,doc,nl,skey,nkey,ier)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c        put documentation lines to a random access data file
c          iounit  : fortran i/o unit no(integer,input)
c          doc     : document lines(character,input)
c          nl      : no of lines to be written(integer,input)
c          skey    : symbolic key associated with the record(char,in)
c          nkey    : numeric key associated with the record(integer,in)
c          ier     : error code (integer,output)
c            1 - unit not declared
c            2 - nl .le. 0
c            3 -
c            4 - skey not given
c            5 - rewrite interlock not cleared
c            6 - skey not found
c          if doc='doc' , internal buffer is used
c          symbolic key must be given
c          for new record, nkey should be zero.
c
      implicit integer(a-z)
c
      parameter (indxl=191, nu=2 )
c
      character*(*) skey
      character*80 fname(nu), doctmp*100
      character*2048 cindx(nu)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt,modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
      parameter(maxl=20, maxchr=100 )
      character*(maxchr) dbuf(maxl)
      common /uwdbuf/ dbuf
      save /uwdbuf/
c
      character*(*) doc(*)
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('putdoc: unit not declared',abortf)
        ier=1
        return
      endif
c
c convert form to the case of this routine.
c   'case' controls the the case of this routine
      doctmp = doc(1)
      call smcase(doctmp, 'case')
c
      if ((nl.le.0).and.(doctmp.ne.'doc')) then
        call cabort('putdoc: no documents to write',abortf)
        ier=2
        return
      endif
c
      if(skey.eq.' ') then
        call cabort('putdoc: skey must be given',abortf)
        ier=4
        return
      endif
c
      last=indx(2,0,u)
c
      if(nkey.ne.0) then
c          existing record
        if(.not.rewrt) then
          call cabort('putdoc: rewrite interlock not cleared',abortf)
          ier=5
          return
        endif
        rewrt=.false.
        iord=nkey
      else
c        new record
        call gnkey(iounit,skey,iord,ier)
        if(iord.eq.0) then
          call cabort('putdoc: skey not found',abortf)
          ier=6
          return
        endif
      endif
c
c        write at the end, always
      pru=indx(1,0,u)
      if (doctmp.eq.'doc') then
c        write internal buffer
        indx(4,iord,u)=nldoc
        nblk=(nldoc+4)/5
        do 10 i=1,nblk
            lblk=min(i*5,nldoc)
            write(iounit, rec=pru+i-1) (dbuf(j),j=i*5-4,lblk)
   10   continue
      else
c        write doc
        indx(4,iord,u)=nl
        nblk=(nl+4)/5
        do 20 i=1,nblk
            lblk=min(i*5,nl)
            write(iounit, rec=pru+i-1)(doc(j),j=i*5-4,lblk)
   20   continue
      endif
c        adjust index
      indx(3,iord,u)=pru
      indx(1,0,u)=pru+nblk
c        if (safe) write out new index
      if(safe) then
        call wrindx(iounit)
      else
c        otherwise, mark it
c        new index will be written when closrf is called
        modify(u)=.true.
      endif
      ier=0
      return
c end subroutine putdoc
      end
       subroutine openrf(iounit,lfn,aflag,sflag,ftype,irecl,ier)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c    openrf uses direct access binary files with word size  irecl.
c    irecl = 128 on vax, 512 otherwise?
c
c      structure of random data file
c
c       block size=512 byte=128 word
c
c       block 1-3 : indx(4,0:indxl,u)
c       block 4-7 : cindx(u)*2048
c
c       first data block is 8
c
c       indx(1,0,u) address of eof (non exisiting)
c       indx(2,0,u)=no of entries
c       indx(3,0,u)=1776  for identification
c       indx(4,0,u)=704   same purpose
c
c       indx(1,n,u)=address of data n
c       indx(2,n,u)=no of words for data n
c       indx(3,n,u)=address of doc n
c       indx(4,n,u)=no of lines for doc n
c
c       cindx(u)(1:10)=ftype
c       cindx(u)(n*10+1:n*10+10)=skey for nkey n
c---------------------------
      implicit integer(a-z)
      parameter (indxl = 191, nu = 2)
      character*(*) ftype,lfn,aflag,sflag
      character*80 fname(nu),fn, aflg*10, sflg*10
      character*2048 cindx(nu)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt,exist
      logical clor, modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
ccc      data unit,nldoc/nu*0,0/
ccc      data abortf,safe/.true.,.false./
c
        clor =.false.
c   find out the case of this routine.
c   'case' controls the the case of this routine
       sflg  = sflag
       aflg  = aflag
       call smcase(aflg, 'case')
       call smcase(sflg, 'case')
c
      abortf = (aflg.ne.'noabort')
      safe   = safe.or.(sflg.eq.'safe')
c
c      if lfn is blank, lfn=for0un where un is fortran i/o no
      if(lfn.eq.' ') then
        fn = 'for0'
        write(fn(5:6),1,err=9999)iounit
    1   format(i2.2)
      else
        fn=lfn
      endif
      inquire (file=fn,exist=exist)
c
      call gunit(iounit,u)
      if(u.eq.0) then
c      assign iounit no to unit(n), a table
        do 100 n=1,nu
          if(unit(n).eq.0) then
            unit(n)=iounit
            u=n
            fname(u)=fn
            go to 110
          endif
 100     continue
c
        call cabort('openrf: max no of files exceeded',abortf)
        ier=1
        return
 110    continue
c
      else
        call messag('openrf: unit reopened')
      endif
c
      if(ftype.eq.' ') then
c      no modify permit
        modify(u)=.true.
      else
        modify(u)=.false.
      endif
c
      if(exist) then
c          file exists
        if(.not.modify(u)) then
c          can modify the file
          open(iounit, file=fn, recl=irecl, access='direct',
     $         status='old', iostat=iosb, err=9999)
        else
c          cannot modify the file
          open(iounit, file=fn, recl=irecl, access='direct',
     $                            status='old')
cccccc        $         ,readonly)
        endif
c          read in existing index
        do 10 i=1,3
          read(iounit,rec=i)((indx(k,l,u),k=1,4),l=i*64-64,i*64-1)
   10   continue
        do 20 i=1,4
          read(iounit,rec=i+3)cindx(u)(i*512-511:i*512)
   20   continue
c
        if(indx(3,0,u).ne.1776 .or. indx(4,0,u).ne.704) then
          call cabort('openrf: wrong file',abortf)
          ier=4
          return
        endif
        ier=0
c
        if(ftype.ne.' '.and.ftype.ne.cindx(u)(1:10))then
          call cabort('openrf: wrong file type',abortf)
          ier=3
          return
        endif
        return
c
c          new file
c
      else
        if(ftype.eq.' ') then
          call cabort('openrf: ftype needed for file creation',abortf)
          ier=5
          return
        endif
c          create a new file
        open(iounit,file=fn,recl=irecl,access='direct',
     x       status='new')
        cindx(u)=ftype
c          index initialization
        do 30 i=1,indxl
           do 30 j=1,4
              indx(j,i,u)=0
   30   continue
        indx(1,0,u)=8
        indx(2,0,u)=0
        indx(3,0,u)=1776
        indx(4,0,u)=704
        ier=0
        go to 99
      endif
c
      entry wrindx(iounit)
c          write out index
      call gunit(iounit,u)
   99 continue
      do 101 i=1,3
        write(iounit,rec=i,err=9999)
     $        ((indx(j,k,u),j=1,4),k=i*64-64,i*64-1)
  101 continue
      do 111 i=1,4
        write(iounit,rec=i+3,err=9999)cindx(u)(i*512-511:i*512)
  111 continue
        if(clor) go to 77
 9998 return
 9999 ier=iosb
      go to 9998
c
      entry closrf(iounit,ier)
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('openrf: unit not declared',abortf)
        ier=1
        return
      endif
c         reset i/o unit table
      unit(u)=0
      ier=0
c            if modified, rewrite index
         clor=.false.
      if(modify(u)) then
         clor=.true.
         go to 99
      endif
 77   continue
      close(iounit)
      clor=.false.
      return
c
      entry rwrtrf(iounit,ier)
c          rewrite interlock.  safeguard.
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('openrf: unit not declared',abortf)
        ier=1
        return
      endif
c
      rewrt=.true.
      return
c end subroutine openrf
      end
      block data uwbdat
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling 
c
c    block data statements for uwxafs 
c
      implicit integer(a-z)
      parameter (indxl = 191, nu = 2)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt
      logical modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      save /uwdata/
      data unit,nldoc/nu*0,0/
      data abortf,safe/.true.,.false./
c end block data
      end          
      subroutine getrec(iounit,array,nw,skey,nkey,ntw,ier)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c        get data record from a data file
c          iounit : i/o unit number (integer,input)
c          array  : array to receive data (any type,output)
c          nw     : maximum no of words to receive(integer,input)
c          skey   : symbolic key of data record to get(character,input)
c          nkey   : numeric key of data record to get(integer,input)
c          ntw    : actual no of words received(integer,output)
c          ier    : error code(integer,output)
c            1 - unit not declared
c            2 - nw .lt. 0
c            3 - nkey .gt. indxl .or. .lt. 0
c            4 - nkey not on file
c            5 - two keys do not match
c            6 - skey not on file
c          either nkey(with skey=' ') or skey(with nkey=0) may be
c          given.  if both are given, they should match.
c
      implicit integer(a-z)
c
      parameter (indxl=191, nu=2, iword=128 )
c
      character*(*) skey
      character*80 fname(nu)
      character*2048 cindx(nu)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt,modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
      real array(nw)
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('getrec: iounit not declared',abortf)
        ier=1
        return
      endif
c
      if(nw.le.0) then
        call cabort('getrec: no data to get',abortf)
        ier=2
        return
      endif
c
      last=indx(2,0,u)
      if(nkey.ne.0) then
        if(nkey.lt.0.or.nkey.gt.indxl) then
          call cabort('getrec: nkey out of bounds',abortf)
          ier=3
          return
        elseif(nkey.gt.last) then
          call cabort('getrec: nkey does not exist',abortf)
          ier=4
          return
        elseif((skey.ne.' ').and.(skey.ne.cindx(u)(nkey*10+1:
     $      nkey*10+10))) then
          call cabort('getrec: skey mismatch',abortf)
          ier=5
          return
        endif
      iord=nkey
c
c        skey is given
c
      else
        call gnkey(iounit,skey,iord,iii)
        if(iord.eq.0) then
          call cabort('getrec: skey not found',abortf)
          ier=6
          return
        endif
      endif
c
      pru=indx(1,iord,u)
      ntw=indx(2,iord,u)
      if(ntw.gt.nw) then
        ntw=nw
        call messag('getrec: field shorter than data')
      endif
c
c        iword is no of words in a block
      nblk  = ( ntw + iword - 1) / iword
      do 10 i = 1, nblk
        l = min(i*iword, ntw)
        read(iounit,rec=pru+i-1)(array(j),j=(i-1)*iword+1,l)
   10 continue
      ier=0
      return
c end subroutine getrec
      end
      subroutine getdoc(iounit,doc,nl,skey,nkey,ntl,ier)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c      get documentation lines from data file
c
c      input parameters
c        iounit : i/o unit number (integer,input)
c        doc    : document array (character,in-out)
c        nl     : no of lines to get (integer,input)
c        skey   : symbolic key of record (character,input)
c        nkey   : numeric key of record (integer,input)
c        ntc    : number of lines actually got(integer,output)
c        ier    : error code (integer,output)
c               1 - unit not declared
c               2 - nl negative or zero
c               3 - nkey .gt. indxl .or. nkey .lt. 1
c               4 - nkey is not on file
c               5 - skey and nkey don't match
c               6 - skey is not on file
c
c       if skey is blank, nkey is used. if nkey is 0, skey is used.
c       if both are given, they should match.
c
c       if doc is equal to 'doc' then data are transferred
c       to internal buffer.  nl is ignored in this case.
c       see routines getline, addline and prntdoc for
c         the manipulation of this buffer
c
      implicit integer(a-z)
      parameter (indxl = 191, nu = 2 )
c
      character*80   fname(nu), doctmp*100
      character*2048 cindx(nu)
      integer*2      indx(4,0:indxl,nu)
      logical        abortf, safe, rewrt, modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
      parameter (maxl=20, maxchr=100 )
      character*(maxchr) dbuf(maxl)
      common /uwdbuf/ dbuf
      save   /uwdbuf/
c
      character*(*) skey,doc(*)
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('getdoc: unit not declared',abortf)
        ier=1
        return
      endif
c
c convert form to the case of this routine.
c   'case' controls the the case of this routine
      doctmp = doc(1)
      call smcase(doctmp, 'case')
c
      if ((nl.le.0).and.(doctmp.ne.'doc')) then
        call cabort('getdoc: no document lines to get',abortf)
        ier=2
        return
      endif
c
      if(nkey.ne.0) then
        if(nkey.lt.0.or.nkey.gt.indxl) then
          call cabort('getdoc: nkey out of bounds',abortf)
          ier=3
          return
        elseif(indx(1,nkey,u).eq.0) then
          call cabort('getdoc: nkey does not exist',abortf)
          ier=4
          return
        elseif(skey.ne.' '.and.
     $      skey.ne.cindx(u)(nkey*10+1:nkey*10+10)) then
          call cabort('getdoc: skey mismatch',abortf)
          ier=5
          return
        endif
        iord=nkey
c      skey is not given
      else
        call gnkey(iounit,skey,iord,ier)
        if(iord.eq.0) then
          call cabort('getdoc: skey not found',abortf)
          ier=6
          return
        endif
      endif
c
      pru=indx(3,iord,u)
c
c      to document buffer
      if (doctmp.eq.'doc') then
        nldoc=indx(4,iord,u)
        nblk=(nldoc+4)/5
        ntl=nldoc
        do 10 i=1,nblk
          read(iounit,rec=pru+i-1) (dbuf(j),j=i*5-4,i*5)
   10   continue
c      to doc
      else
        ntl=indx(4,iord,u)
        ntl=min(ntl,nl)
        nblk=(ntl+4)/5
        do 20 i=1,nblk
          lblk=min(i*5,ntl)
          read(iounit,rec=pru+i-1) (doc(j),j=i*5-4,lblk)
   20   continue
      endif
      ier=0
      return
c end subroutine getdoc
      end
      subroutine hash(array, narray, doc, ndoc, skey)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c  generate 5 character string composed of alphanumerics
c
c   since this routine is not called too often, execution speed
c   is not as important as getting a reasonably pseudo-random skey.
c ***   note:  random numbers done as in numerical recipes
c-----------------------------------------------------------------------
       parameter(maxpts = 4096)
       parameter(imod =  6655, imul = 936, iadd = 1399)
       parameter(jmod = 14406, jmul = 967, jadd = 3041)
       parameter(kmod =  7875, kmul = 211, kadd = 1663)
       parameter(lmod =  6075, lmul = 106, ladd = 1283)
       parameter(ihalf= 3333, imost= 5555, jhalf= 7201, jthrd= 4821)
c
       double precision work(maxpts), sum(4), zero
       double precision pi, gold, goldm1, e1, aver, part
       parameter(zero = 0.d0, pi = 3.141592653589793d0 )
       parameter(e1= 2.7182818280)
       parameter(gold = 1.618033989d0, goldm1 = 0.618033989d0)
       character*(*)    doc(*)
       character*(5)    skey
       real             array(*)
       integer          ikey(5), iran(131)
       logical          loop
c
c initialize
       nwork  = 2*narray
       skey   = 'skey0'
       if (narray.le.0)   return
       ichr0  = ichar('0')
       ichra  = ichar('a')
       do 15 i = 1, 5
           ikey(i) = 0
 15    continue
       do 18 i = 1, 4
           sum(i)  = zero
 18    continue

c get measure of the magnitude of the data two different ways
c        ihalf ~= imod/2 , so that roughly half the values
c                          are used to make the partial sum
       aver  = 1.d-1
       part  = 2.d-1
       do 30 i = 1, narray
          aver  = abs( dble(array(i)) / narray ) + aver
          irndm = mod(imul*(i + narray)  + iadd, imod)
          if ( (i.gt.2) .and. (irndm.gt.ihalf) ) then
             part = abs( dble(array(i)) / narray ) + part
             if (irndm.gt.imost) then
                 part = abs( dble(array(i-2)) / narray ) + part
              else
                 part = abs( dble(array(i-1)) / narray ) + part
              end if
          end if
30     continue

c create work array such that all values of work are of the order 1.
c  - most values are scaled to one of the two different measures of
c    magnitude from above.
c  - a few values get scaled to be on the order of 1 without reference
c    to these values (should prevent against two arrays differing only
c    by a constant factor from having the same skey)
c  - couldn't resist the golden mean and fine structure constant.

       if (abs(aver).le.1.d-3) aver = 1.d-2
       if (abs(part).le.1.d-3) part = 1.d-2
       do 150 i = 1, narray
          loop           = .true.
          work(i)        = abs( dble(array(i)) / aver )
          work(i+narray) = abs( dble(array(i)) / part )
          j              = i*kmul + kadd + narray
          jrndm          = mod(jmul*j  + jadd, jmod)
          if ( jrndm.lt.jthrd ) then
              work(i) = work(i) * pi
          elseif ( jrndm.gt.jhalf ) then
              j              =  mod(i*j + jrndm, narray - 1 ) + 1
              work(i+narray) = abs( dble(array(i)+array(j)) / e1)
100           continue
                if(loop.and.(work(i+narray).le.(0.0072974d0))) then
                   work(i+narray) = work(i+narray) * gold
                   loop = .false.
                   go to 100
                elseif(loop.and.(work(i+narray).ge.( 137.036d0))) then
                   work(i+narray) = work(i+narray) * goldm1
                   loop = .false.
                   go to 100
                endif
          end if
150     continue
c
c generate iran: a list of 131 pseudo-random integers that
c                do not depend on the data at all
       do 200 i = 1, 131
            j       = i*imul + iadd
            jtmp    = mod(jmul*j    + jadd, jmod) + 1
            ktmp    = mod(kmul*jtmp + kadd, kmod) + 3
            iran(i) = mod(lmul*ktmp + ladd, lmod) + 7
200    continue
c
c collect 4 different sums from the work array:
c   each value in the work array is multiplied by a pseudo-randomly
c   selected integer between 20 and 120, and 4 different sums are made.
c   since each value in work() is on the order of 1, each of the sums
c   should be of the order 100*narray. with narray being something
c   between 100 and 1000, each of the different sums will be a random
c   number on the order of 50 000. this value mod 36 should be a good
c   random number.
c
       do 500 i = 1, nwork
c       get some random numbers, and make them bigger than 50
          i1 = mod (i * imul + iadd, imod ) + 53
          i2 = mod (i * jmul + jadd, jmod ) + 67
          i3 = mod (i * kmul + kadd, kmod ) + 31
          i4 = mod (i * lmul + ladd, lmod ) + 79

c       use these to make random numbers between [1, 130 ]
          j1 = mod( jmul*i1 + kadd, 109) + 3
          j2 = mod( kmul*i2 + ladd, 119) + 5
          j3 = mod( lmul*i3 + iadd, 111) + 7
          j4 = mod( imul*i4 + jadd, 123) + 1

c       use these for the iran array of random numbers to get a set
c                                   of numbers between [20 and 150]
          k1 = mod( jmul*( i4 + iran(j1)) + kadd,  73 ) + 43
          k2 = mod( kmul*( i2 + iran(j2)) + ladd, 111 ) + 37
          k3 = mod( lmul*( i1 + iran(j3)) + iadd,  91 ) + 29
          k4 = mod( imul*( i3 + iran(j4)) + jadd, 121 ) + 19

c       do "randomly weighted" sum of work array
          sum(1) = sum(1) + work(i) * k1
          sum(2) = sum(2) + work(i) * k2
          sum(3) = sum(3) + work(i) * k3
          sum(4) = sum(4) + work(i) * k4
500    continue

c turn the sums to integers between 1 and 36 for ikey(1) - ikey(4)
       do 900 i = 1, 4
 880      continue
          if (abs(sum(i)).ge.100 000 000) then
              sum(i) = sum(i) / gold
              go to 880
          end if
          isum  = int( sum(i) )
          ikey(i) = mod(isum, 36)
 900   continue

c ikey(5) : sum from document array
       isum = 0
       im   = mod(iran(16) * ndoc + iran(61), 353)  + 27
       ia   = mod(iran(77) * ndoc + iran(52), 347)  + 19

       do 2000 i = 1, ndoc
          call triml( doc(i) )
          jlen = max(1, istrln( doc(i)))
          do 1800 j = 1, jlen
             kseed = mod( (j + 2*i) * imul  + jadd , 127) + 1
             k     = mod( iran(kseed) * im  + ia   ,  13) + 3
             isum  = isum + k * ichar( doc(i)(j:j) )
1800      continue
2000   continue
       ikey(5) = mod(isum, 36)
c
c map integers 1 to 36 to numerals and letters
c   ascii assumed but not required. the numerals must be
c   ordered 0 - 9 and the letters must be ordered a - z.
       do 4000 i = 1, 5
         if (ikey(i).le.9) then
            ikey(i) = ikey(i) + ichr0
         else
            ikey(i) = ikey(i) - 10 + ichra
          end if
4000   continue

c write skey from ikey
       do 5000 i = 1, 5
          skey(i:i) = char( ikey(i) )
5000   continue
       call upper(skey)
       return
c end subroutine hash
       end
      subroutine gunit(iounit,u)
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c        match unit no with iounit no
c          iounit : fortran i/o unit no(integer,input)
c          u      : corresponding index(1,2.. upto nu, in order of
c                   call to openrf routine)(integer,output)
c            relation   unit(u)=iounit
      implicit integer(a-z)
c
      parameter (indxl=191, nu=2 )
c
      character*80 fname(nu)
      character*2048 cindx(nu)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt,modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
      u=0
      do 10 n=1,nu
          if(unit(n).eq.iounit)  then
              u = n
              go to 20
          end if
   10 continue
   20 continue
      return
c end subroutine gunit
      end
      subroutine rfmisc
c
c        copyright university of washington 1981
c        part of uwxafs binary (rdf) file handling
c
c  miscellaneous routines for handling uwexafs files.  most of
c  the entries here are to find out what's inside a file.
c        copyright university of washington 1981
c
      implicit integer(a-z)
c
      parameter (indxl=191, nu=2)
c
      character*(*) skey,ftype,lfn
      character*80 fname(nu)
      character*2048 cindx(nu)
      integer*2 indx(4,0:indxl,nu)
      logical abortf,safe,rewrt,modify(nu)
c
      common /uwdata/ unit(nu),modify,abortf,safe,rewrt,nldoc,indx
      common /uwdocs/ cindx,fname
c
      save /uwdata/,/uwdocs/
c
      entry gskey(iounit,nkey,skey,ier)
c
c          get symbolic key from a numeric key
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gskey: unit not declared',abortf)
        ier=1
        return
      endif
      if(nkey.lt.0.or.nkey.gt.indxl) then
        call cabort('gskey:  nkey out of range',abortf)
        ier=2
        return
      endif
c          if nkey does not exist, skey=' '
      skey=cindx(u)(nkey*10+1:nkey*10+10)
      ier=0
      return
c
      entry gnkey(iounit,skey,nkey,ier)
c
c          get a numeric key from a symbolic key
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gnkey:  unit not declared',abortf)
        ier=1
        return
      endif
c
      last=indx(2,0,u)
      do 300 n=1,last
        if(skey.eq.cindx(u)(n*10+1:n*10+10)) go to 310
  300 continue
c        skey not found
      nkey=0
      return
c
  310 continue
      nkey=n
      ier=0
      return
c
      entry gftype(iounit,ftype,ier)
c
c      get file-type from a i/o unit no
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gftype:  iounit not declared',abortf)
        ier=1
        return
      endif
c
      ftype=cindx(u)(1:10)
      ier=0
      return
c
      entry glfn(iounit,lfn,ier)
c
c        get filename from   i/o unit no
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gfln: iounit not declared',abortf)
        ier=1
        return
      endif
c
      lfn=fname(u)
      ier=0
      return
c
      entry gflen(iounit,flen,ier)
c
c         get the length of a file from i/o unit no
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gflen: iounit not declared',abortf)
        ier=1
        return
      endif
c
      flen=indx(1,0,u)-1
      return
c
      entry gnie(iounit,nie,ier)
c
c          get number of entries from i/o unit no
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gnie: iounit not declared ',abortf)
        ier=1
        return
      endif
c
      nie=indx(2,0,u)
      ier=0
      return
c
      entry grlen(iounit,nkey,rlen,ier)
c
c         get the length of a data record (in words) from a numeric key
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('grlen: iounit not declared ',abortf)
        ier=1
        return
      endif
c
      if(nkey.lt.0.or.nkey.gt.indxl) then
        call cabort('grlen: nkey out of range',abortf)
        ier=2
        return
      endif
c
      rlen=indx(2,nkey,u)
      ier=0
      return
c
      entry gdlen(iounit,nkey,dlen,ier)
c
c       get the length of document (in lines) from a numeric key
c
      call gunit(iounit,u)
      if(u.eq.0) then
        call cabort('gdlen: unit not declared',abortf)
        ier=1
        return
      endif
c
      if(nkey.lt.0.or.nkey.gt.indxl) then
        call cabort('gdlen: nkey out of range',abortf)
        ier=2
        return
      endif
c
      dlen=indx(4,nkey,u)
      ier=0
      return
c
c end subroutine rfmisc
      end
         subroutine lintrp(x, y, npts, xin, ip, yout)
c
c    linear interpolation for use in loops where xin increases
c    steadily through the monotonically increasing array x.
c  arguments:
c     x      array of ordinate values                   [in]
c     y      array of abscissa values                   [in]
c     npts   length of arrays x and y                   [in]
c     xin    value of x at which to interpolate         [in]
c     ip     index such that x(ip) <= xin <= x(ip+1)    [in/out]
c     y      interpolated abscissa at xin               [out]
c  note: this routine is called extremely often
c        -- anything to improve efficiency should be done
       integer    npts, ip
       real       x(*), y(*), tiny, xin, yout
       logical    dohunt
       parameter  (tiny = 1.e-11)
c  make sure ip is in range
       ip  = min(npts-1,max(1,ip))
c  find ip such that   x(ip) <= xin <= x(ip+1)
c   most likely candidate is the current value of ip, or ip+1
c   otherwise use routine hunt to find ip
       dohunt = .false.
       if (xin.lt.x(1)) then
          ip = 1
       elseif (xin.gt.x(npts)) then
          ip = npts - 1
       elseif ((ip.le.npts-2).and.
     $         (xin.gt.(x(ip+1))) .and. (xin.le.(x(ip+2)))) then
          ip = ip + 1
       elseif ((xin.lt.(x(ip))) .or. (xin.gt.(x(ip+1)))) then
          dohunt = .true.
       end if
       if (dohunt) call hunt(x, npts, xin, ip)
       ip  = min(npts-1,max(1,ip))
       yout = y(ip)
       if ( (x(ip+1) - x(ip)) .gt. tiny)  yout = yout +
     $      (y(ip+1) - y(ip)) * ( xin - x(ip)) / (x(ip+1) - x(ip))
       return
c  end subroutine lintrp
       end
       subroutine qintrp(x, y, npts, xin, ip, yout)
c
c     this does a crude quadratic interpolation for repeated loops
c     where xin is increasing steadily through the values in x.
c   inputs:
c     x      array of ordinate values
c     y      array of abscissa values
c     npts   length of arrays x and y
c     xin    value of x at which to interpolate
c     ip     guess of index in x array to use
c  outputs:
c     ip     index in x array used in interpolation
c     yout    interpolated abscissa at xin
c----------------------------------------------------------------
       integer    npts, ip
       real       x(npts), y(npts), tiny, xin, yout
       logical    dohunt
       parameter  (tiny = 1.e-8)

c  find ip such that   x(ip) <= xin <= x(ip+1)
c   most likely candidate is the current value of ip, or ip+1
c   otherwise use routine hunt to find ip
c  make sure ip is in range
       ip  = min(npts-1,max(1,ip))
c  find ip such that   x(ip) <= xin <= x(ip+1)
c   most likely candidate is the current value of ip, or ip+1
c   otherwise use routine hunt to find ip
       dohunt = .false.
       if (xin.lt.x(1)) then
          ip = 1
       elseif (xin.gt.x(npts)) then
          ip = npts - 1
       elseif ((ip.le.npts-2).and.
     $         (xin.gt.(x(ip+1))) .and. (xin.le.(x(ip+2)))) then
          ip = ip + 1
       elseif ((xin.lt.(x(ip))) .or. (xin.gt.(x(ip+1)))) then
          dohunt = .true.
       end if
       if (dohunt) call hunt(x, npts, xin, ip)
       ip  = min(npts-1,max(1,ip))
c
       yout  = y(ip)
      if ((x(ip+1)-x(ip)).gt.tiny) then
c find two closest x values and the two further neighbors
          i1 = ip
          i2 = ip + 1
          if (xin.lt.x(ip))    i2 = ip - 1
          i3a = max(i1,i2) + 1
          i3b = min(i1,i2) - 1
          imin = min(i1,i2,i3a,i3b)
          imax = max(i1,i2,i3a,i3b)
          if ((imin.gt.3).and.(imax.lt.npts-2)) then
c construct differences
             dxi1  =  xin   - x(i1)
             dxi2  =  xin   - x(i2)
             dxi3a =  xin   - x(i3a)
             dxi3b =  xin   - x(i3b)
             dx12  =  x(i1) - x(i2)
             dx13a =  x(i1) - x(i3a)
             dx13b =  x(i1) - x(i3b)
             dx23a =  x(i2) - x(i3a)
             dx23b =  x(i2) - x(i3b)
             youta = dxi2 * dxi3a * y(i1)  / ( dx12  * dx13a )
     $             - dxi1 * dxi3a * y(i2)  / ( dx12  * dx23a )
     $             + dxi1 * dxi2  * y(i3a) / ( dx13a * dx23a )
             youtb = dxi2 * dxi3b * y(i1)  / ( dx12  * dx13b )
     $             - dxi1 * dxi3b * y(i2)  / ( dx12  * dx23b )
     $             + dxi1 * dxi2  * y(i3b) / ( dx13b * dx23b )
             yout  = (youta * dxi3b - youtb * dxi3a)/(x(i3a) - x(i3b))
          else
             call lintrp(x, y, npts, xin, ip, yout)
          end if
       end if
       return
c  end subroutine qintrp
       end
       subroutine hunt(xar, npts, xin, jlo)
c
c   given an array xar(n), and a value xin, return jlo
c   such that xar(jlo) <= xin <= xar(jlo+1).
c   xar must be monotonic.
c   jlo = 0 or jlo = n indicates that xin is out of range.
c   on input, jlo gives an initial guess for the output jlo
c
c   note the use of the somewhat rare logical operator .eqv. :
c   a.eqv.b = ((a.and.b.) .or. (.not.(a.or.b)))
c
       dimension xar(npts)
       logical incre, nohunt

c  first, decide if we really need to be here
       nohunt = .true.
       if ((xin.ge.(xar(jlo))) .and. (xin.le.(xar(jlo+1)))) then
          continue
       elseif (xin.lt.xar(1)) then
          jlo = 1
       elseif (xin.gt.xar(npts)) then
          jlo = npts - 1
       elseif (jlo.le.npts-2) then
          if ((xin.gt.(xar(jlo+1))) .and. (xin.le.(xar(jlo+2)))) then
             jlo = jlo+1
          else
             nohunt = .false.
          end if
       else
             nohunt = .false.
       end if
       if (nohunt) return
cc
       incre = xar(npts).gt.xar(1)
       if (jlo.le.0.or.jlo.gt.npts) then
c  the input jlo is not useful -- go to bisection
         jlo = 0
         jhi = npts+1
         go to 30
       endif
       inc = 1
c  incre = .true. if xar is an increasing table
c  hunt up ...
       if (xin.ge.xar(jlo).eqv.incre) then
 10      jhi=jlo+inc
         if (jhi.gt.npts) then
           jhi=npts+1
         elseif (xin.ge.xar(jhi).eqv.incre) then
           jlo=jhi
           inc=inc+inc
           go to 10
         endif
       else
c  ... or hunt down
         jhi=jlo
 20      jlo=jhi-inc
         if (jlo.lt.1) then
           jlo=0
         elseif (xin.lt.xar(jlo).eqv.incre) then
           jhi=jlo
           inc=inc+inc
           go to 20
         endif
       endif
c  done hunting, value bracketed
c  bisection:
 30    continue
       if (jhi-jlo.ne.1) then
          jm = (jhi + jlo) / 2
          if (xin.gt.xar(jm).eqv.incre) then
             jlo=jm
          else
             jhi=jm
          endif
          go to 30
       end if
       return
c end subroutine hunt
       end
       subroutine window(mpts, iw, wp1, wp2, xmin, xmax, xgrid, wa)
c
c  create a window array appropriate for ffts (a window function is
c  used to smooth out the data and maintain some peak separation).
c
c  arguments:
c     mpts:  dimension of wa                           [in]
c     iw:    window type (see notes below)         [in/out]
c     wp1:   window parameters (see notes below)   [in/out]
c     wp2:   window parameters (see notes below)   [in/out]
c     xmin:  window range (see notes below)            [in]
c     xmax:  window range (see notes below)            [in]
c     xgrid: array grid, used to evaluate wa           [in]
c     wa:    array containing window function         [out]
c
c  notes:
c    currently eight window functions are supported.   most windows
c    rise from zero at x1 to one at x2, stay at one until x3 and then
c    drop to zero at x4, with x1,...,x4 depending on window type and
c    parameters (iw,wp1,wp2,xmin,xmax).   the gaussian and lorentzian
c    windows extend over the entire range and never equal zero.
c    the array is on an even grid beginning at zero:
c       wa(i) = wa(x=(i-1)*xgrid).
c
c  windows types are ( if iw > 7 , iw will be set to 0).
c    0: hanning window sills (default):
c        x1 = xmin - wp1/2 ,   x2 = xmin + wp1/2
c        x3 = xmax - wp2/2 ,   x4 = xmax + wp2/2
c        the hanning function goes as cos^2 and sin^2.
c    1: hanning window fraction:
c        x1 = xmin ,   x2 = xmin + wp1*(xmax-xmin)/2
c        x4 = xmax,    x3 = xmax - wp1*(xmax-xmin)/2
c        the function goes as cos^2 and sin^2. wp1 is the
c        hanning fraction: the fraction of the x range over
c        which the windop is not 1. (wp1 = 1 will
c        give a full hanning fraction, with x2 = x3)
c    2: gaussian window:
c        x1 = xmin ,   x4 = xmax,    x2,x3 not used
c        a gaussian is applied over the entire transform range.
c        window(x) = exp( -wp1*term**2 )
c        term      = (x - xave)/(delx/2)
c        xave      = (x4+x1) / 2,   delx = x4-x1
c    3: Kaiser-Bessel window:
c       x1 = xmin ,   x4 = xmax,    x2,x3 not used
c       this function is similar to a Gaussian and goes to 0 at x1
c       and x4 for kbe = 5.44. Sometimes you will get a better resolution
c       in r-space for kbe = 2.72 (when the function isn't zero at 
c       x1 and x4. See the articel 'Digital Filter' by J.F. Kaiser in
c       'System Analysis by Digital Computers' edited by F.F. Kuo
c       and J.F. Kaiser, (New York; Wiley) 1966
c    4: parzen window:
c        x1 = xmin - wp1/2 ,   x2 = xmin + wp1/2
c        x3 = xmax - wp2/2 ,   x4 = xmax + wp2/2
c        the window is linear between x1 and x2 and x3 and x4
c    5: welch window:
c        x1 = xmin - wp1/2 ,   x2 = xmin + wp1/2
c        x3 = xmax - wp2/2 ,   x4 = xmax + wp2/2
c        the window is parabolic between x1 and x2 and x3 and x4.
c    6: sine window:
c        x1 = xmin - wp1 ,   x4 = xmin + wp1
c        x2 and x3 =not used
c        this function is a sine that goes to 0 at x1 and x4
c        and is applied over the entire window range
c    7: gaussion#2 window:
c        x1 = xmin ,   x4 = xmin,   x2 and x3 =not used
c        window(x) = exp( -wp1*(x - wp2)**2 )
c  for more information, see documentation for feffit, etc.
c
c copyright 1997  matt newville
c
       implicit none
       integer mpts, iw, i, ix1, ix2, ix3, ix4
       real wa(mpts), halfpi, zero, one, eps, x21i, x43i, x41i
       real x1,x2,x3,x4,xmin,xmax, xgrid, wp1, wp2, term, x
       real  bessi0, bkde, bkde2, bkom, bkxx, bki0, bkav
       parameter (halfpi= 1.570796326795, zero=0, one=1, eps= 1.e-3)
       external bessi0
c
       if (iw.gt.7) iw = 0
c  set x1..x4 based on window type
c   hanning sills, parzen, and welch:
       x1 = xmin - wp1/2
       x2 = xmin + wp1/2 + eps * xgrid
       x3 = xmax - wp2/2 - eps * xgrid
       x4 = xmax + wp2/2
c   hanning fraction
       if (iw.eq.1) then
          wp1 = max(zero, min(one, wp1))
          x1 = xmin
          x2 = x1 + wp1*(xmax-xmin)/2 + eps * xgrid
          x3 = x4 - wp1*(xmax-xmin)/2 - eps * xgrid
          x4 = xmax
c   gaussian, kaiser-bessel
       elseif ((iw.eq.2).or.(iw.eq.3).or.(iw.eq.7)) then
          wp1 = max(wp1, eps)
          x1 = xmin
          x2 = zero
          x3 = zero
          x4 = xmax
c   sine
       elseif (iw.eq.6) then
          x1 = xmin - wp1
          x2 = zero
          x3 = zero
          x4 = xmax + wp2
       end if
c keep some useful constants
       ix1  = int(x1/xgrid)
       ix2  = int(x2/xgrid)
       ix3  = int(x3/xgrid)
       ix4  = int(x4/xgrid)
       x21i = 1/(x2-x1)
       x43i = 1/(x4-x3)
       x41i = 1/(x4-x1)
c
c initialize window array to zero
       do 5 i=1,mpts
          wa(i) = zero
 5     continue
c now make the window array
c    hanning (fraction or sills)
       if (iw.le.1) then
          do 10 i=1,mpts
             x = (i-1)*xgrid
             if ((i.ge.ix1).and.(i.le.ix2)) then
                wa(i) = sin(halfpi*(x-x1) * x21i) ** 2
             elseif ((i.ge.ix3).and.(i.le.ix4)) then
                wa(i) = cos(halfpi*(x-x3) * x43i) ** 2
             elseif ((i.lt.ix3).and.(i.gt.ix2)) then
                wa(i) = one
             endif
 10       continue
c    gaussian
       else if (iw.eq.2) then
          do 20 i = 1, mpts
             term  = (2*(i-1)*xgrid - (x4+x1)) * x41i
             wa(i) = exp( -wp1*term*term)
 20       continue
c    kaiser-bessel
       elseif (iw.eq.3) then
          bki0  = bessi0(wp1)
          bkav  = (x4+x1) /2
          bkde  = (x4-x1) /2
          bkde2 = bkde * bkde
          bkom  = wp1  / bkde
          do 30 i = 1, mpts
             wa(i) = zero
             bkxx  = bkde2 - ((i-1)*xgrid - bkav)**2
             if (bkxx.gt.0) then
                wa(i) = bessi0( bkom * sqrt(bkxx) ) / bki0
             endif
 30       continue 
c    parzen
       elseif (iw.eq.4) then
          do 40 i=1,mpts
             x = (i-1)*xgrid
             if ((i.ge.ix1).and.(i.le.ix2)) then
                wa(i) =  (x-x1) * x21i
             elseif ((i.ge.ix3).and.(i.le.ix4)) then
                wa(i) = one - (x-x3) * x43i
             elseif ((i.lt.ix3).and.(i.gt.ix2)) then
                wa(i) = one
             endif
 40       continue
c    welch
       elseif (iw.eq.5) then
          do 50 i=1,mpts
             x = (i-1)*xgrid
             if ((i.ge.ix1).and.(i.le.ix2)) then
                wa(i) = one - ((x-x2) * x21i) ** 2
             elseif ((i.ge.ix3).and.(i.le.ix4)) then
                wa(i) = one - ((x-x3) * x43i) ** 2
             elseif ((i.lt.ix3).and.(i.gt.ix2)) then
                wa(i) = one
             endif
 50       continue
c    sine
       elseif (iw.eq.6) then
          do 60 i = 1, mpts
             if ((i.ge.ix1).and.(i.le.ix4))
     $            wa(i) = sin( 2* halfpi*(x4- (i-1)*xgrid) * x41i)
 60       continue
c    gaussian#2
       elseif (iw.eq.7) then
          do 70 i = 1, mpts
             if ((i.ge.ix1).and.(i.le.ix4)) then
                term = (i-1)*xgrid - wp2
                wa(i) =  exp( -wp1 * term*term)
             end if
 70       continue
       end if
       return
c end subroutine window
       end
       real function bessi0(x)
c
c zero-ordered modified Bessel function I_0(x) for real x
c from abramowitz and stegun p 378 
       real x, v, y, c
       real a1,a2,a3,a4,a5,a6
       real b1,b2,b3,b4,b5,b6,b7,b8,b9
       parameter(a1 = 3.5156229d0  , a2 = 3.0899424d0  )
       parameter(a3 = 1.2067492d0  , a4 = 0.2659732d0  )
       parameter(a5 = 0.360768d-1  , a6 = 0.45813d-2   )
       parameter(b1 = 0.39894228d0 , b2 = 0.1328592d-1 )
       parameter(b3 = 0.225319d-2  , b4 =-0.157565d-2  )
       parameter(b5 = 0.916281d-2  , b6 =-0.2057706d-1 )
       parameter(b7 = 0.2635537d-1 , b8 =-0.1647633d-1 )
       parameter(b9 = 0.392377d-2  ,  c = 3.75d0)
c
       v = abs(x)
       if(v.lt.c) then
          y=(x/c)**2
          bessi0= 1 + y*(a1+y*(a2+y*(a3+y*(a4+y*(a5+y*a6)))))
       else
          y=c/v
          bessi0=(exp(v)/sqrt(v)) *
     $    (b1+y*(b2+y*(b3+y*(b4+y*(b5+y*(b6+y*(b7+y*(b8+y*b9))))))))
       endif
      return
      end
      subroutine fitchk
c
c      this routine does some error checking of the math expressions
c      for feffit.  the expressions have already been encoded in
c      fitinp, and the math syntax has been checked in encod, but not
c      all the checks could be done until all the input files have been
c      read in. done here are checks so that:
c        1.  all variables named in the math expresions must
c            be defined as either variables or functions.
c        2.  all defined variables and functions are used, or a
c            warning will be given.
c        3.  all encoded math expressions can be reliably decoded.
c            all math expressions are actually evaluated here.
c
c      also done here is the use of the zeroth (0th) path as the default
c      expression for the various path parameters. the 0th path will be
c      used here to overwrite those path parameters that were not
c      explicitly given in the input file.
c
c      copyright 1993 university of washington         matt newville
c
c----------------------------------------------------------------
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c  from encod!
       integer   jconst, io2n(maxval)
       parameter (jconst = 8192)
c----------------------------------------------------------------------
c
c fix integer codes to put variables first, then constants, then
c ordered math expressions, so that a single pass will correctly
c evaluate all "set" values
c notes:  puts "local" variables  after constants
c         doesn't check for pathological recursion
       nvar = numvar
       call fixicd(icdval, maxval, micode, jconst, ixlocl,
     $      vnames, values, nvar, nconst, nmathx, io2n)
       if (nvar.ne.numvar)  call finmsg(3200,' ',' ',0)
c update xguess to reordered values!
       do 150 iv = 1, numvar
          xguess(iv) = values(iv)
 150      continue
c
       do 360 id = 1, ndata
          do 340 j = 1, mlocal
             do 320 i = 1, micode
                if (icdloc(i,j,id).eq.0) go to 325
                if ((icdloc(i,j,id).gt.0).and.
     $               (icdloc(i,j,id).le.nmathx) )
     $               icdloc(i,j,id) = io2n(icdloc(i,j,id))
 320         continue
 325         continue
 340      continue
 360   continue
c
       do 860 ip = 1, mpaths
          do 840 j = 1, mpthpr
             do 820 i = 1, micode
                if (icdpar(i,j,ip).eq.0) go to 825
                if ((icdpar(i,j,ip).gt.0).and.
     $               (icdpar(i,j,ip).le.nmathx))
     $               icdpar(i,j,ip) = io2n(icdpar(i,j,ip))
 820         continue
 825         continue
 840      continue
 860   continue
c
c  check that variables named in math expressions are defined
       do 1000 iv = 1, nmathx
          if ( (vnames(iv).ne.' ').and.(icdval(1,iv).eq.0) )
     $         call finmsg(3220,vnames(iv),' ',0)
 1000  continue
c
c  check that the variables and user-defined functions are used.
c  expection for '_bkg_#' - these won't show up in other user-def fun's
       do 2000 iv = 1, nmathx
          if ( vnames(iv)(1:6).ne.'_bkg_#' ) then
c     check other user-defined functions and local values
             do 1600  jv = 1, nmathx
                if ((icdval(1,jv).gt.0).and.
     $               (icdval(1,jv).le.ixlocl)) then
                   do 1500 i = 1, micode
                      if (icdval(i,jv).eq.iv) go to 1990
 1500              continue
                elseif(icdval(1,jv).gt.ixlocl) then
                   ilcl = icdval(1,jv) -ixlocl
                   do 1560 id = 1, ndata
                      do 1530 i = 1, micode
                         if (icdloc(i,ilcl,id).eq.iv) go to 1990
 1530                 continue
 1560              continue
                endif
 1600        continue
c     check path parameters
             do 1850  inpath = 1, mpaths
                do 1820  jpar = 1, mpthpr
                   do 1800 i   = 1, micode
                      if (icdpar(i,jpar,inpath).eq.iv) go to 1990
 1800              continue
 1820           continue
 1850        continue
             call finmsg(3240,vnames(iv),' ',-1)
          end if
 1990     continue
 2000  continue
c
c  load default path params from the Oth  path.  copy 0th path param
c  to all non-explicitily given path params for that data set.
       do 4200 idata = 1, ndata
          inpth0  = jdtpth(0,idata)
c   if a 0th path is given for this data set...
          if (inpth0.le.0)  go to 4190
c   check all paths for this data set ...
          do 4150 idpath = 1, mdpths
             inpath = jdtpth(idpath, idata)
             if (inpath.gt.0) then
c   that if a zeroth path param was given ***and***
c   an explicit path param was ***not*** given ...
                do 4100 ipar = 1, mpthpr
                   if ((icdpar(1,ipar,inpath).eq.0).and.
     $                  (icdpar(1,ipar,inpth0).ne.0))   then
c   that the zeroth path expression be copied.
                      do 4050 j = 1, micode
                         icdpar(j,ipar,inpath) = icdpar(j,ipar,inpth0)
 4050                 continue
                   endif
 4100           continue
             endif
 4150        continue
 4190     continue
 4200  continue
c
c  check the newly encoded expressions by evaluating them.
c  evaluate the user defined values
       id  = 1
       call setval(1,nmathx,icdval,maxval,micode,
     $      consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
       return
c  end subroutine fitchk
       end
       subroutine fixicd(icdval, maxval, micode, jconst, jxlocl,
     $               vnames, xval, nvar, nconst, ntotal,io2n)
c
c  fix integer code arrays from encod so that :
c     1.  all variables come first
c     2.  all true constants come next (well, most ...)
c     3.  all other math expressions are ordered so that each
c         depends on only its predecessors.  this allows
c         single-pass, ordered decoding.
c
c arguments
c   icdval  integer array codes from encod (micode, maxval)  (in/out)
c   maxval  dimension of icdval, vnames, xval                (in)
c   micode  dimension of icdval                              (in)
c   jconst  integer placeholder for constants (from encod)   (in)
c   jxlocl  integer placeholder for locals                   (in)
c   vnames  array of variable names                          (in/out)
c   xval    array of variables values/initial guesses        (in/out)
c   nvar    number of variables                              (out)
c   nconst  number of constants                              (out)
c   ntotal  total number of named parameters                 (out)
c   io2n    map    io2n(iold) = inew                         (out)
c notes:
c  1. jxlocl > jconst !!   jconst = 2000, jxlocl = 5000 at this writing.
c  2. elements   1      -> nvar          of icdval are variables
c     elements  nvar+1  -> nconst +nvar  of icdval are constants
c  3. the parameters mxval and mcode should be >= maxval, micode.
c  4. jfake1 and jfake2 are for the "fake constants" (like reff)
c     hardwired in feffit/encod to be held in the constant array,
c     even though their values are continually overwritten.  I don't
c     want to include them in the  "true constants" list here.
c
      integer  mxval , mcode, micode, maxval, jconst, jxlocl
      integer  icdval(micode, maxval), io2n(maxval), nvar, nconst
      real            xval(maxval),     zero
      character*(*)   vnames(maxval)
      parameter (mxval = 2048, mcode = 256, zero = 0.)
      integer    jfake1 ,  jfake2
      parameter (jfake1 = 4, jfake2 = 8)
      character*64 vnew(mxval), vorig(mxval)
      integer  icdnew(mcode, mxval), iold(mxval), inew(mxval)
      integer  io, in, ntotal, icd, ncandv, jv
      integer  iv, ivold, ivnew, itmp, i
      real     xnew(mxval), xxtmp
       integer   jdebye, jeins, jeins2
       parameter(jdebye=-120, jeins =-121, jeins2=-122)

c
       do 80 i = 1, maxval
          vnew(i) = ' '
          vorig(i)= vnames(i)
          xnew(i) = zero
          if (vnames(i).ne.' ')  ntotal = i
 80    continue
c
c reorder #1:  put variables 1st
      ivnew = 0
      do 100 iv = 1, ntotal
         if (icdval(1,iv).eq.-1) then
            ivnew        = ivnew + 1
            vnew(ivnew)  = vnames(iv)
            xnew(ivnew)  = xval(iv)
            inew(iv)     = ivnew
            iold(ivnew)  = iv
         end if
 100  continue
      nvar = ivnew
c
c reorder #2: put  constants 2nd
c   if                    1  <= icdval(i) <= jconst
c   or if    jfake1 + jconst <= icdval(i) <= jfake2 jconst
c   then its not a constant
      do 150 iv = 1, ntotal
         if ( (icdval(1,iv).ne.-1).and.
     $        (icdval(1,iv).le.jxlocl) ) then
            icd = 0
            do 130 i = 1, micode
               if (icdval(i,iv).eq.0) go to 135
               if ( (icdval(i,iv).eq.jdebye) .or.
     $              (icdval(i,iv).eq.jeins)  .or.
     $              (icdval(i,iv).eq.jeins2) ) icd = icd + 1
               if ( (icdval(i,iv).ge.1).and.
     $              (icdval(i,iv).lt.jconst) )  icd = icd + 1
               if ( (icdval(i,iv).ge.(jfake1+jconst)).and.
     $              (icdval(i,iv).le.(jfake2+jconst)) ) icd = icd + 1
 130        continue
 135        continue
            if (icd.eq.0) then
               ivnew       = ivnew + 1
               vnew(ivnew) = vnames(iv)
               xnew(ivnew) = xval(iv)
               inew(iv)    = ivnew
               iold(ivnew) = iv
            endif
         end if
 150  continue
      ncandv  = ivnew
      nconst  = ivnew - nvar
c
c reorder #3:  now put "local variables", all of which are marked with
c  an initial element larger that jxlocl that is much greater than
c  jconst (jxlocl = 5000, jconst = 2000  at this writing)
      do 240 iv = 1, ntotal
         if (icdval(1,iv).gt.jxlocl) then
            ivnew       = ivnew + 1
            vnew(ivnew) = vnames(iv)
            xnew(ivnew) = xval(iv)
            inew(iv)    = ivnew
            iold(ivnew) = iv
         endif
 240  continue
c
c add all the other math expressions to the new arrays.
c without worrying about order
      do 400 iv = 1, ntotal
         icd = 0
         do 360 i = 1, micode
            if (icdval(i,iv).eq.0) go to 370
            if ((icdval(i,iv).ge.1).and.
     $           (icdval(i,iv).lt.jconst ) )  then
               icd = icd + 1
               go to 370
            end if
            if ( (icdval(i,iv).eq.jdebye) .or.
     $           (icdval(i,iv).eq.jeins)  .or.
     $           (icdval(i,iv).eq.jeins2) ) then
               icd = icd + 1
               go to 370
            end if
            if ((icdval(i,iv).ge.(jfake1+jconst)).and.
     $          (icdval(i,iv).le.(jfake2+jconst)) ) then
               icd = icd + 1
               go to 370
            end if
 360     continue
 370     continue
         if (icd.ne.0) then
            ivnew        = ivnew + 1
            vnew(ivnew)  = vnames(iv)
            xnew(ivnew)  = xval(iv)
            inew(iv)     = ivnew
            iold(ivnew)  = iv
         endif
 400  continue
c
c now replace all occurances of iv with inew(iv) (= ivnew) in icdval.
      do 540 iv = 1, ntotal
         ivold = iold(iv)
         do 520 i = 1, micode
            if ((icdval(i,ivold).ge.1).and.
     $           (icdval(i,ivold).lt.jconst ) ) then
               icdnew(i,iv) = inew(icdval(i,ivold))
            else
               icdnew(i,iv) = icdval(i,ivold)
            endif
 520    continue
 540  continue
      do 600 iv = 1, maxval
         vnames(iv) = vnew(iv)
         xval(iv)   = xnew(iv)
         xnew(iv)   = zero
         vnew(iv)   = ' '
         iold(iv)   = 0
         inew(iv)   = 0
         do 580 i = 1, micode
            icdval(i,iv) = icdnew(i,iv)
 580     continue
 600  continue
c
c finally, put the math expressions in order
c a simple switch-in-place, with recovery
      do 900 iv = ncandv+1, ntotal
         itmp = ncandv
         do 750 i = 1, micode
            icd = icdval(i,iv)
            if (icd.eq.0) go to 760
            if ((icd.ge.ncandv).and.
     $           (icd.lt.jconst))  itmp = max(icd,itmp)
 750     continue
 760     continue
         if (itmp.gt.iv) then
            ivold = iv
            ivnew  = itmp
            do 780 i = 1, micode
               icdnew(i,1)     = icdval(i,ivnew)
               icdval(i,ivnew) = icdval(i,ivold)
               icdval(i,ivold) = icdnew(i,1)
 780        continue
            vnew(1)       = vnames(ivnew)
            vnames(ivnew) = vnames(ivold)
            vnames(ivold) = vnew(1)
            xxtmp         = xval(ivnew)
            xval(ivnew)   = xval(ivold)
            xval(ivold)   = xxtmp
            do 850 jv = ncandv+1, ntotal
               do 820 i = 1, micode
                  if (icdval(i,jv).eq.0) go to 830
                  if (icdval(i,jv).eq.ivold) then
                     icdval(i,jv) =  ivnew
                  elseif (icdval(i,jv).eq.ivnew) then
                     icdval(i,jv) =  ivold
                  endif
 820           continue
 830           continue
 850        continue
         end if
 900  continue
c
c now re-map old to new and return
      do 1000 io = 1, ntotal
         do 980 in = 1, ntotal
            if (vorig(io).eq.vnames(in)) then
               io2n(io) = in
               go to 990
            endif
 980     continue
 990     continue
 1000 continue
c
      return
c end subroutine fixicd
      end
       subroutine setval(n1, n2, icdval, mvals, micode, consts,
     $      mconst, vals, icloc, mloc, md,  ixlocl,  id)
c simple loop through resetting values using eval.
       implicit none
       integer  mconst, mvals, micode, mloc, md
       integer  ixlocl, i, id, n1, n2
       real     consts(mconst), vals(mvals), old, eval
       integer  icdval(micode, mvals), icloc(micode,mloc,md)
       external eval
       do 10 i = n1, n2
          old   = vals(i)
          vals(i) = eval(icdval, mvals, micode, consts,
     $         mconst, vals, old, icloc,
     $         mloc, md,  ixlocl,  id, i )
 10    continue
       return
       end
       real function eval(icode,mvals,micode,consts,mconst,
     $       vals,old,icloc,mloc,md,ixlcl, id, ieval)
c
c  evaluate integer codes of math expressions for "set" and "local"
c  valuess.  includes decision of whether the named value is global
c  ("set") or "local" to the data set.
c
c  notes:
c    1. the first m element of "i(1,i)" are i(1,i) to i(m,i).
c    2. the first element of the encoded integer arrays holds an
c       important clue about the nature of the math expression:
c        icode(1,i) = -1      variable
c        icode(1,i) =  0      unused
c        icode(1,i) >  0      user-defined function ("global")
c        icode(1,i) >  ixlcl  "local"
       integer  mconst, mvals, micode, mloc, md
       integer  ixlcl, ieval, jlcl, id
       real     consts(mconst), vals(mvals), old, decod
       integer  icode(micode, mvals), icloc(micode,mloc,md)
       external decod
       eval = old
       if (icode(1,ieval).gt.ixlcl) then
          jlcl = icode(1,ieval) - ixlcl
          eval = decod(icloc(1,jlcl,id), micode,consts,vals,old)
       elseif (icode(1,ieval).gt.0)  then
          eval = decod(icode(1,ieval),   micode,consts,vals,old)
       endif
       return
       end
       real function decod(icode, ni, consts, values, defval)
c
c  copyright 1993 .. 1997 matt newville
c
c   this decodes the icode array, inserting the values in consts,
c   and values when necessary, and returns the real value of the
c   calulated pararmeter.
c   the default value, defval, will be returned if icode is empty.
c
c  input:
c    icode    integer array containing code for the math expression
c    ni       length of icode
c    consts   real array of the constant numerical values
c    values   real array containing the variable values
c    defval   default value for the parameter
c  output:
c    decod    real number calculated from integer code in icode
c---------------------------------------------------------------------
       integer  mstack, ierr, iplace, istack, ic, i, ni
       real     f1mth, f2mth, zero, cordby, einsdw, einval
       integer  jconst, icode(ni)
       parameter(mstack=  32, jconst = 8192, zero = 0.)
       real     consts(*), values(*), x(mstack), defval
       integer  iexp, ilog, isqrt, isin, icos, itan, iabs, ineg
       integer  iasin, iacos, iatan, isinh, icosh, itanh, icoth
       integer  iadd, isub, imul, idiv, iy2x
       integer  jadd, jsub, jmin, jmax, jdebye, jeins, jeins2
       parameter(iexp  = -10, ilog  = -11, isqrt = -12,
     $           isin  = -13, icos  = -14, itan  = -15,
     $           iasin = -16, iacos = -17, iatan = -18,
     $           iabs  = -19, ineg  = -20, isinh = -23,
     $           icosh = -24, itanh = -25, icoth = -26,
     $           iadd  = -50, isub  = -51, imul  = -52,
     $           idiv  = -53, iy2x  = -54, jadd  =-111,
     $           jsub  =-112, jmin  = -85, jmax  = -86,
     $           jdebye=-120, jeins =-121, jeins2=-122)
       external  f1mth, f2mth, cordby, einsdw, einval
c
c  return default value if icode is empty
       decod = defval
       if (icode(1).eq.0)  return
c  initialize stack
       do 20 i = 1, mstack
          x(i) = zero
 20    continue
       ierr   = 0
       iplace = 0
       istack = 0
c  interpret next object, do operations, and manage stack
c                hold place in icode array with iplace
 100   continue
       iplace = iplace + 1
       if (iplace.gt.ni) ierr = 2
       ic = icode(iplace)
       if (ic.eq.0) return
c  if number, then push everything in stack
       if (ic.ge.1) then
          istack = istack + 1
          if (istack.ge.mstack) ierr = 1
          do 200 i = istack, 2, -1
             x(i) = x(i-1)
 200      continue
          if (ic.le.jconst) x(1) = values(ic)
          if (ic.gt.jconst) x(1) = consts(ic - jconst)
c  one-component math:  overwrite x(1), no change to rest of the stack
       elseif ( (ic.le.-10).and.(ic.ge.-49)) then
          x(1) = f1mth(x(1),ic,ierr)
c  two-component math:  overwrite x(1), drop x(2), drop stack by 1
       elseif ( (ic.le.-50).and.(ic.ge.-99)) then
          x(1) =  f2mth( x(1),x(2),ic,ierr)
          call stack(x,istack,1)
c  special math operations:
c    each has its own external function call, and stack size.
c      : debye( x(2), x(1))
       elseif (ic.eq.jdebye) then
          x(1) =  cordby(x(2), x(1), ierr)
          call stack(x,istack,1)
c      : eins( x(2), x(1))
       elseif (ic.eq.jeins) then
          x(1) =  einsdw(x(2), x(1), ierr)
          call stack(x,istack,1)
c      : eins2( x(3), x(2), x(1))
       elseif (ic.eq.jeins2) then
          x(1) =  einval(x(3), x(2), x(1))
          call stack(x,istack,2)
       else
          ierr = 3
       end if
c  done: if there were no errors, update decod and go to next object
       if (ierr.eq.0) then
          decod = x(1)
          go to 100
       end if
c  error handling: can only get here if (ierr.ne.0)
       decod  = zero
       if (ierr.eq.ilog) then
          call messag(' math error: log(x) must have x > 0')
       elseif (ierr.eq.isqrt) then
          call messag(' math error: sqrt(x) cannot have x < 0')
       elseif (ierr.eq.iasin) then
          call messag(' math error: asin(x) must have (-1 < x < 1)')
       elseif (ierr.eq.iacos) then
          call messag(' math error: acos(x) must have (-1 < x < 1)')
       elseif (ierr.eq.idiv) then
          call messag(' math error: divide by 0')
       elseif (ierr.eq.iy2x) then
          call messag(' math error: invalid exponentiation')
       elseif (ierr.eq.jdebye) then
          call messag(' math error: error using "debye" function')
          call messag('      could not find a path index to use!')
       elseif (ierr.eq.jeins) then
          call messag(' math error: error using "eins" function')
          call messag('      could not find a path index to use!')
       elseif (ierr.eq.1) then
          call messag(' decoding error: exceeded stack size!')
       elseif (ierr.eq.2) then
          call messag(' decoding error: too many objects!')
       elseif (ierr.eq.3) then
          call messag(' decoding error: unknown operation!')
       else
          call messag(' decoding error: unknown error!')
       end if
       if (ierr.gt.0) stop
       return
c  end function decod
       end
       real function f1mth( x, iop, ierr)
c
c  copyright 1993  university of washington      matt newville
c
c one component math. if any tests are failed, x is returned.
c iop is an integer indication of which operation to perform.
c
       real        x, zero, one, expmax
       logical     error
       integer     iop, ierr
       integer     iexp, ilog, isqrt, isin, icos, itan, iabs, ineg
       integer     iasin, iacos, iatan, isinh, icosh, itanh, icoth
       parameter ( iexp  = -10, ilog  = -11, isqrt = -12,
     $             isin  = -13, icos  = -14, itan  = -15,
     $             iasin = -16, iacos = -17, iatan = -18,
     $             iabs  = -19, ineg  = -20, isinh = -23,
     $             icosh = -24, itanh = -25, icoth = -26  )
       parameter (zero = 0., one = 1., expmax = 50.)
cc       real small
cc       parameter ( small = 2.e-22 )
       ierr  = 0
       error = .false.
       f1mth = zero
       if (iop.eq.iexp) then
          f1mth = exp( max( -expmax, min(x, expmax) ) )
       elseif (iop.eq.ilog) then
          if  ( x.gt.zero ) then
             f1mth = log(x)
          else
             error = .true.
          end if
       elseif (iop.eq.isqrt) then
          if  ( x.ge.zero) then
             f1mth = sqrt(x)
          else
             error = .true.
          end if
       elseif (iop.eq.iabs)  then
          f1mth = abs(x)
       elseif (iop.eq.ineg)  then
          f1mth = - x
       elseif (iop.eq.isin)  then
          f1mth = sin(x)
       elseif (iop.eq.icos)  then
          f1mth = cos(x)
       elseif (iop.eq.itan)  then
          f1mth = tan(x)
cc       elseif (iop.eq.icot)  then
cc          f1mth = one / max( small, tan(x) )
       elseif (iop.eq.iasin) then
          if (abs(x).le.one) then
             f1mth = asin(x)
          else
             error = .true.
          end if
       elseif (iop.eq.iacos) then
          if (abs(x).le.one) then
             f1mth = acos(x)
          else
             error = .true.
          end if
       elseif (iop.eq.iatan) then
          f1mth = atan(x)
       elseif (iop.eq.itanh) then
          f1mth = tanh(  max(-expmax, min(x, expmax)) )
       elseif (iop.eq.icoth) then
          f1mth = one / tanh(  max(-expmax, min(x, expmax)) )
       elseif (iop.eq.icosh) then
          f1mth = cosh(  max(-expmax, min(x, expmax)) )
       elseif (iop.eq.isinh) then
          f1mth = sinh(  max(-expmax, min(x, expmax)) )
       else
          f1mth = x
       end if
       if (error) ierr = iop
       return
c end function f1mth
       end
       real function f2mth( x, y, iop, ierr)
c
c  copyright 1993  university of washington      matt newville
c
c two component math.
c if ( (negative number)**(fraction)) is requested, x is returned.
c
c iop is an integer indication of which operation to perform.
c if iop = 0, then x is returned.
       real       x, y, zero, one, fifty, xtmp, test
       integer   ierr, iadd, isub, imul, idiv, iy2x, iop, newx
       integer   jmin, jmax
       parameter ( iadd = -50, isub = -51, imul  = -52)
       parameter ( idiv = -53, iy2x  = -54 )
       parameter ( jmin  = -85, jmax  = -86)
       parameter ( zero = 0., one = 1., fifty = 50. * one )
       ierr  = 0
       f2mth = zero
       if (iop.eq.0) then
          f2mth = x
       elseif (iop.eq.iadd) then
          f2mth = y + x
       elseif (iop.eq.isub) then
          f2mth = y - x
       elseif (iop.eq.imul) then
          f2mth = y * x
       elseif (iop.eq.jmin) then
          f2mth = min(y, x)
       elseif (iop.eq.jmax) then
          f2mth = max(y, x)
       elseif (iop.eq.idiv) then
          if (x.eq.zero)  then
             f2mth = zero
             ierr  = iop
          else
             f2mth = y / x
          end if
       elseif (iop.eq.iy2x) then
          newx = int(x)
          xtmp = float(newx)
          if (x.eq.zero)  then
             f2mth = one
          elseif ( (y.eq.zero).and.(x.gt.zero))  then
             f2mth = zero
          elseif (y.gt.zero)  then
             test  = x * log(y)
             if (test.gt.fifty) then
                f2mth = exp(fifty)
             elseif (test.lt.(-fifty)) then
                f2mth = exp(-fifty)
             else
                f2mth = y**x
             end if
          elseif ( (y.lt.zero).and.(xtmp.eq.x)) then
             test  = xtmp * log(-y)
             if (test.gt.fifty) then
                f2mth = exp(fifty)
             elseif (test.lt.(-fifty)) then
                f2mth = exp(-fifty)
             else
                f2mth = y**newx
             end if
          else
             f2mth = zero
             ierr  = iop
          end if
       end if
       return
c end function f2mth
       end
       subroutine stack(xstack,istack,ipop)
c
c   copyright 1993  university of washington      matt newville
c   drop the stack held in x by idrop. (ipop = 1 for 2 component math)
       real xstack(*)
       integer istack, ipop, i
       istack   = istack - ipop
       do 100 i = 2, istack
          xstack(i)  = xstack(i + ipop)
 100   continue
       do 120 i = istack + 1, istack + ipop
          xstack(i)  = 0.
 120   continue
       return
c  end subroutine stack
       end
       real function cordby(temp, thetad, ierr)
c
c  copyright 1993  university of washington      matt newville
c
c  returns xafs sigma^2 from correlated debye model a la jj rehr
c  important note:   the path information is passed in the
c      common block /fefdat/, and the value ixpath  specifies
c      which path sigma^2 is to be calculated for.
c  temp    temperature       [k]      (in)
c  theta   debye temperature [k]      (in)
c  cordby  sigma^2           [aa^2]   (out)
c-
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
       real     temp, thetad, tk, theta, sig2, rat(3,0:maxleg)
       integer  ierr, iz(0:maxleg), i, j, ipth
c
       ierr   = 0
       cordby = zero
       ipth   = min( mfffil, max(1, ixpath))
c
       tk     = temp
       theta  = thetad
       if (tk   .le.one) tk    = one
       if (theta.le.one) theta = one
       do 50 i = 0, nlgpth(ipth)
             iz(i)   = izpth(i,ipth)
             do 40 j = 1,3
                rat(j,i)  = ratpth(j,i,ipth)
  40         continue
  50   continue
       call sigms (tk, theta, rwgpth(ipth), nlgpth(ipth),rat,iz,sig2)
       cordby = sig2
       return
c  end function cordby
       end
       real function einsdw(temp, theta, ierr)
c
c  copyright 1994  university of washington      matt newville
c
c  return sigma^2 factor from einstein model.
c  important note:   the path information is passed in the
c      common block /fefdat/, and the value ixpath  specifies
c      which path sigma^2 is to be calculated for.
c   temp    temperature           [k]      (in)
c   thetae  einstein temperature  [k]      (in)
c   einsdw  sigma^2               [aa^2]   (out)
c-
       real      small
       parameter (small = 1.e-4)
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
       real     temp, theta, rmass, rtemp, atwts, einval
       integer  ierr, ipth, i, natoms
       external atwts, einval
       ierr   = 0
       einsdw = zero
       ipth   = min( mfffil, max(1, ixpath))
c  construct reduced mass (in amu) using function atwts
       natoms = nlgpth(ipth)
       rtemp  = zero
       rmass  = zero
       do 50 i = 1, natoms
          rmass  = max(one, atwts( izpth(i, ipth)) )
          rtemp  = rtemp +  one / rmass
  50   continue
       rmass  = max(small, rtemp)
       rmass  = one / rmass
c  call einval to get sigma squared
       einsdw = einval(temp, theta, rmass)
       return
c  end function einsdw
       end
       function einval(t,theta,rmass)
c
c  compute sigma^2 from the eisntein model
c    t       temperature          [K]    (in)
c    theta   einstein temperature [K]    (in)
c    rmass   reduced mass         [amu]  (in)
c    einval  sigma squared        [aa^2] (out)
       real       small, big, two, factor
       real       t, theta, rmass, x, t1, th1, rm1
       parameter (two    = 2., small = 1.e-3, big = 1.e8        )
       parameter (factor = 24.25423371)
cc       parameter (hbarc  = 1973.270533,  boltz = 8.617385e-5)
cc       parameter (amu2ev = 9.3149432e8          )
cc       parameter (factor = hbarc*hbarc/(two * boltz * amu2ev))
       th1  = max(small, theta)
       rm1  = max(small, rmass)
       t1   = max(small, t    )
       x    = max(small, min(big, th1 / (two * t1)))
       einval = factor / ( rm1 * th1 * tanh(x))
       return
c  end function einval
       end
       subroutine sigms (tk, theta, rs, nleg, rat, iz, sig2)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  the following routines calculate the debye-waller factor for a
c  path based on the temperature, debye temperature, average
c  norman radius, atoms in the path, and their positions.
c  these routines come courtesy of jj rehr and si zabinsky.
c  i changed them a bit.   matt n
c-------------------------------------------------------------------
c
c  from s i zabinsky.
c  inputs:
c       tk      temperature in degrees k
c       theta   debye temp in degrees k
c       rs      average wigner seitz or norman radius in bohr
c                     averaged over entire problem:
c                     (4pi/3)*rs**3 = sum( (4pi/3)rnrm**3 ) / n
c                     (sum is over all atoms in the problem)
c       nleg    nlegs in path
c       rat     positions of each atom in path (in bohr)
c       iz      atomic number of each atom in path
c output:
c       sig2    debye waller factor
c  notes:
c     all units of distance in this routine are angstroms
c     there are nleg atoms including the central atom.
c     index 0 and index nleg both refer to central atom.
       parameter (nlegx = 7, zero = 0., two = 2.)
       dimension rat(3,0:nlegx)
       dimension iz(0:nlegx)
c
       sig2   = zero
       do 800 i  = 1, nleg
         do 800 j = i, nleg
c
c  calculate r_i-r_i-1 and r_j-r_j-1 and the rest of the
c  distances, and get the partial cosine term:
c       cosine(i,j) = r_i.r_j / ((r_i - r_i-1) * (r_j - r_j-1))
           rij    = dist ( rat(1,i)  , rat(1,j)   )
           rimjm  = dist ( rat(1,i-1), rat(1,j-1))
           rijm   = dist ( rat(1,i)  , rat(1,j-1))
           rimj   = dist ( rat(1,i-1), rat(1,j)   )
           riim   = dist ( rat(1,i)  , rat(1,i-1))
           rjjm   = dist ( rat(1,j)  , rat(1,j-1))
           ridotj = (rat(1,i)-rat(1,i-1)) * (rat(1,j)-rat(1,j-1))
     $            + (rat(2,i)-rat(2,i-1)) * (rat(2,j)-rat(2,j-1))
     $            + (rat(3,i)-rat(3,i-1)) * (rat(3,j)-rat(3,j-1))
           cosijm = ridotj / (riim * rjjm)
c
c  call corrfn to get the correlations between atom pairs
           call corrfn (rij  , theta, tk, iz(i)  , iz(j)  , rs, cij)
           call corrfn (rimjm, theta, tk, iz(i-1), iz(j-1), rs, cimjm)
           call corrfn (rijm , theta, tk, iz(i)  , iz(j-1), rs, cijm)
           call corrfn (rimj , theta, tk, iz(i-1), iz(j)  , rs, cimj)
c
c  combine outputs of corrfn to give the debye-waller factor for
c    this atom pair.   !!! note: don't double count (i.eq.j) terms !!!
           sig2ij = ( cij + cimjm - cijm - cimj ) * cosijm / two
           if (j.eq.i) sig2ij = sig2ij / two
           sig2 = sig2 + sig2ij
 800   continue
       return
c  end subroutine sigms
       end
       subroutine corrfn(rij, theta, tk, iz1, iz2, rs, cij)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  subroutine calculates correlation function
c  c(ri, rj) = <xi xj> in the debye approximation
c
c            = (1/n)sum_k exp(ik.(ri-rj)) (1/sqrt(mi*mj))*
c                              (hbar/2w_k)*coth(beta hbar w_k/2)
c
c            = (3kt/mu w_d**2) * sqrt(mu**2/mi*mj) * int
c  where :
c       x        k_d*r (distance parameter)  r distance in angstroms
c       theta    debye temp in degrees k
c       tk       temperature in degrees k
c       temper   theta / tk = hbar omegad/kt
c       k_d      debye wave number = (6*pi**2 n/v)
c       n/v      free electron number density = 1/(4pi/3rs**3)
c       rs       wigner seitz or norman radius in bohr
c       ami      atomic mass at sites i in amu
c       amj      atomic mass at sites j in amu
c       int      int_0^1 (temper/x) dw sin(wx)coth(w*temper/2)
c
c  solution by numerical integration
c
c  parameters pi, bohr, con
c  con=hbar**2/kb*amu)*10**20   in ang**2 units
c  hbar=1.0549x10**-34 amu=1.65979x10-27kg kb=1.3807x10-23
       parameter (pi = 3.14159 26535 89793 23846 26433)
       parameter (one = 1., athird = one/3.)
       parameter (bohr = 0.529 177 249)
       parameter (con = 48.559)
       common /xtemp/ x, temper
c
c  theta in degrees k, t temperature in degrees k
       ami    = atwts(iz1)
       amj    = atwts(iz2)
       temper = theta / tk
       xkd    = (9.*pi/2.)**(athird) / (rs * bohr)
       x      = xkd * rij
c  call numerical integration
       call bingrt (xinteg, eps, nx)
       cij  = (3./2.) * xinteg * con / (theta * sqrt(ami*amj))
       return
c  end subroutine corrfn
       end
       function debfun(w)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  debfun = (sin(w*x)/x) * coth(w*temper/2)
c
       parameter (wmin = 1.e-20, argmax = 50.)
       common /xtemp/ x, temper

c  allow t = 0 without bombing
       debfun = 2 / temper
       if (w.gt.wmin) then
          debfun  = w
          if (x.gt.0) debfun = sin(w*x) / x
          emwt = 0
          argu = w*temper
          if (argu.lt.argmax) emwt = exp(-argu)
          debfun = debfun * (1 + emwt) / (1 - emwt)
       end if
       return
c  end function debfun
       end
       subroutine bingrt (b, eps, n)
c
c  copyright 1993  university of washington
c                  john rehr, steve zabinsky, matt newville
c
c  subroutine calculates integrals between [0,1]  b = int_0^1 f(z) dz
c  by trapezoidal rule and binary refinement  (romberg integration)
c  coded by j rehr (10 feb 92)   see, e.g., numerical recipes
c  for discussion and a much fancier version
c-----------------------------------------------
c     del=dz  itn=2**n tol=1.e-5
c     starting values
c      implicit double precision (a-h,o-z)
c     error is approximately 2**(-2n) ~ 10**(-.6n)
c     so nmax=10 implies an error of 1.e-6
c
       parameter(nmax = 10, tol = 1.e-5)
       parameter(zero=0., one=1., two=2., three=3., four=4.)
       external debfun
c
       n   = 0
       itn = 1
       del = one
       bn  = (debfun(zero) + debfun(one)) / two
       bo  = bn
 10    continue
c  nth iteration
c  b_n+1=(b_n)/2+deln*sum_0^2**n f([2n-1]deln)
         n   = n + 1
         if (n.gt.nmax) go to 40
         del = del / two
         sum = zero
         do 20 i= 1, itn
            zi  = (two * i - 1) * del
            sum = sum + debfun(zi)
 20      continue
c     bnp1=b_n+1 is current value of integral
c     cancel leading error terms b=[4b-bn]/3
c     note: this is the first term in the neville table - remaining
c           errors were found too small to justify the added code
         bnp1 = ( bn / two ) + del * sum
         b   = (four * bnp1 - bn) / three
         eps = abs( (b - bo) / b)
         if (eps.lt.tol) goto 60
         bn  = bnp1
         bo  = b
         itn = itn * 2
       goto 10
  40   continue
       return
 60    continue
       return
c end subroutine bingrt
       end
       real function atwts (iz)
c
c  returns atomic weight from atom number (iz)
c
       dimension atmass(103)
       data atmass /
     1   1.0079, 4.0026, 6.941,  9.0122, 10.81,   12.01,
     2   14.007, 15.999, 18.998, 20.18,  22.9898, 24.305,
     3   26.982, 28.086, 30.974, 32.064, 35.453,  39.948,
     4   39.09,  40.08,  44.956, 47.90,  50.942,  52.00,
     5   54.938, 55.85,  58.93,  58.71,  63.55,   65.38,
     6   69.72,  72.59,  74.922, 78.96,  79.91,   83.80,
     7   85.47,  87.62,  88.91,  91.22,  92.91,   95.94,
     8   98.91,  101.07, 102.90, 106.40, 107.87,  112.40,
     9   114.82, 118.69, 121.75, 127.60, 126.90,  131.30,
     x   132.91, 137.34, 138.91, 140.12, 140.91,  144.24,
     1   145,    150.35, 151.96, 157.25, 158.92,  162.50,
     2   164.93, 167.26, 168.93, 173.04, 174.97,  178.49,
     3   180.95, 183.85, 186.2,  190.20, 192.22,  195.09,
     4   196.97, 200.59, 204.37, 207.19, 208.98,  210,
     5   210,    222,    223,    226,    227,     232.04,
     6   231,    238.03, 237.05, 244,    243,     247,
     7   247,    251,    254,    257,    256,     254,
     8   257/
       atwts = atmass(iz)
       return
c  end function atwts
       end
       real function dist (r0, r1)
c  find distance between cartesian points r0 and r1
       dimension r0(3), r1(3)
       dist = 0
       do 10  i = 1, 3
          dist = dist + (r0(i) - r1(i))**2
 10    continue
       dist = sqrt(dist)
       return
c  end function dist
       end
       subroutine fefsrt( mfiles, mpaths, feffil, iffrec, jpthff)
c
c  this sorts the list of feff files so that feff.bin files (which
c  contain multiple paths) can  be read once, and in order, no matter
c  what the user-selected order was.
c  matt newville 1997
       integer mfiles, mpaths
       integer iffrec(mfiles), jpthff(mpaths)
       character*(*)  feffil(mfiles)

       integer  maxpth, maxfil
       parameter (maxpth = 2048, maxfil = 2048)
       integer jsave(maxfil), jffpth(maxfil)
       integer jfftmp(maxfil), ifftmp(maxfil)
       character*128 tmpfil(maxfil)
       if (mfiles.gt.maxfil) stop ' increase maxfil in fefsrt'
       if (mpaths.gt.maxpth) stop ' increase maxpth in fefsrt'
       naxpth = min(mpaths,maxpth)
c  there are a lot of path indices here, and they get confusing.
c  here's a menu:
c     iuser   "user path index"      what the user wrote in feffit.inp
c     inpath  "internal path index"  which set of path params to use
c     ifeff   "feff path index"      which feff file to use
c     idpath  "data path index"      which internal path is this for this
c                                    data set, when summing over paths
c  idpath is the key, and gives the rest using pointers in common blocks:
c     inpath = jdtpth(idpath,idata)
c     iuser  = jdtusr(idpath,idata)
c     ifeff  = jpthff(inpath)

       do 20 i = 1, naxpth
          jsave(i) = jpthff(i)
 20    continue
       do 25 i = 1, maxfil
          tmpfil(i) = ' '
          jfftmp(i) = 0
          ifftmp(i) = 0
 25    continue
c construct jffpth array {pointing  backwards from jpthff:
c     ifeff  = jpthff(inpath)
c     inpath = jffpth(ifeff)   }
       itmp  = 0
       do 50 i = 1, mfiles
          jffpth(i) = 0
          do 30 j = 1, mpaths
             if (jpthff(j).eq.i)  then
                jffpth(i) = j
                go to 32
             end if
 30       continue
 32       continue
          if ((feffil(i).ne. ' ').and.(iffrec(i).eq.0)) then
             itmp = itmp+1
             tmpfil(itmp) = feffil(i)
             ifftmp(itmp) = 0
             jfftmp(itmp) = jffpth(i)
             feffil(i)    = ' '
          end if
 50    continue
c
c group paths by file name:
       do 100 i = 1, mfiles
          if ((feffil(i).ne. ' ').and.(iffrec(i).ne.0)) then
             itmp = itmp+1
             i1   = itmp
             tmpfil(itmp) = feffil(i)
             ifftmp(itmp) = iffrec(i)
             jfftmp(itmp) = jffpth(i)
             do 90 j = min(mfiles,i+1), mfiles
                if (feffil(j).eq.feffil(i)) then
                   itmp = itmp+1
                   tmpfil(itmp) = feffil(j)
                   ifftmp(itmp) = iffrec(j)
                   jfftmp(itmp) = jffpth(j)
                   feffil(j)    = ' '
                end if
 90          continue
             feffil(i) = ' '
c sort entries with same path names:  elements i1 to itmp:
             if (i1.lt.itmp) then
                n = itmp - i1 + 1
                call sort2i(n,ifftmp(i1),jfftmp(i1))
             end if
          end if
 100   continue
c replace original arrays with new, sorted values
       do 500 i = 1, mfiles
          feffil(i) = tmpfil(i)
          iffrec(i) = ifftmp(i)
 500   continue
       do 700 i = 1,naxpth
          if (jsave(i).ne.0) jpthff(i) = jsave(jfftmp(jsave(i)))
 700   continue

       return
       end


       subroutine sort2(n, ra, rb)
c heap sort real array ra of length n to ascending order,
c and make the corresponding rearrangement to rb.
       real ra(n), rb(n), xa, xb
       integer n, l, ir
       l  = n / 2 + 1
       ir = n
c heap creation phase
c index l is decremented from its initial value down to 1
 10    continue
       if (l.gt.1) then
          l  = l - 1
          xa = ra(l)
          xb = rb(l)
c heap selection phase
c index ir is decremented from its initial value to to 1
       else
          xa = ra(ir)
          xb = rb(ir)
          ra(ir) = ra(1)
          rb(ir) = rb(1)
          ir = ir - 1
          if (ir.eq.1) then
             ra(1) = xa
             rb(1) = xb
             go to 50
          end if
       end if
c sift down xa
       i = l
       j = l + l
 20    continue
       if (j.le.ir) then
c found better low element
          if ((j.lt.ir).and.(ra(j).lt.ra(j+1))) j = j + 1
c demote xa
          if (xa.lt.ra(j)) then
             ra(i) = ra(j)
             rb(i) = rb(j)
             i = j
             j = j + j
          else
             j = ir + 1
          end if
c ends the sift-down
          go to 20
       end if
c restore xa and xb
       ra(i) = xa
       rb(i) = xb
       go to 10
c      return
 50    continue
       return
c  end subroutine sort2
       end

       subroutine sort2i(n, ira1, ira2)
c
c      sort an array ira1 of length n into ascending order,
c      while making the corresponding rearrangement to rb.
c      the sorting is done by the heapsort algorithm
c
       integer  ira1(n), ira2(n)
       l  = n / 2 + 1
       ir = n
c
c   index l will be decremented from its initial value down to 1
c   during the hiring phase (heap creation). Once l reaches 1, the
c   index ir will be decremented from its initial value to to 1
c   during the retirement-and-promotion (heap selection) phase.
c
 10    continue
c                                           heap creation phase
          if (l.gt.1) then
               l      = l - 1
               ia1    = ira1(l)
               ia2    = ira2(l)
c                                           heap selection phase
          else
               ia1    = ira1(ir)
               ia2    = ira2(ir)
               ira1(ir) = ira1(1)
               ira2(ir) = ira2(1)
               ir     = ir - 1
               if (ir.eq.1) then
                    ira1(1) = ia1
                    ira2(1) = ia2
                    go to 50
               end if
          end if
c                                           set up to sift down ia1.
          i = l
          j = l + l
c                                           do while j.le.ir
 20       continue
          if (j.le.ir) then
c                                           better low element
              if (j.lt.ir) then
                    if ( ira1(j).lt.ira1(j+1) )j = j + 1
              end if
c                                           demote ia1
              if (ia1.lt.ira1(j)) then
                    ira1(i) = ira1(j)
                    ira2(i) = ira2(j)
                    i     = j
                    j     = j + j
c                                           terminate the sift-down
              else
                    j     = ir + 1
              end if
              go to 20
          end if
c                                           put ia1, ia2 into slots
          ira1(i) = ia1
          ira2(i) = ia2
          go to 10
c  return
 50    continue
       return
c  end subroutine sort2i
       end
       subroutine fefinp(mpts, mfil, mtitle, mleg, title, feffil,
     $      iffrec, degflg, degpth, refpth, rwgpth, ratpth, theamp,
     $      thepha,  qfeff,  realp,  xlamb, nlgpth,  izpth, iptpth)
c
c    read path information from feff files:
c    readse either feffnnnn.dat files (feff5 or higher) or the
c    ascii feff.bin files from feff702
c
c    copyright 1996        matt newville
       integer   mpts, mfil, mtitle, mleg
       real     degpth(mfil), refpth(mfil), rwgpth(mfil)
       real     ratpth(3, 0:mleg, mfil), qfeff(mpts, mfil)
       real     theamp(mpts, mfil), thepha(mpts, mfil)
       real     realp( mpts, mfil), xlamb( mpts, mfil)
       integer  nlgpth(mfil), iffrec(mfil)
       integer  izpth(0:mleg, mfil), iptpth(0:mleg, mfil)
       character*128 title(mtitle, mfil), feffil(mfil)

       integer   mlegx, mptsx, mwords
       parameter (mlegx = 10, mptsx= 100, mwords = 30, mdocx=10)
       character*64  filnam*128, stat*10, str*128, words(mwords)
       character*128 doc(mdocx), messg
       logical    degflg, exist
       integer    izpot(0:mlegx)
       complex    phc(mptsx), ck(mptsx), coni, cchi
       real       xk(mptsx), achi(mptsx), phchi(mptsx), beta(mlegx)
       real       eps, phff, phffo, xlam, reff, bohr, zero
       parameter (zero = 0, eps = 1.e-12, bohr = 0.529 177 249)
       parameter (coni = (0,1))
       data stat /'old'/
c  feff.dat data extraction
c  loop to get data from at most maxpth paths
       ipth = 0
  50   continue
       ipth = ipth + 1
c   skip unused paths
       if ((ipth.le.mfil).and.(feffil(ipth).ne.' ')) then
c   get next file name from feffil, check that it exists
          exist  = .false.
          filnam = feffil(ipth)
          call triml (filnam)
          ilen = max(1, istrln(filnam))
          inquire ( file = filnam,  exist = exist)
c  failed to find this file: stop with warning message
          if (.not.exist) call finmsg(1001,filnam, ' ',0)
c  read data from file
          if (iffrec(ipth).eq.0) then
c feff5-style feffnnnn.dat file
             call messag( '        '//filnam(1:ilen))
             call rdffdt(filnam,mtitle,mleg,mpts,ntitle,nlgpth(ipth),
     $            npts,title(1,ipth), refpth(ipth), rwgpth(ipth),
     $            degpth(ipth), ratpth(1,0,ipth), iptpth(0,ipth),
     $            izpth(0,ipth), qfeff(1,ipth),theamp(1,ipth),
     $            thepha(1,ipth), xlamb(1,ipth), realp(1,ipth))
             if (.not.degflg) degpth(ipth) = 1
          elseif (iffrec(ipth).ne.0) then
c feff7-style feff.bin
             iunit = 0
             call openfl(iunit,filnam,stat,iex,ierr)
             if ((iex.lt.0).or.(ierr.lt.0))
     $            call finmsg(1003,filnam, ' ',0)
c read top of feff.bin for all the records from this file
             call rdfb1(filnam,iunit,mdocx,mlegx,mptsx, ndoc, npot,
     $            npts, rnrmav, l0, doc,izpot,phc,ck,xk)
c skip to next record within this file
 120         continue
             read(iunit,'(a)',end=500) str
             call sclean(str)
             call triml(str)
             if (str(1:2).ne.'##')   go to 120
             nwords = 1
             call bwords(str(3:),nwords,words)
             call str2in(words(1) , itmp, ierr)
c  skip this record (and go to next) if this isn't the record we want
             if (itmp.ne.iffrec(ipth)) go to 120
c we found the right record:  read in path information
             ilen = istrln(filnam)
             write(messg,'(a,1x,a,1x,i5)')
     $            filnam(1:ilen), ',', iffrec(ipth)
             ilen = istrln(messg)
             call messag( '              '//messg(1:ilen))
             rwgpth(ipth) = rnrmav
             do 145 i = 1, ndoc
                title(i,ipth) =  doc(i)
 145         continue
             nwords = mwords
             call bwords(str(3:),nwords,words)
             call str2in(words(2), nleg, ierr)
             nlgpth(ipth) = nleg
             call str2re(words(3), degpth(ipth), ierr)
             call str2in(words(4), nepts, ierr)
             call str2re(words(5), refpth(ipth), ierr)
             reff  = refpth(ipth) / bohr
             do 170 j = 1, nleg
                call str2in(words(6+j),i,ierr)
                iptpth(j,ipth) = i
                izpth(j,ipth) = izpot(i)
 170         continue
             iptpth(0,ipth) = 0
             izpth(0,ipth)  = izpot(0)
             call rdpadr(iunit,ratpth(1,1,ipth),3*nleg)
             do 190 i = 0, nleg
                do 185 j = 1, 3
                   ratpth(j,i,ipth) = ratpth(j,i,ipth) * bohr
 185            continue
 190         continue
c  note that we really don't care about beta, eta, ri arrays, so we'll
c  just skip them here:
             call rdpadr(iunit,beta,nleg)
             call rdpadr(iunit,beta,nleg)
             call rdpadr(iunit,beta,nleg)
c but we really want these arrays (amplitude and phase)
             call rdpadr(iunit,achi,nepts)
             call rdpadr(iunit,phchi,nepts)
             do 230 j = nepts+1, mptsx
                achi(j)  = zero
                phchi(j) = zero
 230         continue
c now convert this into same info as in feff.dat file
             npts = min(mptsx,npts,mpts)
             phffo = zero
             rf2b  =  reff*reff*bohr
             do 300 i = 1, npts
                cchi = achi(i) * exp (coni*phchi(i))
                if (abs(aimag(ck(i))) .gt. eps) then
                   xlam= 1/aimag(ck(i))
                else
                   xlam = 1.e10
                end if
                if (abs(cchi).ge.eps) then
                   phff = atan2 (aimag(cchi), real(cchi))
                else
                   phff = zero
                end if
c  remove 2 pi jumps in phases
                call pijump (phff, phffo)
                phffo  = phff
c  save values to arrays
                qfeff(i,ipth) = xk(i) / bohr
                realp(i,ipth) = real ( ck(i) / bohr )
                xlamb(i,ipth) = xlam  * bohr
                thepha(i,ipth)= phff
                theamp(i,ipth)= abs(cchi*xk(i)*exp(2*reff/xlam))*rf2b
 300         continue
c
c fill in the rest of qfeff so that it is monotonically increasing
             do 350  i = npts+1, mpts
                if(qfeff(i,ipth).lt.qfeff(i-1,ipth)) then
                   qfeff(i,ipth) = 2*qfeff(i-1,ipth)-qfeff(i-2,ipth)
                   theamp(i,ipth)= zero
                end if
 350         continue
c
c if the next {feffil,iffrec} set has the same file name,
c read the next record
             if ((ipth.lt.mfil) .and.
     $            (feffil(ipth+1).eq.feffil(ipth))) then
                ipth = ipth + 1
                go to  120
             end if
 500         continue
             close(iunit)
c  done reading feff.bin entry
          end if
          go to 50
c
       end if
       return
 998   format(a1,a)
 999   format(a)
c end subroutine fefinp
       end
       subroutine rdffdt(filnam,mtitle,mleg,mpts, ntitle, nleg, npts,
     $      title, reff, rwignr, degen, xyz, ipot, iz,
     $      qf,amplit,phase,xlamb,realp)
c
c  read a feffnnnn.dat file
       integer      mtitle, mleg, mpts, ntitle, nleg, npts
       character*(*) filnam, title(mtitle)
       integer       ipot(0:mleg), iz(0:mleg)
       real    reff, rwignr, degen, xyz(3,0:mleg)
       real    qf(mpts), amplit(mpts), phase(mpts)
       real    xlamb(mpts),realp(mpts), zero

       character*40 stat*5, line*90, words(6)
       integer  iunit, iex, ierr
       parameter (zero = 0)
       real   cdel, afeff,phfeff, redfac, xk, xlmda ,  preal
       data  stat /'old'/

       iunit = 0
       xk    = zero
       call openfl(iunit, filnam , stat, iex, ierr)
       if ((iex.lt.0).or.(ierr.lt.0)) call finmsg(1003,filnam, ' ',0)
c  read top of feff.dat, keeping first mtitle comment lines
       ntitle = 0
 150   continue
       ntitle = ntitle + 1
       read(iunit,999) line
       call triml(line)
       if (line(3:6) .eq. '----')  goto 200
       if (ntitle.le.mtitle) title(ntitle) = line
       go to 150
 200   continue
c   read and save reff and degen: feff version 5.03 and higher
       read(iunit,999) line
       nwords = 4
       call bwords(line(2:), nwords, words)
       call str2in(words(1), nleg,   ier1)
       if (nleg .gt. mleg) call finmsg(7020,filnam, ' ',mleg)
       call str2re(words(2), degen,  ier2)
       call str2re(words(3), reff,   ier3)
       call str2re(words(4), rwignr, ier4)
       if ( (ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0).or.
     $      (ier4.ne.0) )   call finmsg(7010,filnam, ' ',0)

c   skip label and read and save path coordinates information
       read(iunit,999) line
       nwords = 5
       do 300  ileg = 0, nleg - 1
          read(iunit,999) line
          call bwords ( line(2:), nwords, words)
          do 270 ix = 1, 3
             call str2re( words(ix), xyz(ix,ileg),ierr )
 270      continue
          call str2in( words(4), ipot(ileg), ierr )
          call str2in( words(5), iz(ileg), ierr )
 300   continue
c      fill in last coordinate = first coordinate
       do 350  ix = 1, 3
          xyz(ix,nleg) = xyz(ix,0)
 350   continue
       iz(nleg)   = iz(0)
       ipot(nleg) = ipot(0)
c
c  skip one line then
c  read in q, amplit, phase, and real and imag parts of p
       read(iunit,999) line
       do 500 i = 1, mpts + 1
          read(iunit,*, end = 505) xk, cdel, afeff, phfeff,
     $        redfac, xlmda, preal
          if (i.gt.mpts) call finmsg(7050,filnam,' ', -int(xk) )
          qf(i)     = xk
          amplit(i) = afeff * redfac
          phase(i)  = cdel  + phfeff
          xlamb(i)  = xlmda
          realp(i)  = preal
 500   continue
 505   continue
       npts = i - 1
       close(iunit)
c
c  make sure no 2pi jumps in phase
       do 800  i = 2, npts
          call pijump ( phase(i), phase(i-1))
 800   continue
c
c  check that qf is monotonically increasing, filling in the high k
c  points if needed (feff provides monotonically increasing data, so the
c  first npts of qf are ok -- we just want to fill in the rest
c  of the points for later extrapolations)
       do 850  i = npts,  mpts
          if (qf(i).lt.qf(i-1)) then
             qf(i)=2*qf(i-1)-qf(i-2)
             amplit(i) = zero
             phase(i)  = zero
             realp(i)  = zero
             xlamb(i)  = 1.e10
          end if
 850   continue
c      done
       return
 999   format(a)
c end subroutine rdffdt
       end
       subroutine rdfb1(filnam,iunit,mtitle,mleg,mpts,
     $      ntitle,npot,npts,rnrmav,l0,title,izpot,phc,ck,xk)
c
c  read top of feff.bin
       character*(*) filnam, title(mtitle)
       integer izpot(0:mleg)
       complex phc(mpts), ck(mpts)
       real    xk(mpts), rnrmav
       integer  mwords, ierr, nwords
       character*128 str
       parameter (mwords = 20 )
       character*30 words(mwords)

 10    format(a)
c first line identifies file (only)
       read(iunit,10) str
       call triml(str)
       if ((str(1:10).ne.'#_feff.bin')) call finmsg(7510,filnam,' ',0)
       ivers = 1
ccc       if (str(1:14).eq.'#_feff.bin fil')   ivers = 1
       if (str(1:14).eq.'#_feff.bin v02')   ivers = 2
       
c second line contains ntitle, npot, npts
       read(iunit,10) str
       call triml(str)
       if ((str(1:2).ne.'#_')) call finmsg(7510,filnam,' ',0)
       nwords = 3
       call bwords(str(3:),nwords,words)
       if (nwords.ne.3)     call finmsg(7510,filnam,' ',0)
       call str2in(words(1), ntext, ier1)
       call str2in(words(2), npot,   ier2)
       call str2in(words(3), npts,   ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0))
     $      call finmsg(7510,filnam,' ',0)
c title lines
       ntitle = min(ntext,mtitle)
       do 20  i = 1, ntext
          read(iunit,10) str
          call triml(str)
          if (str(1:2).ne.'#"') call finmsg(7510,filnam,' ',0)
          if (i.le.ntitle) title(i) = str(3:)
 20    continue
c line with several numbers, only rnrmav and l0 are needed for exafs
       read(iunit,10) str
       call triml(str)
       if (str(1:2).ne.'#&') call finmsg(7510,filnam,' ',0)
       nwords = 8
       call bwords(str(3:),nwords,words)
       if (ivers.eq.1) then 
           if (nwords.ne.8) call finmsg(7510,filnam,' ',0)
           call str2re(words(3), rnrmav, ierr)
           call str2in(words(8), l0, ierr2)
           if ((ierr.ne.0).or.(ierr2.ne.0))
     $          call finmsg(7510,filnam,' ',0)
        elseif (ivers.eq.2) then 
           if (nwords.ne.5) call finmsg(7510,filnam,' ',0)
           call str2re(words(2), rnrmav, ierr)
           call str2in(words(5), l0, ierr2)
           if ((ierr.ne.0).or.(ierr2.ne.0))
     $          call finmsg(7510,filnam,' ',0)
        end if
c read pot labels and atomic numbers
       read(iunit,10) str 
       call triml(str)
       if (str(1:2).ne.'#@') call finmsg(7510,filnam,' ',0)
       nwords = min(mwords, 2 * npot + 2 )
       call bwords(str(3:), nwords, words)
       if (nwords.ne.(2 + 2*npot)) call finmsg(7510,filnam,' ',0)
       do 30 i = 0, npot
          call str2in(words(2+npot+i),izpot(i),ierr)
          if (ierr.ne.0)  call finmsg(7510,filnam,' ',0)
 30    continue 
c
c read packed arrays for momentum pieces
       call rdpadc(iunit,phc,npts)
c note: the next array is erefim but we don't care about it for 
c       exafs, so we'll read it as xk, just as a place holder.
cc     call rdpadr(iunit,erefim,npts)
       call rdpadr(iunit,xk,npts)
       call rdpadc(iunit,ck,npts)
c ... now really read xk for real 
       call rdpadr(iunit,xk,npts)
c done
       return
       end
      double precision  function unpad(str)
c      real function unpad(str)
c  convert packed-ascii-data string to real number
c        include 'padcom.h'
c{padcom.h:  parameters for packed-ascii-data (pad) routines
       implicit none
       character*1 cpadr, cpadi, cpadc
       integer     npack, maxlen, ibase, ioff, ihuge
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(npack =  6, maxlen = 75)
       parameter(ibase = 90, ioff = 37, ihuge = 35)
       parameter(zero=0d0, one=1d0, ten= 10d0, tenlog= 2.302585093d0)
       parameter(huge= ten**ihuge, tiny= one/huge, base= one*ibase)
c padcom.h}

       double precision sum
       integer   iexp, itmp, isgn, i
       character str*(*)
c
       unpad = zero
cc       if (npack.le.2) print*, ' houston, we have a problem'
       iexp  =     (ichar(str(1:1)) - ioff   ) - (ibase / 2)
       isgn  = mod (ichar(str(2:2)) - ioff, 2) * 2 - 1
       itmp  =     (ichar(str(2:2)) - ioff   ) / 2
       sum   = dble(itmp/(base*base))
       do 100 i = 3, npack
          sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
 100   continue
       unpad = 2 * isgn * base * sum * (ten ** iexp)
       return
       end
       subroutine rdpadr(iou,array,npts)
c read real array from packed-ascii-data file
c arguments:
c   iou    unit to read from (assumed open)                 (in)
c   array  real array                                       (out)
c   npts   number of array elements to read / number read   (in/out)
c notes:
c   packed-ascii-data string converted to real array using  unpad
c        include 'padcom.h'
c{padcom.h:  parameters for packed-ascii-data (pad) routines
       implicit none
       character*1 cpadr, cpadi, cpadc
       integer     npack, maxlen, ibase, ioff, ihuge
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(npack =  6, maxlen = 75)
       parameter(ibase = 90, ioff = 37, ihuge = 35)
       parameter(zero=0d0, one=1d0, ten= 10d0, tenlog= 2.302585093d0)
       parameter(huge= ten**ihuge, tiny= one/huge, base= one*ibase)
c padcom.h}

       integer iou, npts, ndline, i, istrln, ipts
       real    array(*)
       double precision unpad
       character  str*128, ctest*1, ccomp*1
       external  unpad
       ccomp = cpadr
       ipts = 0
 10    continue
          read(iou, 100, end = 50) str
          call sclean(str)
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = istrln(str)/npack
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts  = ipts + 1
             array(ipts) = unpad(str(1-npack+i*npack:i*npack))
             if (ipts.ge.npts) go to 50
 30       continue
          go to 10
 50    continue
       return
 100   format(a)
 200   continue
       call messag(' rpadr failed')
       stop
       end
       subroutine rdpadc(iou,array,npts)
c read complex array from packed-ascii-data file
c arguments:
c   iou    unit to read from (assumed open)                 (in)
c   array  complex array                                    (out)
c   npts   number of array elements to read / number read   (in/out)
c notes:
c   packed-ascii-data string converted to real array using  unpad
c        include 'padcom.h'
c{padcom.h:  parameters for packed-ascii-data (pad) routines
       implicit none
       character*1 cpadr, cpadi, cpadc
       integer     npack, maxlen, ibase, ioff, ihuge
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(npack =  6, maxlen = 75)
       parameter(ibase = 90, ioff = 37, ihuge = 35)
       parameter(zero=0d0, one=1d0, ten= 10d0, tenlog= 2.302585093d0)
       parameter(huge= ten**ihuge, tiny= one/huge, base= one*ibase)
c padcom.h}

       integer iou, npts, ndline, i, istrln, ipts, np
       double precision  unpad, tmpr, tmpi
       complex  array(*)
       character  str*85, ctest*1, ccomp*1
       external  unpad
       ccomp = cpadc
       ipts = 0
       np   = 2 * npack
 10    continue
          read(iou, 100, end = 50) str
          call sclean(str)
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = istrln(str)/ np
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts = ipts + 1
             tmpr = unpad(str(1-np+i*np:-npack+i*np))
             tmpi = unpad(str(1-npack+i*np:i*np))
             array(ipts) = cmplx(tmpr, tmpi)
             if (ipts.ge.npts) go to 50
 30       continue
          go to 10
 50    continue
       return
 100   format(a)
 200   continue
       call messag(' rpadc failed')
       stop
       end
       subroutine fitck2
c
c  this routine is part of feffit: does some  checking of math
c    expressions for path parameters for the "reasonableness"
c    of their initial values,  so that deltar is not 100.0, etc.
c  note: this needs to be called *after* the feff.dat info is read
c
c      copyright 1993 university of washington         matt newville
c----------------------------------------------------------------
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}

       real      par, pmax(mpthpr), small
       parameter (small = 0.001)
       character*20  setchr
c  these are the magnitudes of the upper limits for "reasonable"
c  initial values -- they're pretty darn big
       data pmax(jps02),  pmax(jpe0)     / 1.e6, 20.0 /
       data pmax(jpdelr), pmax(jpsig2)   / 0.50, 0.30 /
       data pmax(jpei),   pmax(jpdpha)   / 20.0, 1.e2 /
       data pmax(jp3rd),  pmax(jp4th)    / 0.20, 0.10 /
c----------------------------------------------------------------------
c  evaluate the non-variable values
c       print*, ' fitck2!!'
       nstart = nconst + numvar + 1
       do 1000 id  = 1, ndata
c    first all the "set values"
          call setval(nstart,nmathx,icdval,maxval,micode,
     $      consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
c  now test the values of the path parameters for sane guesses
c  also does error checking of whether all the path info is there, so
c  that such checks aren't needed in fitfun/fitout
          do 950 ipath = 1, mdpths
             inpath = jdtpth(ipath, id)
             if (inpath.gt.0) then
                jfeff  = jpthff(inpath)
                if (jfeff.le.0) then
                   jdtpth(ipath,id) = -1
                   go to 940
                end if
                juser  = jdtusr(ipath, id)
                if (refpth(jfeff).le.small) then
                   jdtpth(ipath,id) = -1
                   jpthff(inpath)   = -1
                   go to 940
                end if
                consts(4) =  refpth(jfeff)
                do 920 i = 1, mpthpr
                   par = abs(decod(icdpar(1, i, inpath),
     $                  micode, consts, values, defalt(i)))
                   if (par.gt.pmax(i)) then
                      write (messg,'(a,i3)') 'for path ',juser
                      if (ndata.gt.1) then
                         write (setchr,'(a,i3)') ' of data set ',id
                         call append(messg,setchr,il)
                      endif
                      call finmsg(3300,parnam(i),messg,-1)
                   end if
 920            continue
             endif
 940         continue
 950      continue
 1000  continue
       return
c  end subroutine fitck2
       end
       subroutine fitnls
c
c    this will call lmdif1, a routine from minpack, to solve the
c    unconstrained non-linear least squares fitting problem using
c    a levenberg-marquardt algorithm. the subroutine fitfun is
c    used to evaluate the function to be minimized in the least
c    squares sense.
c
c      copyright 1993 university of washington         matt newville
c
c    the outline of this routine is:
c    1.  an estimate of the measurement uncertainty is made by
c        using the high r components of the data (unless the user
c        has overwritten this value).
c    2.  the arrays for the call to lmdif1 are setup, and the call
c        to lmdif1 is made.
c    3.  after a successful fit has been found, the uncertainties
c        in the fit parameters are estimated by assuming that the
c        errors are normally distributed, so that the correlation
c        matrix is the inverse of the curvature of parameter space
c        around the solution.
c
c--------------------------------------------------------------------
ccc       implicit none
c        include 'fitcom.h'
c{fitcom.h
c  common blocks for feffit
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c fitcom.h}
c---------------------------------------------------------------------
       integer     lenwrk,  lenfvc, istrln, im, ier, ierr, ilen, ione
       integer     lminfo, iflag, nfirst, nr1, nr2, mfit, nsigd
       integer     nrwght, irun, iex, id, i, istop, nrmin,nrmax
       parameter(lenwrk = 2*maxpts*(mvarys + 1)  + 20*mvarys )
       parameter(lenfvc = mdata*maxpts , ione = 1)
       integer   iwork(mvarys),nptfit(mdata),ibadx(mvarys),nfit1,nsig1
       logical   datafl, feff
       real      work(lenwrk), fvect(lenfvc), ftemp(lenfvc)
       real      xvarys(mvarys), fjac(lenfvc, mvarys)
       real      alpha(mvarys, mvarys), toler, tolfac
       real      chirhi(maxpts), sumsqr
       real      rsmall, rgrid, stmp, wtmp, xolow, xohigh
       external fitfun, sumsqr, istrln
       data     datafl / .false./
       data     tolfac, lminfo / 1.e-4, 0/
c-----------------------------------------------------------------
c for phase-shifted FT's, determine which feff path to take
c the phase shift from
       if (pcfit.or.pcout) then
          do 40 id  = 1, ndata
             jffphs(id) = 0
             do 30 ind  = 1, mdpths
                if (jdtpth(ind,id).gt.0) then
                   jffphs(id) = jpthff( jdtpth(ind,id) )
                   if (jffphs(id).gt.0) go to 35
                end if
 30          continue 
 35          continue 
 40       continue 
       end if
c set up fft:
c    cffti initializes the work array wfftc for the fft routines
c    called in fitfft. it only needs to be called once, as long
c    as the size of the fft arrays are not changed. for fitting,
c    the fft uses mftfit points. for writing outputs, in fitout,
c    the fft will use mftwrt points.
c    (usually mftfit = 256 or 512 while mftwrt = 2048)
c
       call cffti(mftfit, wfftc)
       rgrid   = pi / (qgrid * mftfit)
       rsmall  = rgrid / 100.0
       if (iprint.ge.2) then
          irun = 0
          call openfl(irun, 'feffit.run','unknown', iex, ierr)
          if (ierr.lt.0) then
             call finmsg(1002,' ','feffit.run',0)
             iprint = 1
          else
             write(irun,*)'mftfit, rgrid =',mftfit,rgrid
          end if
       end if
c
c hack by matt : ifxvar temporarily holds irun (so iprint works in fitfun)
       ifxvar = irun
c
c set up/initialize a bunch of other stuff:
c   mfit   = number of point to use in fitting
c   nrwght = # of points to use for getting measurement uncertainty
       mfit    = 0
       nr1    = int ( (rwght1 + rsmall) / rgrid )
       nr2    = int ( (rwght2 + rsmall) / rgrid )
       nrwght = nr2 - nr1 + 1
       nsigd  = 2*nrwght
c
c for each data set:
c  1 call fitfft to apply window and weighting and to do fft
c    of the data, returning chifit over the given fit range.
c    if ifft=0, chifit contains real chi(k), with only window
c               applied, but no fft.
c    if ifft=1, chifit contains chi(r). this is the default
c    if ifft=2, chifit contains backtransformed chi(k).
c  2 calculate the measurement uncertainty by calling fitfft
c    (this time doing the fft even if the fit is in k-space),
c    returning chi(r) between 15 and 25 angstroms. if the fit
c    is done in r-space, the measurement uncertainty is taken
c    as the rms value of the high-r components of chi(r), which
c    will represent the random, white noise in the data. if the
c    fit is done in k-space, the uncertainty is found from the
c    r-space value according to (see thiel, livins, stern, and
c    lewis paper on pt-pop. the result is fairly straighforward
c    fourier analysis, done by p livins, checked algebraically and
c    numerically on samples of modelled noisy data by m newville.)
c
c                                 /         pi * w'            \
c    (sigma_k)^2 = (sigma_r)^2 * | --------------------------   |
c                                 \ qgrid*( kmax^w' - kmin^w') /
c
c      where  w' = (2 * kweight + 1).
c
       do 100 id = 1, ndata
          nrmin    = int ( (rmin(id) + rsmall) / rgrid )
          nrmax    = int ( (rmax(id) + rsmall) / rgrid )
          nrpts(id)= nrmax  - nrmin + 1
          if (ifft(id).eq.1) then
             nptfit(id) = 2 * max (1, nrpts(id))
          elseif (ifft(id).eq.2) then
             nptfit(id) = 2 * max (1, nqpts(id))
          else
             nptfit(id) =     max (1, nqpts(id))
          end if
          mfit   = mfit + nptfit(id)
          if (datain(id)) then
             datafl  = .true.
             if (mod(ifft(id), 2).eq.0) then
                xolow = qmin(id)
                xohigh= qmax(id)
             else
                xolow = rmin(id)
                xohigh= rmax(id)
             end if
             if (iprint.ge.2) then
                write(irun,*) ' id, ifft(id) =', id , ifft(id)
                write(irun,*) ' nrmin, nrmax = ',nrmin,nrmax
                write(irun,*) ' nrpts, nqpts = ',nrpts(id),nqpts(id)
                write(irun,*) ' qmin , qmax  = ',qmin(id),qmax(id)
                write(irun,*) ' sample of qwindo (i,q,qwindo):'                
                do ix = 20, 30
                   write(irun,*) ix, ix*qgrid, qwindo(ix,id)
                end do
                write(irun,*) '  calling fitfft... '
             endif
             call fitfft(chiq(1,id), maxpts, mftfit, wfftc, qgrid,
     $            qwindo(1,id),qweigh(id),rwindo(1,id),rweigh(id),
     $            ifft(id), xolow,xohigh,pcfit,qfeff(1,jffphs(id)),
     $            thepha(1,jffphs(id)),mffpts, nfit1, chifit(1,id))
c
             if (iprint.ge.2) then
                write(irun,*) ' id, ifft(id) =', id , ifft(id)
                write(irun,*) ' nrmin, nrmax = ',nrmin,nrmax
                write(irun,*) ' nrpts, nqpts = ',nrpts(id),nqpts(id)
                write(irun,*) ' qmin , qmax  = ',qmin(id),qmax(id)
             endif
c
c estimate of measurement uncertainty for fit:
c    assuming the measurement uncertainty to be white noise, and
c    that the signal dies off appreciably at reasonably large r,
c    the noise is given by the high r components of the signal. 
c    sigdtr is estimated as the rms part of the signal at high r. 
c    we most need the noise in the real and/or imaginary parts
c    of chi(r). the temp array below contains both real and 
c    imaginary parts, so its rms is too big by the sqrt(2). 
c
             if ((sigdtr(id).le.zero).and.(sigdtk(id).le.zero)) then
                call fitfft(chiq(1,id), maxpts, mftfit, wfftc, qgrid,
     $               qwindo(1,id),qweigh(id), qwindo(1,id), rweigh(id),
     $               ione, rwght1, rwght2, pcfit, qfeff(1,jffphs(id)),
     $               thepha(1,jffphs(id)),mffpts, nsig1, chirhi)
                sigdtr(id) = sqrt( sumsqr(chirhi, nsig1) / nsig1)
             endif
c  find sigdtk, the measurement uncertainty for the k-space data,
c  using the formula above
c  if sigdtk was given, the sigdtr is still zero, so
c  get it by inverting the above formula
             if ((sigdtk(id).le.zero).or.(sigdtr(id).le.zero)) then
                wtmp   = 2 * qweigh(id)  + one
c#mn mar-18-98 sqrt(2) seems needed, empirically at least
                stmp   = sqrt( 2 * pi * wtmp /
     $               (qgrid * (qmax(id)**wtmp - qmin(id)**wtmp )))
c                 stmp   = sqrt ( pi * wtmp /
c      $               (qgrid * (qmax(id)**wtmp - qmin(id)**wtmp )))
                if (sigdtr(id).le.zero) sigdtr(id) = sigdtk(id)/stmp
                if (sigdtk(id).le.zero) sigdtk(id) = sigdtr(id)*stmp
             end if
          endif
          sigdtk(id) = abs( sigdtk(id))
          sigdtr(id) = abs( sigdtr(id))
          if (sigdtk(id).le.zero) sigdtk(id) = one
          if (sigdtr(id).le.zero) sigdtr(id) = one
c  finally, get sigdtq, again using the above formula, this
c  time using the  r-weight and r-ranges of the r->q ft
          if (sigdtq(id).le.zero) then
             wtmp   = 2 * rweigh(id)  + one
             stmp   = sqrt ( pi * wtmp /
     $            (rgrid * (rmax(id)**wtmp - rmin(id)**wtmp )))
             sigdtq(id) = sigdtr(id) / stmp
          end if
c------------------------------------------------------------
c assign weighting to use in fit based on user chosen weight (sigwgt)
c and on data uncertainty for the space to fit in
c
          sigwgt(id) = abs( sigwgt(id))
          if (sigwgt(id).le.zero) sigwgt(id) = one
          if (ifft(id).eq.0) then
             weight(id) = sigdtk(id) * sigdtk(id) / sigwgt(id)
          elseif (ifft(id).eq.1) then
             weight(id) = sigdtr(id) * sigdtr(id) / sigwgt(id)
          elseif (ifft(id).eq.2) then
             weight(id) = sigdtq(id) * sigdtq(id) / sigwgt(id)
          endif
 100   continue

c  do some simple error checking
       mfit = min(mfit, lenfvc)
       if (numvar.gt.mfit) then
          write(messg, '(a,i3,a,i3,a)' ) 'trying to use ', numvar,
     $         ' variables for ', mfit , ' measurements'
          call finmsg(3510,messg,' ',0)
       elseif (numvar.gt.xnidp) then
          call messag( '>WARNING:  more variables than'//
     $                 ' independent measurements in data!')
       elseif (numvar.eq.inform)  then
          call messag( '>WARNING:  equal number of variables'//
     $               ' and measurements in data!')
       end if
c
       if (iprint.ge.2) then
          write(irun,*) ' ndata, mfit, numvar=',ndata, mfit, numvar
          write(irun,*) ' xnidp              = ' , xnidp
          write(irun,*) ' -------------------------------------'
       endif
c initialization for fitting:
c  the default fitting tolerance (tolfac = 1.e-4) is empirical.
c  the user can set usrtol [default = 1]  with "toler" keyword.
       toler  = usrtol * tolfac
       chisqr = zero
       istop  = 0
c get weight for chi-square:
c     chi-square = sum{1 to mfit} [ del_chi(r) / sigma ]^2
c     but chi-square should be correctly normalized, as if the
c     sum was {1 to inform} (inform = # of independent points).
c     we already got most of this above, but now we include the
c     terms mfit and inform, so that the sum is correctly normalized
c     when we actually sum over mfit points instead of inform points
       do 280  id = 1, ndata
          weight(id) = sqrt ( nptfit(id) * weight(id) / xinfo(id))
          if (iprint.ge.2) then
             write(irun,*) ' sigdtk, sigdtr =',sigdtk(id),sigdtr(id)
             write(irun,*) ' nptfit, xinfo  =',nptfit(id),xinfo(id)
             write(irun,*) ' weight, sigwgt =',weight(id),sigwgt(id)
             write(irun,*) '---------------------------------------'
             write(irun,*) '  tolfac,usrtol = ',tolfac,usrtol
          endif
 280   continue
c
c initialize variables and fit arrays
       do 420 i =1, numvar
          xvarys(i) = xguess(i)
          xfinal(i) = xguess(i)
 420   continue
       do 440 i =1, mfit
          fvect(i) = zero
 440   continue
c
c print pre - fit message
       write(messg, '(a,f6.2,a,i3,a)' ) '        fitting ',xnidp,
     $      ' independent points with ', numvar, ' variables'
       im = istrln(messg)
       call messag(messg(:im))
c
c last chance to bail (no feff files, no data file, nofit requested)
       feff = .false.
       do 450 i = 1, mfffil
          if (feffil(i).ne.' ') feff = .true.
 450   continue
       noout = noout.or.((.not.feff).and.(.not.datafl))
       if ( nofit.or.(.not.datafl).or.
     $      (numvar.le.0).or.(.not.feff)) then
          if (nofit) then
             messg  = 'no fitting will be done, as requested.'
          elseif (.not.datafl) then
             messg = 'no fitting done. no data to fit!'
          elseif (numvar.le.0) then
             numvar = 0
             messg  = 'no fitting done. no variables defined!'
          elseif (.not.feff) then
             messg  = 'no fitting done. no feff files defined!'
          end if
          im = max(1, istrln(messg))
          call messag('        '//messg(:im))
          final = .true.
          call fitfun(mfit, numvar, xvarys, fvect, istop)
          chisqr = sumsqr(fvect, mfit)
cc          final = .false.
          go to 5000
       end if
c
c do the fitting:
       call lmdif1 (fitfun, mfit, numvar, xvarys, fvect,
     $               toler, lminfo, iwork, work, lenwrk)
c
c print post-fit message
c   lminfo key is listed in the comments to lmdif and lmdif1
          call messag('           fitting is finished.')
       if (lminfo.eq.0)  call finmsg(3530,' ',' ',lminfo)
       if ( (lminfo.ge.4).and.(lminfo.le.7)) then
          call messag('           fit gave a warning message:')
          if (lminfo.eq.4) then
             call messag('      one or more '//
     $            'variables may not affect the fit.')
          elseif (lminfo.eq.5) then
             call messag('      too many fit '//
     $            'iterations.  try again with better')
             call messag('      better guesses or '//
     $            'a simpler problem.')
          elseif ((lminfo.eq.6).or.(lminfo.eq.7)) then
             call messag('      "toler" can probably be '//
     $            'increased without a loss of')
             write(messg, '(a,e13.5)' ) '      fit quality. '//
     $            'current value is:  toler = ', usrtol
             im = istrln(messg)
             call messag(messg(:im))
          endif
       end if
c-----------------------------------------------------------
c assign variables to final values and call fitfun one more time
       if (iprint.ge.2) then
          write(irun,*) 'fitnls before error bars: i, xfinal,dx'
          do 600 i =1, numvar
             write(irun,*) i, xfinal(i),xfinal(i) - xguess(i)
 600      continue
       endif
       iflag = 0
       final = .true.
       call fitfun(mfit, numvar, xvarys, fvect, iflag)
cc       final = .false.
c
c evaluate chi-square : note that fvect is properly
c     normalized by weight in fitfun
       nfirst = 1
       do 620 id = 1, ndata
          chi2dt(id)  = sumsqr(fvect(nfirst), nptfit(id))
          if (iprint.ge.2) then
             write(irun,*) 'nfirst, nptfit(id) =',nfirst,nptfit(id)
             write(irun,*) 'id, chi2dt(id)     =', id, chi2dt(id)
          end if
          nfirst      = nptfit(id)  + nfirst
 620   continue
       chisqr = sumsqr(fvect, mfit)
       if (iprint.ge.2) then
          write(irun,*) ' after fit : chisqr = ',  chisqr
          write(irun,*) '    i , fvect(i) '
          do 640 i = 1, mfit
             write(irun,*) i, fvect(i)
 640      continue
       endif
c
c estimate the uncertainties in parameters
       call fiterr(fitfun, mfit, numvar, lenfvc, mvarys, fvect,
     $      ftemp, fjac, alpha, iprint, irun, nerstp, xvarys,
     $      delta, correl, ier, ibadx)
c
c write final fit values to common block arrays
       do 840 i = 1, numvar
          xfinal(i) = xvarys(i)
 840   continue
       if (ier.eq.0) then
          call messag('           uncertainties estimated')
       else
          ierbar = -1
          call messag('>WARNING:  uncertainties can not'//
     $         ' be estimated.  one or more ')
          call messag('        variables did not'//
     $         ' affect the fit:')
          do 880 i = 1, numvar
             if (ibadx(i).gt.0) then
                ilen = max(1, istrln(vnames(i)))
                messg = '       >>  '//vnames(i)(1:ilen) //' <<'
                call messag(messg(:ilen+15))
             end if
 880      continue
       endif
c
 5000  continue
       if (iprint.ge.2) then
          close(irun)
          iprint = 0
       endif
       return
c
c end subroutine fitnls
       end
       subroutine fitfun(mvec, nvar, xvar, fvec, iend)
c
c  evaluate function to minimize in the least squares sense by lmdif.
c  the function fvec is the difference between chi(r) for data and
c  modelled theory on the fit range [rmin, rmax]. the variables
c  modify the theory chi(k), evaluated as a sum over paths, using
c  routine chipth for the chi(k) for each path.
c
c     copyright 1993   university of washington    matthew newville
c
c arguments:
c   mvec    number of evaluations of fvec ( = 2*nrpts )    (in)
c   nvar    number of variables xvar      ( = numvar  )    (in)
c   xvar    array of variables                             (in)
c   fvec    function of the variables to minimize          (out)
c   iend    integer stopping flag (not currently used)     (in)
c
c note: since this routine (and the routines it calls) is called
c       so often by lmdif (and fdjac2) efficiency and speed are
c       important. (usually clarity is more important than speed.).
c       so this routine is a bit terse.
c----------------------------------------------------------------------
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c  local variables
c  warning: do not dimension the array xvar as "xvar(nvar)" !
c           this routine may be called with nvar = 0,
c           and an array dimension 0 is not allowed.
       integer   lenfvc, mvec, nvar, iend, id, i
       integer   nstart, jfit, nfit, nfit1
       integer   j0, nqdata, ibscf, jdd, inpath, idpath, jfeff
       parameter(lenfvc = mdata * maxpts)
       real      reff, degen, xolow, xohigh
       real      tchiqi(maxpts), tchiqr(maxpts), thifit(maxpts)
       real      xvar(mvarys), fvec(lenfvc), par(mpthpr)
       real      rfact, bvalue, decod
       external  rfact, bvalue, decod
       data      j0  / 0/
c----------------------------------------------------------------------
cc       print*, ' fitfun   :: final = ', final
c  use the values of the variables to evaluate all the "values"
c  for both the variables and the user-defined functions
c  note: values(i) is a variable       if  icdval(1,i) < 0
c        values(i) is a user function  if  icdval(1,i) > 0
c        values(i) is unused           if  icdval(1,i) = 0
       id    = 1
       do 20 i = 1, nvar
          values(i) = xvar(i)
 20    continue
c don't need to evaluate the obvious constants, so we can start the
c looping here at nconst+nvar (see fitchk and fixicd)
       nstart = nconst + nvar + 1
       call setval(nstart,nmathx,icdval,maxval,micode,
     $      consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
c
c  sum function to minimize over data sets
c   jfit is the counter (through all the data sets)
c   for the total number of fitting points
       jfit = 0
       do 3000 id = 1, ndata
          nqdata = min(maxpts, max(2, nqfit(id)) + 10)
          if (ifft(id).eq.1) then
             xolow  = rmin(id)
             xohigh = rmax(id)
             nfit   = 2 * max (1, nrpts(id))
          elseif (ifft(id).eq.2) then
             xolow  = qmin(id)
             xohigh = qmax(id)
             nfit   = 2 * max (1, nqpts(id))
          else
             xolow  = qmin(id)
             xohigh = qmax(id)
             nfit   = 2 * max (1, nqpts(id))
          endif
          do 200 i = 1, nfit
             thifit(i)   = zero
 200      continue
c  re-initialize array for theoretical chi(k)
c  by assigning this to the background function
          do 300 i = 1, nqdata
             thiq(i, id) = zero
             tchiqi(i)   = zero
             tchiqr(i)   = zero
             if (final) thiqr(i, id) = zero
             if ( bkgfit(id))  then
c  ibscf holds place in xvar list of where the
c  spline coefs for the current data set are kept.
                ibscf  = nvuser+1
                if (id.gt.1) then
                   do 290 jdd = 2, id
                      ibscf = ibscf + nbkg(jdd-1)
 290               continue
                endif
                thiq(i, id) = thiq(i, id) +
     $               bvalue(qknot(1,id), xvar(ibscf),
     $               nbkg(id),korder,qgrid*(i-1),j0)
             end if
 300      continue
c
c   sum over paths for theory chi for this data set
          do 1000 idpath = 1, mdpths
             inpath    = jdtpth(idpath,id)
             if (inpath.le.0)    go to 990
             jfeff     = jpthff(inpath)
             reff      = refpth(jfeff)
             degen     = degpth(jfeff)
             ixpath    = jfeff
             consts(4) = reff
             consts(5) = degen
c  evaluate the non-variable values
             call setval(nstart,nmathx,icdval,maxval,micode,
     $            consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
c  evaluate the path parameters from "values"
             do 500 i = 1, mpthpr
                par(i) = decod(icdpar(1, i, inpath), micode,
     $                         consts, values, defalt(i))
 500         continue
c  get chi(k) for this path from feff and path parameters
             if ( (inpath.gt.0).and.(jfeff.gt.0))  then
                if (iprint.ge.3) then
                   write(ifxvar,*) 'calling chipth:'
                   write(ifxvar,*) 'nfit, jfeff = ',nfit, jfeff
                   write(ifxvar,*) 'nqdata, maxpts = ',nqdata, maxpts
                   write(ifxvar,*) 'reff, mffpts = ', reff, mffpts
                   write(ifxvar,*) ' theamp(28,jfeff),thepha(28,jfeff)'
                   write(ifxvar,*) theamp(28,jfeff), thepha(28,jfeff)
                   write(ifxvar,*) ' qfeff(28,jfeff) =',qfeff(28,jfeff)
                   write(ifxvar,*) ' xlamb(28,jfeff), realp(28,jfeff)'
                   write(ifxvar,*) xlamb(28,jfeff), realp(28,jfeff)
                   write(ifxvar,*) ' reff, degen = ', reff, degen
                end if
                call chipth(theamp(1,jfeff), thepha(1,jfeff),
     $  qfeff(1,jfeff), xlamb(1,jfeff), realp(1,jfeff), mffpts,
     $  reff, degen, par(jps02),  par(jpe0),  par(jpei), par(jpdpha),
     $  par(jpdelr), par(jpsig2), par(jp3rd), par(jp4th), tranq, 
     $  rm2flg, nqdata, maxpts, tchiqr, tchiqi)

                if (iprint.ge.3) then
                   write(ifxvar,*) 'called chipth: jfeff, id = ',
     $                  jfeff,id
                   write(ifxvar,*) ' degen, s02, e0, ei = ',degen,
     $                  par(jps02),par(jpe0),par(jpei)
                   write(ifxvar,*) ' dphas,delr, sig2 = ',
     $                  par(jpdpha),par(jpdelr),par(jpsig2)
                   write(ifxvar,*) 'nqdata, maxpts = ',nqdata, maxpts
                   write(ifxvar,*) 'tchiqr(1),tchiqi(1)'
                   write(ifxvar,*)  tchiqr(1),tchiqi(1)
                end if
c
c  add this to the other paths
                do 850 i = 1, nqdata
                   thiq(i, id) = thiq(i, id) + tchiqi(i)
                   if (final) thiqr(i, id) = thiqr(i, id) + tchiqr(i)
 850            continue
             end if
 990         continue
 1000     continue
c   take fft of theory chi (exactly as for data chi)
          if (iprint.ge.2) then
             write(ifxvar,*) ' call fitfft: id = ', id
             write(ifxvar,*) ' xolow , xohigh ', xolow , xohigh
             write(ifxvar,*) ' maxpts, mftfit ', maxpts, mftfit
             write(ifxvar,*) ' qgrid =  ', qgrid
          endif
          call fitfft(thiq(1,id), maxpts, mftfit, wfftc, qgrid,
     $         qwindo(1,id), qweigh(id), rwindo(1,id), rweigh(id),
     $         ifft(id), xolow,xohigh,pcfit,  qfeff(1,jffphs(id)),
     $         thepha(1,jffphs(id)),mffpts, nfit1, thifit)
c
          if (nfit1.ne.nfit) then
             if (iprint.ge.1) then
                write(ifxvar,*) '*********************'
                write(ifxvar,*) 'fitfun error after fitfft: id = ',id
                write(ifxvar,*) 'nfit,  nfit1 = ', nfit, nfit1
                write(ifxvar,*) 'these should be equal !!'
                write(ifxvar,*) '*********************'
             end if
             print*, 'nfit,  nfit1 = ', nfit, nfit1
             call finmsg(3590,' ',' ',nfit1)
          endif
c  evaluate the contribution to fvec for this data set.  weight scales
c  chi-square properly to the number of independent points. this is
c  important for error analysis (if chi-square is to increase by one,
c  it  must be scaled correctly.), but only in the final pass, when
c  chi-square and r-factors will be calculated.
          if (final.and.iprint.ge.2) then
             write(ifxvar,*) ' in fitfun (final): id = ', id
             write(ifxvar,*) ' xolow , xohigh ', xolow , xohigh
             write(ifxvar,*) ' maxpts, mftfit ', maxpts, mftfit
             write(ifxvar,*) ' nfit, nfit1,jfit = ', nfit, nfit1,jfit
             write(ifxvar,*) ' rfactr(id)  = ', rfactr(id)
             if (iprint.ge.5)
     $            write(ifxvar,*) ' i, chifit,thifit,fvec: '
          end if
          do 2400 i =  1, nfit
             fvec(jfit+i) = (thifit(i) - chifit(i,id))/weight(id)
             if (final.and.iprint.ge.5) write(ifxvar,*) jfit+i,
     $            chifit(i,id), thifit(i),  fvec(jfit+i)
 2400     continue
          jfit  = nfit + jfit
          if (final.and.datain(id))
     $         rfactr(id) = rfact(chifit(1,id), thifit, nfit)
 3000  continue
       return
c  end subroutine fitfun
       end
       real function rfact(data, theory, ndata)
c
c      compute an xafs reliability factor as a measure of the
c      goodness of fit between arrays for data and theory.
c
c      copyright 1993 university of washington       matt newville
c  input:
c      data    alternating (real,imag) pairs for data over fit range
c      theory  alternating (real,imag) pairs for theory over fit range
c      ndata   number of data points to use
c  output:
c      rfact   xafs r-factor:
c
c        sum{ [re(data) - re(theory)]^2 + [im(data) - im(theory)]^2 }
c  rfact =  ------------------------------------------------------------
c                     sum{ [re(data)]^2 + [im(data)]^2 }
c
c       last update: 15-jun-1998  mn
c--------------------------------------------------------------------
       real     data(*), theory(*),  ampl, zero, small
       integer  ndata, i
       parameter(zero = 0., small = 1.e-08)
c initialize
       ampl   =  zero
       rfact  =  zero
c  construct sums of squares
       do 100 i = 1, ndata
          ampl  =  ampl  +  data(i)**2 
          rfact =  rfact + (data(i)  - theory(i))**2
 100   continue
c  rescale r-factor
       rfact =   rfact   / max(small, ampl)
       return
c end function rfact
       end
      real function bvalue ( t, bcoef, n, k, x, jderiv )
c
c  from  * a practical guide to splines *  by c. de boor
c  calls  interv
c
c  calculates value at x of jderiv-th derivative of spline from b-repr.
c  the spline is taken to be continuous from the right, except at the
c  rightmost knot, where it is taken to be continuous from the left.
c
c  from:   in%"netlibd@research.att.com"  9-aug-1992 13:11:48.46
c  subj:   re: subject: send bvalue from pppack
c  echo "anything free comes with no guarantee!"
c
c******  i n p u t ******
c  t, bcoef, n, k......forms the b-representation of the spline  f  to
c        be evaluated. specifically,
c  t.....knot sequence, of length  n+k, assumed nondecreasing.
c  bcoef.....b-coefficient sequence, of length  n .
c  n.....length of  bcoef  and dimension of spline(k,t),
c        a s s u m e d  positive .
c  k.....order of the spline .
c
c  w a r n i n g . . .   the restriction  k .le. kmax (=20)  is imposed
c        arbitrarily by the dimension statement for  aj, dl, dr  below,
c        but is  n o w h e r e  c h e c k e d  for.
c
c  x.....the point at which to evaluate .
c  jderiv.....integer giving the order of the derivative to be evaluated
c        a s s u m e d  to be zero or positive.
c
c******  o u t p u t  ******
c  bvalue.....the value of the (jderiv)-th derivative of  f  at  x .
c
c******  m e t h o d  ******
c     the nontrivial knot interval  (t(i),t(i+1))  containing  x  is lo-
c  cated with the aid of  interv . the  k  b-coeffs of  f  relevant for
c  this interval are then obtained from  bcoef (or taken to be zero if
c  not explicitly available) and are then differenced  jderiv  times to
c  obtain the b-coeffs of  (d**jderiv)f  relevant for that interval.
c  precisely, with  j = jderiv, we have from x.(12) of the text that
c
c     (d**j)f  =  sum ( bcoef(.,j)*b(.,k-j,t) )
c
c  where
c                   / bcoef(.),                     ,  j .eq. 0
c                   /
c    bcoef(.,j)  =  / bcoef(.,j-1) - bcoef(.-1,j-1)
c                   / ----------------------------- ,  j .gt. 0
c                   /    (t(.+k-j) - t(.))/(k-j)
c
c     then, we use repeatedly the fact that
c
c    sum ( a(.)*b(.,m,t)(x) )  =  sum ( a(.,x)*b(.,m-1,t)(x) )
c  with
c                 (x - t(.))*a(.) + (t(.+m-1) - x)*a(.-1)
c    a(.,x)  =    ---------------------------------------
c                 (x - t(.))      + (t(.+m-1) - x)
c
c  to write  (d**j)f(x)  eventually as a linear combination of b-splines
c  of order  1 , and the coefficient for  b(i,1,t)(x)  must then be the
c  desired number  (d**j)f(x). (see x.(17)-(19) of text).
c
      parameter (kmax = 50)
      integer jderiv,k,n,   i,ilo,imk,j,jc,jcmin,jcmax,jj,kmj,km1,mflag
     *                     ,nmi,jdrvp1
c     real bcoef(n),t(1),x,   aj(20),dl(20),dr(20),fkmj
      real bcoef(n),t(*),x,   aj(kmax),dl(kmax),dr(kmax),fkmj
c       dimension t(n+k)
c  former fortran standard made it impossible to specify the length
c  of  t precisely without the introduction of otherwise superfluous
c  additional arguments.
      bvalue = 0.
      if (jderiv .ge. k)                go to 99
c
c  *** find  i   s.t.   1 .le. i .lt. n+k   and   t(i) .lt. t(i+1)   and
c      t(i) .le. x .lt. t(i+1) . if no such i can be found,  x  lies
c      outside the support of  the spline  f , hence  bvalue = 0.
c      (the asymmetry in this choice of  i  makes  f  rightcontinuous,
c      except  at  t(n+k) where it is leftcontinuous.)
      call interv ( t, n+k, x, i, mflag )
      if (mflag .ne. 0)                 go to 99
c  *** if k = 1 (and jderiv = 0), bvalue = bcoef(i).
      km1 = k - 1
      if (km1 .gt. 0)                   go to 1
      bvalue = bcoef(i)
                                        go to 99
c
c  *** store the k b-spline coefficients relevant for the knot interval
c     (t(i),t(i+1)) in aj(1),...,aj(k) and compute dl(j) = x - t(i+1-j),
c     dr(j) = t(i+j) - x, j=1,...,k-1 . set any of the aj not obtainable
c     from input to zero. set any t.s not obtainable equal to t(1) or
c     to t(n+k) appropriately.
    1 jcmin = 1
      imk = i - k
      if (imk .ge. 0)                   go to 8
      jcmin = 1 - imk
      do 5 j=1,i
    5    dl(j) = x - t(i+1-j)
      do 6 j=i,km1
         aj(k-j) = 0.
    6    dl(j) = dl(i)
                                        go to 10
    8 do 9 j=1,km1
    9    dl(j) = x - t(i+1-j)
c
   10 jcmax = k
      nmi = n - i
      if (nmi .ge. 0)                   go to 18
      jcmax = k + nmi
      do 15 j=1,jcmax
   15    dr(j) = t(i+j) - x
      do 16 j=jcmax,km1
         aj(j+1) = 0.
   16    dr(j) = dr(jcmax)
                                        go to 20
   18 do 19 j=1,km1
   19    dr(j) = t(i+j) - x
c
   20 do 21 jc=jcmin,jcmax
   21    aj(jc) = bcoef(imk + jc)
c
c               *** difference the coefficients  jderiv  times.
      if (jderiv .eq. 0)                go to 30
      do 23 j=1,jderiv
         kmj = k-j
         fkmj = float(kmj)
         ilo = kmj
         do 23 jj=1,kmj
            aj(jj) = ((aj(jj+1) - aj(jj))/(dl(ilo) + dr(jj)))*fkmj
   23       ilo = ilo - 1
c
c  *** compute value at  x  in (t(i),t(i+1)) of jderiv-th derivative,
c     given its relevant b-spline coeffs in aj(1),...,aj(k-jderiv).
   30 if (jderiv .eq. km1)              go to 39
      jdrvp1 = jderiv + 1
      do 33 j=jdrvp1,km1
         kmj = k-j
         ilo = kmj
         do 33 jj=1,kmj
            aj(jj) = (aj(jj+1)*dl(ilo) + aj(jj)*dr(jj))/(dl(ilo)+dr(jj))
   33       ilo = ilo - 1
   39 bvalue = aj(1)
c
   99                                   return
c  end funtion bvalue
      end
      subroutine interv ( xt, lxt, x, left, mflag )
c  from  * a practical guide to splines *  by c. de boor
c  computes  left = max( i :  xt(i) .lt. xt(lxt) .and.  xt(i) .le. x ).
c
c******  i n p u t  ******
c  xt.....a real sequence, of length  lxt , assumed to be nondecreasing
c  lxt.....number of terms in the sequence  xt .
c  x.....the point whose location with respect to the sequence  xt  is
c        to be determined.
c
c******  o u t p u t  ******
c  left, mflag.....both integers, whose value is
c
c   1     -1      if               x .lt.  xt(1)
c   i      0      if   xt(i)  .le. x .lt. xt(i+1)
c   i      0      if   xt(i)  .lt. x .eq. xt(i+1) .eq. xt(lxt)
c   i      1      if   xt(i)  .lt.        xt(i+1) .eq. xt(lxt) .lt. x
c
c        in particular,  mflag = 0  is the 'usual' case.  mflag .ne. 0
c        indicates that  x  lies outside the closed interval
c        xt(1) .le. y .le. xt(lxt) . the asymmetric treatment of the
c        intervals is due to the decision to make all pp functions cont-
c        inuous from the right, but, by returning  mflag = 0  even if
c        x = xt(lxt), there is the option of having the computed pp function
c        continuous from the left at  xt(lxt) .
c
c******  m e t h o d  ******
c  the program is designed to be efficient in the common situation that
c  it is called repeatedly, with  x  taken from an increasing or decrea-
c  sing sequence. this will happen, e.g., when a pp function is to be
c  graphed. the first guess for  left  is therefore taken to be the val-
c  ue returned at the previous call and stored in the  l o c a l  varia-
c  ble  ilo . a first check ascertains that  ilo .lt. lxt (this is nec-
c  essary since the present call may have nothing to do with the previ-
c  ous call). then, if  xt(ilo) .le. x .lt. xt(ilo+1), we set  left =
c  ilo  and are done after just three comparisons.
c     otherwise, we repeatedly double the difference  istep = ihi - ilo
c  while also moving  ilo  and  ihi  in the direction of  x , until
c                      xt(ilo) .le. x .lt. xt(ihi) ,
c  after which we use bisection to get, in addition, ilo+1 = ihi .
c  left = ilo  is then returned.
c
      integer left,lxt,mflag,   ihi,ilo,istep,middle
      real x,xt(lxt)
      save ilo
      data ilo /1/
c
      ihi = ilo + 1
      if (ihi .lt. lxt)                 go to 20
         if (x .ge. xt(lxt))            go to 110
         if (lxt .le. 1)                go to 90
         ilo = lxt - 1
         ihi = lxt
c
   20 if (x .ge. xt(ihi))               go to 40
      if (x .ge. xt(ilo))               go to 100
c
c              **** now x .lt. xt(ilo) . decrease  ilo  to capture  x .
      istep = 1
   31    ihi = ilo
         ilo = ihi - istep
         if (ilo .le. 1)                go to 35
         if (x .ge. xt(ilo))            go to 50
         istep = istep*2
                                        go to 31
   35 ilo = 1
      if (x .lt. xt(1))                 go to 90
                                        go to 50
c              **** now x .ge. xt(ihi) . increase  ihi  to capture  x .
   40 istep = 1
   41    ilo = ihi
         ihi = ilo + istep
         if (ihi .ge. lxt)              go to 45
         if (x .lt. xt(ihi))            go to 50
         istep = istep*2
                                        go to 41
   45 if (x .ge. xt(lxt))               go to 110
      ihi = lxt
c
c           **** now xt(ilo) .le. x .lt. xt(ihi) . narrow the interval.
   50 middle = (ilo + ihi)/2
      if (middle .eq. ilo)              go to 100
c     note. it is assumed that middle = ilo in case ihi = ilo+1 .
      if (x .lt. xt(middle))            go to 53
         ilo = middle
                                        go to 50
   53    ihi = middle
                                        go to 50
c**** set output and return.
   90 mflag = -1
      left = 1
                                        return
  100 mflag = 0
      left = ilo
                                        return
  110 mflag = 1
       if (x .eq. xt(lxt)) mflag = 0
      left = lxt
  111 if (left .eq. 1)                  return
       left = left - 1
       if (xt(left) .lt. xt(lxt))       return
c  end subroutine interv
      end
       subroutine chipth(ampfef, phafef, qfeff, xlamb, realp, nffpts,
     $      reff, degen, s02, e0shft, e0imag, delpha, deltar, sigma2,
     $      third, fourth, tranq, rm2flg,
     $      nqvals, mchiq, chiqr, chiqi)
c
c  evaluate the theoretical chi(k) for a scattering path given:
c   1. feff information          (ampfef - degen)
c   2. the xafs path parameters  (s02 - fourth)
c
c     copyright 1993 university of washington        matt newville
c
c input:
c    ampfef   amplitude from feff for the path
c    phafef   phase shift from feff (w/o 2*k*r term) for the path
c    qfeff    k-values from feff for the other feff arrays
c    xlamb    mean-free-path from feff
c    realp    real part of p (momentum) from feff
c    nffpts   number of data points in the feff arrays
c    reff     half path length for the path
c    degen    path degeneracy (# of equivalent paths)
c    s02      constant multiplicitive amplitude factor for the path
c    e0shft   e0 shift to use for the path
c    e0imag   imaginary e0 shift / broadening for the path
c    delpha   constant phase shift (delta phase )
c    deltar   delta r to add to reff for the path
c    sigma2   debye-waller factor for the path
c    third    third cumulant for the path
c    fourth   fourth cumulant for the path
c    tranq    real paramter giving coefficient in tranquada correction
c    rm2flg   flag for using (reff)^{-2} instead of (reff+delr)^{-2}
c    nqvals   index of highest q value to calculate
c             (no greater than 512, no less than 20)
c    mchiq    array dimension for chiqr and chiqi
c output:
c    chiqr    real part \   of complex chi(k) for this path
c    chiqi    imag part /   with all path parameters applied
c **note measured chi(k) data corresponds to  chiqi **
c------------------------------------------------------------------
       integer izero, ipos, i, nqvals, nffpts, nqdata, mchiq, nqffmx
       complex coni, cp, cp2, cphshf, cdwf, cargu, cchi, ciei
       real    chiqr(mchiq), chiqi(mchiq)
       real    e0eff, s02r2n, degen, reff
       real    s02, e0shft, e0imag, delpha, deltar, sigma2, third
       real    first, fourth, r2m2, qgrid, energy, q, tranq
       real    expmax, expmin, small, etok, one
       real    rep, xlam, cxlam, pha, amp, car
       real    ampfef(nffpts), phafef(nffpts)
       real    qfeff(nffpts), xlamb(nffpts),  realp(nffpts)
       logical rm2flg, le0big
       parameter (coni = (0., 1.) , one = 1.)
       parameter (small=0.0001, etok = 0.26246 82917 )
       parameter (expmax = 30., expmin = -expmax, qgrid = 1./20.)
c------------------------------------------------------------------
c  combine path parameters and feff data to get theory chi
c  note: feff writes out the feffnnnn.dat files such that
c    phase = 2*q*r + phase_shifts. additional phase shifts and
c    all amplitude reduction terms use p, the complex momentum.
c    q is used only to reproduce chi(k) from feff
       nqffmx = int(qfeff(nffpts) / qgrid) + 5
       nqdata = min(512, min(nqvals, min(nqffmx, mchiq)))
       if (nqdata.lt.25)  nqdata = 400
c tranquada correction
       first = deltar - tranq * sigma2 / reff
       r2m2  = 1 / ( (reff + deltar) * (reff + deltar) )
       if (rm2flg)  r2m2   = 1 / ( reff * reff )
       le0big  = (abs(e0shft).ge.small)
c ipos is a place holder for the routine lintrp
c izero stores the index of the q = 0. location.
       ipos   = 1
       izero  = 0
c store some multiplications before the main loopa
       e0eff  = e0shft * etok
       ciei   = coni * e0imag * etok
       s02r2n = degen * s02 * r2m2
c the official xafs calculation loop:
       do 500 i = 1, nqdata
c  e0-shift the value of q
          q   = (i - 1) * qgrid
          if (le0big) then
             energy =  q*q - e0eff
             q      = sign(one,energy) * sqrt(abs(energy))
          end if
c  q = zero is special, and will be dealt with below
          if (abs(q).le.small) then
             izero = i
          else
c  interpolate amplitude, phase, realp and xlamb of feff chi
             call lintrp(qfeff,  realp, nffpts, q, ipos,  rep)
             call lintrp(qfeff,  xlamb, nffpts, q, ipos, xlam)
             call lintrp(qfeff, phafef, nffpts, q, ipos,  pha)
             call lintrp(qfeff, ampfef, nffpts, q, ipos,  amp)
c  evaluate complex momemtum
             cp2    =  (rep + coni/max(xlam,small))**2 + ciei
             cp     =  sqrt(cp2)
c  mean free path, complex debye-waller factor and phase shift
             cxlam  =  -2*reff* aimag(cp)
             cdwf   =  -2*cp2 * (sigma2 -    cp2 * fourth/3)
             cphshf =   2*cp  * (first  - (2*cp2)* third /3) + delpha
c  create complex chi, first checking that the exponential won't crash
             cargu  =  cxlam + cdwf + coni*(2*q*reff + pha + cphshf)
             car    =  max(expmin, min(expmax, real(cargu)))
             cchi   =  (amp * s02r2n / abs(q)) *
     $                     exp(cmplx(car, aimag(cargu)))
c  save real and imag chi for this value of q
             chiqi(i) = aimag(cchi)
             chiqr(i) = -real(cchi)
cc             print*, i, q, rep, xlam,  pha, amp, cchi
          end if
 500   continue
c  fill in guess for data at q = zero if needed
       if (izero.eq.1)  then
          chiqr(1) = 2*chiqr(2) - chiqr(3)
          chiqi(1) = 2*chiqi(2) - chiqi(3)
       elseif (izero.ge.2) then
          chiqr(izero) = (chiqr(izero-1) + chiqr(izero+1))/2
          chiqi(izero) = (chiqi(izero-1) + chiqi(izero+1))/2
       end if
       return
c end subroutine chipth
       end
       subroutine fitfft(chiq, mpts, mfft, wfftc, qgrid,
     $      qwin, qweigh, rwin, rweigh, ifft, xlow, xhigh,
     $      pcflg, qfeff, phafef, mfeff, nout, chifit)
c
c    calculate a fourier tranform of a function to be minimized in
c    either r or backtransformed k space to use as fitting function
c    in feffit.  returns chifit, a real array containing real and
c    imaginary parts of chi in either r or q space, between rmin and
c    rmax (or between qlow and qhi).
c
c    calls routine xafsft which uses the routine cfftf.
c    the routine cffti must be called prior to this routine.
c
c    copyright 1992 ... 97   matt newville
c
c inputs:
c   chiq    array containing chi(q), on grid with spacing qgrid,
c           and first point at chi(q = 0.).
c   mpts    dimension of chiq, qwin, and rwin
c   mfft    number of points to use for fft
c   wfftc   work array for fft initialized by cffti, which must
c           be called prior to this routine.
c   qgrid   grid size for chiq.
c   qwin    q-space fft window array
c   qweigh  q-weight in  k->r fft.
c   rwin    r-space fft window array
c   rweigh   r-weight in  r->q fft.
c   ifft    integer flag for number of fft's to do:
c             0    chifit is in original k-space
c             1    chifit is in r-space
c             2    chifit is in back-transformed k-space
c   xlow    low-x range for output chifit (either r or k)
c   xhigh   high-x range for output chifit (either r or k)
c   nout    number of points in output : useful length of chifit
c outputs:
c   chifit  real array representation of the complex result from
c           0, 1, or 2 fft of the input chi(k).
c           output between xlow and xhigh in real-imag pairs
c           (if ifft=0, all imag parts are 0.)
c
c mxmpts is the largest expected value for mpts
       implicit none
       integer   mpts, mfft, mfeff, ifft, nout, mxmpts, nfft, i, ipos
       real      pi, zero, xlow, xhigh
       parameter (mxmpts = 2048, zero=0., pi = 3.141592653589793)
       real     chiq(mpts), chifit(mpts), qwin(mpts), rwin(mpts)
       real     qweigh, rweigh, qgrid, rgrid, q , pha
       real     qfeff(mfeff), phafef(mfeff), wfftc(*)
       complex  cchir(mxmpts), cchiq(mxmpts), coni
       parameter (coni=(0,1))
       logical pcflg
c  check that ifft is valid
       if ((ifft.lt.0).or.(ifft.ge.3)) then
          call messag('fitfft: ifft out of range. have a nice day.')
          stop
       endif
c
c  nfft will be the actual length of the fft arrays.
c  it is expected that nfft = mfft, but just in case...
       nfft   =  min(mxmpts, min(mfft, mpts) )
       rgrid  =  pi / (qgrid * nfft)
c
c  copy input data into complex data array.
       if (pcflg) then
          ipos = 1
          do 110 i = 1, nfft
             q = (i-1) * qgrid
             call lintrp(qfeff, phafef, mfeff, q, ipos,  pha)
             cchiq(i) = cmplx(chiq(i), zero) * exp(-coni * pha)
 110      continue
       else
          do 130 i = 1, nfft
             cchiq(i) = cmplx(chiq(i), zero)
 130      continue
       end if
c
c  do ifft (= 0, 1, 2)  number of fourier transforms
c  fft k -> r :
       if (ifft.ge.1) call xafsft(nfft, cchiq, qwin, qgrid, qweigh,
     $      wfftc, 1, cchir)
c
c  fft r -> q :
c    note that we use cchir, the output of the above k->r fft,
c    and overwrite the original cchiq.
       if (ifft.eq.2) call xafsft(nfft, cchir, rwin, rgrid, rweigh,
     $      wfftc, -1, cchiq)
c
c  construct chifit from the above the calculations, using fftout
       if (mod(ifft,2).eq.0) then
          call fftout(mxmpts,cchiq,qgrid,xlow,xhigh,nout,mpts,chifit)
       else
          call fftout(mxmpts,cchir,rgrid,xlow,xhigh,nout,mpts,chifit)
       endif
       return
c  end subroutine fitfft
       end
       subroutine xafsft(mpts, chip, wa, xgrid, xwgh, wfftc,jfft,chiq)
c
c  xafs fourier transform. includes k-weighting, an arbitrary window
c  function, and mapping from FT conjugates (k,2R) to (k,R), with
c  rational normalization
c
c  fft routines cfftf/b (from fftpack) are used in subroutine xfft.
c
c  arrays wa and wfftc must be initialized before this routine:
c      wfftc  must be initialized by "cffti".
c      wa     is probably initialized by "window".
c  arguments
c    mpts     dimension of arrays chip and wa                  [in]
c    chip     complex array of input data, on uniform grid     [in]
c             chip(1) = chi(x=0.), zero-padding expected.
c    wa       real array of window function                    [in]
c    xgrid    grid spacing for chip                            [in]
c    xwgh     x-weight                                         [in]
c    wfftc    work array for fft                               [in]
c    jfft     integer controlling functionality                [in]
c               1   forward transform (k->r)
c               0   no transform (returns windowed data)
c              -1   reverse transform (r->k)
c    chiq     complex fourier transform of chip               [out]
c
c  copyright 1997   matthew newville
c--------------------------------------------------------------------
       implicit none
       integer  i, mpts, jfft, ixwgh
       real     wfftc(*), wa(*), xwgh, dx, xgrid
       real     sqrtpi, eps7, eps4
       complex  chip(*), chiq(*), cnorm
       parameter(sqrtpi = 0.5641895835, eps7=1.e-7, eps4=1.e-4)
c                sqrtpi = 1 / sqrt(pi)
c complex normalization constant, for the transform from r to k in
c    xafs, the xgrid is assumed to be the grid in r *not* in 2r.
c    to normalize correctly, cnorm must be multiplied by 2.
c    note that if we're not doing fft, we don't want to normalize
       cnorm = xgrid * sqrtpi * (1,0)
       if (jfft.lt.0) cnorm = 2 * cnorm
       if (jfft.eq.0) cnorm = (1,0)
c make chiq as  k-weighted and windowed chip
c   if xwgh is really an integer, do only the integer exponentiation
       ixwgh = int(xwgh)
       if (ixwgh.eq.0) then 
          do 40 i = 1, mpts
             chiq(i) = (0,0)
             if (wa(i) .gt. eps7) chiq(i) = cnorm * chip(i) * wa(i)
 40       continue
       else 
          do 50 i = 1, mpts
             chiq(i) = (0,0)
             if (wa(i) .gt. eps7) chiq(i) = cnorm * chip(i) * wa(i)
     $            * ((i-1) * xgrid)**ixwgh
 50       continue
       end if
c   do fp exponentiation only if it will be noticeable
       dx = xwgh - ixwgh
       if (dx .gt. eps4) then
          do 60 i = 1, mpts
             if (wa(i).gt.eps7) chiq(i) = chiq(i) * ((i-1)*xgrid)**dx
 60       continue
       end if
c do fft on modified array, chiq (fft is done in place):
c    jfft > 0:  cfftf, k->r, forward fft
c    jfft < 0:  cfftb, r->k, reverse fft
c    jfft = 0:  no fft, chiq returned as is (ie, after weighting)
       if (jfft.gt.0) call cfftf(mpts,chiq,wfftc)
       if (jfft.lt.0) call cfftb(mpts,chiq,wfftc)
       return
c  end subroutine xafsft
       end
      subroutine cffti (n,wsave)
      dimension       wsave(*)
      if (n .eq. 1) return
      iw1 = n+n+1
      iw2 = iw1+n+n
      call cffti1 (n,wsave(iw1),wsave(iw2))
      return
      end
      subroutine cffti1 (n,wa,ifac)
      dimension       wa(*)      ,ifac(*)    ,ntryh(4)
      data ntryh(1),ntryh(2),ntryh(3),ntryh(4)/3,4,2,5/
      nl = n
      nf = 0
      j = 0
  101 j = j+1
      if (j-4) 102,102,103
  102 ntry = ntryh(j)
      go to 104
  103 ntry = ntry+2
  104 nq = nl/ntry
      nr = nl-ntry*nq
      if (nr) 101,105,101
  105 nf = nf+1
      ifac(nf+2) = ntry
      nl = nq
      if (ntry .ne. 2) go to 107
      if (nf .eq. 1) go to 107
      do 106 i=2,nf
         ib = nf-i+2
         ifac(ib+2) = ifac(ib+1)
  106 continue
      ifac(3) = 2
  107 if (nl .ne. 1) go to 104
      ifac(1) = n
      ifac(2) = nf
      tpi = 6.28318530717959
      argh = tpi/float(n)
      i = 2
      l1 = 1
      do 110 k1=1,nf
         ip = ifac(k1+2)
         ld = 0
         l2 = l1*ip
         ido = n/l2
         idot = ido+ido+2
         ipm = ip-1
         do 109 j=1,ipm
            i1 = i
            wa(i-1) = 1.
            wa(i) = 0.
            ld = ld+l1
            fi = 0.
            argld = float(ld)*argh
            do 108 ii=4,idot,2
               i = i+2
               fi = fi+1.
               arg = fi*argld
               wa(i-1) = cos(arg)
               wa(i) = sin(arg)
  108       continue
            if (ip .le. 5) go to 109
            wa(i1-1) = wa(i-1)
            wa(i1) = wa(i)
  109    continue
         l1 = l2
  110 continue
      return
      end
       subroutine cfftf (n,c,wsave)
       dimension       c(*)       ,wsave(*)
       if (n .eq. 1) return
       iw1 = n+n+1
       iw2 = iw1+n+n
       call cfftf1 (n,c,wsave,wsave(iw1),wsave(iw2))
       return
       end
       subroutine cfftf1 (n,c,ch,wa,ifac)
       dimension       ch(*)  ,c(*) ,wa(*) ,ifac(*)
       nf = ifac(2)
       na = 0
       l1 = 1
       iw = 1
       do 116 k1=1,nf
          ip = ifac(k1+2)
          l2 = ip*l1
          ido = n/l2
          idot = ido+ido
          idl1 = idot*l1
          if (ip .ne. 4) go to 103
          ix2 = iw+idot
          ix3 = ix2+idot
          if (na .ne. 0) go to 101
          call passf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
          go to 102
  101     call passf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
  102     na = 1-na
          go to 115
  103     if (ip .ne. 2) go to 106
          if (na .ne. 0) go to 104
          call passf2 (idot,l1,c,ch,wa(iw))
          go to 105
  104     call passf2 (idot,l1,ch,c,wa(iw))
  105     na = 1-na
          go to 115
  106     if (ip .ne. 3) go to 109
          ix2 = iw+idot
          if (na .ne. 0) go to 107
          call passf3 (idot,l1,c,ch,wa(iw),wa(ix2))
          go to 108
  107     call passf3 (idot,l1,ch,c,wa(iw),wa(ix2))
  108     na = 1-na
          go to 115
  109     if (ip .ne. 5) go to 112
          ix2 = iw+idot
          ix3 = ix2+idot
          ix4 = ix3+idot
          if (na .ne. 0) go to 110
          call passf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
          go to 111
  110     call passf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
  111     na = 1-na
          go to 115
  112     if (na .ne. 0) go to 113
          call passf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
          go to 114
  113     call passf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
  114     if (nac .ne. 0) na = 1-na
  115     l1 = l2
          iw = iw+(ip-1)*idot
  116  continue
       if (na .eq. 0) return
       n2 = n+n
       do 117 i=1,n2
          c(i) = ch(i)
  117  continue
       return
       end
      subroutine cfftb (n,c,wsave)
      dimension       c(*)       ,wsave(*)
      if (n .eq. 1) return
      iw1 = n+n+1
      iw2 = iw1+n+n
      call cfftb1 (n,c,wsave,wsave(iw1),wsave(iw2))
      return
      end
      subroutine cfftb1 (n,c,ch,wa,ifac)
      dimension       ch(*)      ,c(*)       ,wa(*)      ,ifac(*)
      nf = ifac(2)
      na = 0
      l1 = 1
      iw = 1
      do 116 k1=1,nf
         ip = ifac(k1+2)
         l2 = ip*l1
         ido = n/l2
         idot = ido+ido
         idl1 = idot*l1
         if (ip .ne. 4) go to 103
         ix2 = iw+idot
         ix3 = ix2+idot
         if (na .ne. 0) go to 101
         call passb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
         go to 102
  101    call passb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
  102    na = 1-na
         go to 115
  103    if (ip .ne. 2) go to 106
         if (na .ne. 0) go to 104
         call passb2 (idot,l1,c,ch,wa(iw))
         go to 105
  104    call passb2 (idot,l1,ch,c,wa(iw))
  105    na = 1-na
         go to 115
  106    if (ip .ne. 3) go to 109
         ix2 = iw+idot
         if (na .ne. 0) go to 107
         call passb3 (idot,l1,c,ch,wa(iw),wa(ix2))
         go to 108
  107    call passb3 (idot,l1,ch,c,wa(iw),wa(ix2))
  108    na = 1-na
         go to 115
  109    if (ip .ne. 5) go to 112
         ix2 = iw+idot
         ix3 = ix2+idot
         ix4 = ix3+idot
         if (na .ne. 0) go to 110
         call passb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
         go to 111
  110    call passb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
  111    na = 1-na
         go to 115
  112    if (na .ne. 0) go to 113
         call passb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
         go to 114
  113    call passb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
  114    if (nac .ne. 0) na = 1-na
  115    l1 = l2
         iw = iw+(ip-1)*idot
  116 continue
      if (na .eq. 0) return
      n2 = n+n
      do 117 i=1,n2
         c(i) = ch(i)
  117 continue
      return
      end
       subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
       dimension       ch(ido,l1,ip)          ,cc(ido,ip,l1)          ,
     1                c1(ido,l1,ip)          ,wa(*)      ,c2(idl1,ip),
     2                ch2(idl1,ip)
       idot = ido/2
       nt = ip*idl1
       ipp2 = ip+2
       ipph = (ip+1)/2
       idp = ip*ido
c
       if (ido .lt. l1) go to 106
       do 103 j=2,ipph
         jc = ipp2-j
         do 102 k=1,l1
            do 101 i=1,ido
               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  101       continue
  102    continue
  103  continue
       do 105 k=1,l1
         do 104 i=1,ido
            ch(i,k,1) = cc(i,1,k)
  104    continue
  105  continue
       go to 112
  106  do 109 j=2,ipph
         jc = ipp2-j
         do 108 i=1,ido
            do 107 k=1,l1
               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  107       continue
  108    continue
  109  continue
       do 111 i=1,ido
         do 110 k=1,l1
            ch(i,k,1) = cc(i,1,k)
  110    continue
  111  continue
  112  idl = 2-ido
       inc = 0
       do 116 l=2,ipph
         lc = ipp2-l
         idl = idl+ido
         do 113 ik=1,idl1
            c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
            c2(ik,lc) = -wa(idl)*ch2(ik,ip)
  113    continue
         idlj = idl
         inc = inc+ido
         do 115 j=3,ipph
            jc = ipp2-j
            idlj = idlj+inc
            if (idlj .gt. idp) idlj = idlj-idp
            war = wa(idlj-1)
            wai = wa(idlj)
            do 114 ik=1,idl1
               c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
               c2(ik,lc) = c2(ik,lc)-wai*ch2(ik,jc)
  114       continue
  115    continue
  116  continue
       do 118 j=2,ipph
         do 117 ik=1,idl1
            ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
  117    continue
  118  continue
       do 120 j=2,ipph
         jc = ipp2-j
         do 119 ik=2,idl1,2
            ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
            ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
            ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
            ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
  119    continue
  120  continue
       nac = 1
       if (ido .eq. 2) return
       nac = 0
       do 121 ik=1,idl1
         c2(ik,1) = ch2(ik,1)
  121  continue
       do 123 j=2,ip
         do 122 k=1,l1
            c1(1,k,j) = ch(1,k,j)
            c1(2,k,j) = ch(2,k,j)
  122    continue
  123  continue
       if (idot .gt. l1) go to 127
       idij = 0
       do 126 j=2,ip
         idij = idij+2
         do 125 i=4,ido,2
            idij = idij+2
            do 124 k=1,l1
               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j)
               c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j)
  124       continue
  125    continue
  126  continue
       return
  127  idj = 2-ido
       do 130 j=2,ip
         idj = idj+ido
         do 129 k=1,l1
            idij = idj
            do 128 i=4,ido,2
               idij = idij+2
               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)+wa(idij)*ch(i,k,j)
               c1(i,k,j) = wa(idij-1)*ch(i,k,j)-wa(idij)*ch(i-1,k,j)
  128       continue
  129    continue
  130  continue
       return
       end
      subroutine passf2 (ido,l1,cc,ch,wa1)
      dimension       cc(ido,2,l1)           ,ch(ido,l1,2)           ,
     1                wa1(*)
      if (ido .gt. 2) go to 102
      do 101 k=1,l1
         ch(1,k,1) = cc(1,1,k)+cc(1,2,k)
         ch(1,k,2) = cc(1,1,k)-cc(1,2,k)
         ch(2,k,1) = cc(2,1,k)+cc(2,2,k)
         ch(2,k,2) = cc(2,1,k)-cc(2,2,k)
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k)
            tr2 = cc(i-1,1,k)-cc(i-1,2,k)
            ch(i,k,1) = cc(i,1,k)+cc(i,2,k)
            ti2 = cc(i,1,k)-cc(i,2,k)
            ch(i,k,2) = wa1(i-1)*ti2-wa1(i)*tr2
            ch(i-1,k,2) = wa1(i-1)*tr2+wa1(i)*ti2
  103    continue
  104 continue
      return
      end
      subroutine passf3 (ido,l1,cc,ch,wa1,wa2)
      dimension       cc(ido,3,l1)           ,ch(ido,l1,3)           ,
     1                wa1(*)     ,wa2(*)
      data taur,taui /-.5,-.866025403784439/
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         tr2 = cc(1,2,k)+cc(1,3,k)
         cr2 = cc(1,1,k)+taur*tr2
         ch(1,k,1) = cc(1,1,k)+tr2
         ti2 = cc(2,2,k)+cc(2,3,k)
         ci2 = cc(2,1,k)+taur*ti2
         ch(2,k,1) = cc(2,1,k)+ti2
         cr3 = taui*(cc(1,2,k)-cc(1,3,k))
         ci3 = taui*(cc(2,2,k)-cc(2,3,k))
         ch(1,k,2) = cr2-ci3
         ch(1,k,3) = cr2+ci3
         ch(2,k,2) = ci2+cr3
         ch(2,k,3) = ci2-cr3
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            tr2 = cc(i-1,2,k)+cc(i-1,3,k)
            cr2 = cc(i-1,1,k)+taur*tr2
            ch(i-1,k,1) = cc(i-1,1,k)+tr2
            ti2 = cc(i,2,k)+cc(i,3,k)
            ci2 = cc(i,1,k)+taur*ti2
            ch(i,k,1) = cc(i,1,k)+ti2
            cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k))
            ci3 = taui*(cc(i,2,k)-cc(i,3,k))
            dr2 = cr2-ci3
            dr3 = cr2+ci3
            di2 = ci2+cr3
            di3 = ci2-cr3
            ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2
            ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2
            ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3
            ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3
  103    continue
  104 continue
      return
      end
      subroutine passf4 (ido,l1,cc,ch,wa1,wa2,wa3)
      dimension       cc(ido,4,l1)           ,ch(ido,l1,4)           ,
     1                wa1(*)     ,wa2(*)     ,wa3(*)
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         ti1 = cc(2,1,k)-cc(2,3,k)
         ti2 = cc(2,1,k)+cc(2,3,k)
         tr4 = cc(2,2,k)-cc(2,4,k)
         ti3 = cc(2,2,k)+cc(2,4,k)
         tr1 = cc(1,1,k)-cc(1,3,k)
         tr2 = cc(1,1,k)+cc(1,3,k)
         ti4 = cc(1,4,k)-cc(1,2,k)
         tr3 = cc(1,2,k)+cc(1,4,k)
         ch(1,k,1) = tr2+tr3
         ch(1,k,3) = tr2-tr3
         ch(2,k,1) = ti2+ti3
         ch(2,k,3) = ti2-ti3
         ch(1,k,2) = tr1+tr4
         ch(1,k,4) = tr1-tr4
         ch(2,k,2) = ti1+ti4
         ch(2,k,4) = ti1-ti4
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ti1 = cc(i,1,k)-cc(i,3,k)
            ti2 = cc(i,1,k)+cc(i,3,k)
            ti3 = cc(i,2,k)+cc(i,4,k)
            tr4 = cc(i,2,k)-cc(i,4,k)
            tr1 = cc(i-1,1,k)-cc(i-1,3,k)
            tr2 = cc(i-1,1,k)+cc(i-1,3,k)
            ti4 = cc(i-1,4,k)-cc(i-1,2,k)
            tr3 = cc(i-1,2,k)+cc(i-1,4,k)
            ch(i-1,k,1) = tr2+tr3
            cr3 = tr2-tr3
            ch(i,k,1) = ti2+ti3
            ci3 = ti2-ti3
            cr2 = tr1+tr4
            cr4 = tr1-tr4
            ci2 = ti1+ti4
            ci4 = ti1-ti4
            ch(i-1,k,2) = wa1(i-1)*cr2+wa1(i)*ci2
            ch(i,k,2) = wa1(i-1)*ci2-wa1(i)*cr2
            ch(i-1,k,3) = wa2(i-1)*cr3+wa2(i)*ci3
            ch(i,k,3) = wa2(i-1)*ci3-wa2(i)*cr3
            ch(i-1,k,4) = wa3(i-1)*cr4+wa3(i)*ci4
            ch(i,k,4) = wa3(i-1)*ci4-wa3(i)*cr4
  103    continue
  104 continue
      return
      end
      subroutine passf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
      dimension       cc(ido,5,l1)           ,ch(ido,l1,5)           ,
     1                wa1(*)     ,wa2(*)     ,wa3(*)     ,wa4(*)
      data tr11,ti11,tr12,ti12 /.309016994374947,-.951056516295154,
     1-.809016994374947,-.587785252292473/
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         ti5 = cc(2,2,k)-cc(2,5,k)
         ti2 = cc(2,2,k)+cc(2,5,k)
         ti4 = cc(2,3,k)-cc(2,4,k)
         ti3 = cc(2,3,k)+cc(2,4,k)
         tr5 = cc(1,2,k)-cc(1,5,k)
         tr2 = cc(1,2,k)+cc(1,5,k)
         tr4 = cc(1,3,k)-cc(1,4,k)
         tr3 = cc(1,3,k)+cc(1,4,k)
         ch(1,k,1) = cc(1,1,k)+tr2+tr3
         ch(2,k,1) = cc(2,1,k)+ti2+ti3
         cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3
         ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3
         cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3
         ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3
         cr5 = ti11*tr5+ti12*tr4
         ci5 = ti11*ti5+ti12*ti4
         cr4 = ti12*tr5-ti11*tr4
         ci4 = ti12*ti5-ti11*ti4
         ch(1,k,2) = cr2-ci5
         ch(1,k,5) = cr2+ci5
         ch(2,k,2) = ci2+cr5
         ch(2,k,3) = ci3+cr4
         ch(1,k,3) = cr3-ci4
         ch(1,k,4) = cr3+ci4
         ch(2,k,4) = ci3-cr4
         ch(2,k,5) = ci2-cr5
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ti5 = cc(i,2,k)-cc(i,5,k)
            ti2 = cc(i,2,k)+cc(i,5,k)
            ti4 = cc(i,3,k)-cc(i,4,k)
            ti3 = cc(i,3,k)+cc(i,4,k)
            tr5 = cc(i-1,2,k)-cc(i-1,5,k)
            tr2 = cc(i-1,2,k)+cc(i-1,5,k)
            tr4 = cc(i-1,3,k)-cc(i-1,4,k)
            tr3 = cc(i-1,3,k)+cc(i-1,4,k)
            ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3
            ch(i,k,1) = cc(i,1,k)+ti2+ti3
            cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3
            ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3
            cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3
            ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3
            cr5 = ti11*tr5+ti12*tr4
            ci5 = ti11*ti5+ti12*ti4
            cr4 = ti12*tr5-ti11*tr4
            ci4 = ti12*ti5-ti11*ti4
            dr3 = cr3-ci4
            dr4 = cr3+ci4
            di3 = ci3+cr4
            di4 = ci3-cr4
            dr5 = cr2+ci5
            dr2 = cr2-ci5
            di5 = ci2-cr5
            di2 = ci2+cr5
            ch(i-1,k,2) = wa1(i-1)*dr2+wa1(i)*di2
            ch(i,k,2) = wa1(i-1)*di2-wa1(i)*dr2
            ch(i-1,k,3) = wa2(i-1)*dr3+wa2(i)*di3
            ch(i,k,3) = wa2(i-1)*di3-wa2(i)*dr3
            ch(i-1,k,4) = wa3(i-1)*dr4+wa3(i)*di4
            ch(i,k,4) = wa3(i-1)*di4-wa3(i)*dr4
            ch(i-1,k,5) = wa4(i-1)*dr5+wa4(i)*di5
            ch(i,k,5) = wa4(i-1)*di5-wa4(i)*dr5
  103    continue
  104 continue
      return
      end
      subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
      dimension       ch(ido,l1,ip)          ,cc(ido,ip,l1)          ,
     1                c1(ido,l1,ip)          ,wa(*)      ,c2(idl1,ip),
     2                ch2(idl1,ip)
      idot = ido/2
      nt = ip*idl1
      ipp2 = ip+2
      ipph = (ip+1)/2
      idp = ip*ido
c
      if (ido .lt. l1) go to 106
      do 103 j=2,ipph
         jc = ipp2-j
         do 102 k=1,l1
            do 101 i=1,ido
               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  101       continue
  102    continue
  103 continue
      do 105 k=1,l1
         do 104 i=1,ido
            ch(i,k,1) = cc(i,1,k)
  104    continue
  105 continue
      go to 112
  106 do 109 j=2,ipph
         jc = ipp2-j
         do 108 i=1,ido
            do 107 k=1,l1
               ch(i,k,j) = cc(i,j,k)+cc(i,jc,k)
               ch(i,k,jc) = cc(i,j,k)-cc(i,jc,k)
  107       continue
  108    continue
  109 continue
      do 111 i=1,ido
         do 110 k=1,l1
            ch(i,k,1) = cc(i,1,k)
  110    continue
  111 continue
  112 idl = 2-ido
      inc = 0
      do 116 l=2,ipph
         lc = ipp2-l
         idl = idl+ido
         do 113 ik=1,idl1
            c2(ik,l) = ch2(ik,1)+wa(idl-1)*ch2(ik,2)
            c2(ik,lc) = wa(idl)*ch2(ik,ip)
  113    continue
         idlj = idl
         inc = inc+ido
         do 115 j=3,ipph
            jc = ipp2-j
            idlj = idlj+inc
            if (idlj .gt. idp) idlj = idlj-idp
            war = wa(idlj-1)
            wai = wa(idlj)
            do 114 ik=1,idl1
               c2(ik,l) = c2(ik,l)+war*ch2(ik,j)
               c2(ik,lc) = c2(ik,lc)+wai*ch2(ik,jc)
  114       continue
  115    continue
  116 continue
      do 118 j=2,ipph
         do 117 ik=1,idl1
            ch2(ik,1) = ch2(ik,1)+ch2(ik,j)
  117    continue
  118 continue
      do 120 j=2,ipph
         jc = ipp2-j
         do 119 ik=2,idl1,2
            ch2(ik-1,j) = c2(ik-1,j)-c2(ik,jc)
            ch2(ik-1,jc) = c2(ik-1,j)+c2(ik,jc)
            ch2(ik,j) = c2(ik,j)+c2(ik-1,jc)
            ch2(ik,jc) = c2(ik,j)-c2(ik-1,jc)
  119    continue
  120 continue
      nac = 1
      if (ido .eq. 2) return
      nac = 0
      do 121 ik=1,idl1
         c2(ik,1) = ch2(ik,1)
  121 continue
      do 123 j=2,ip
         do 122 k=1,l1
            c1(1,k,j) = ch(1,k,j)
            c1(2,k,j) = ch(2,k,j)
  122    continue
  123 continue
      if (idot .gt. l1) go to 127
      idij = 0
      do 126 j=2,ip
         idij = idij+2
         do 125 i=4,ido,2
            idij = idij+2
            do 124 k=1,l1
               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
               c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
  124       continue
  125    continue
  126 continue
      return
  127 idj = 2-ido
      do 130 j=2,ip
         idj = idj+ido
         do 129 k=1,l1
            idij = idj
            do 128 i=4,ido,2
               idij = idij+2
               c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)-wa(idij)*ch(i,k,j)
               c1(i,k,j) = wa(idij-1)*ch(i,k,j)+wa(idij)*ch(i-1,k,j)
  128       continue
  129    continue
  130 continue
      return
      end
      subroutine passb2 (ido,l1,cc,ch,wa1)
      dimension       cc(ido,2,l1)           ,ch(ido,l1,2)           ,
     1                wa1(*)
      if (ido .gt. 2) go to 102
      do 101 k=1,l1
         ch(1,k,1) = cc(1,1,k)+cc(1,2,k)
         ch(1,k,2) = cc(1,1,k)-cc(1,2,k)
         ch(2,k,1) = cc(2,1,k)+cc(2,2,k)
         ch(2,k,2) = cc(2,1,k)-cc(2,2,k)
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ch(i-1,k,1) = cc(i-1,1,k)+cc(i-1,2,k)
            tr2 = cc(i-1,1,k)-cc(i-1,2,k)
            ch(i,k,1) = cc(i,1,k)+cc(i,2,k)
            ti2 = cc(i,1,k)-cc(i,2,k)
            ch(i,k,2) = wa1(i-1)*ti2+wa1(i)*tr2
            ch(i-1,k,2) = wa1(i-1)*tr2-wa1(i)*ti2
  103    continue
  104 continue
      return
      end
      subroutine passb3 (ido,l1,cc,ch,wa1,wa2)
      dimension       cc(ido,3,l1)           ,ch(ido,l1,3)           ,
     1                wa1(*)     ,wa2(*)
      data taur,taui /-.5,.866025403784439/
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         tr2 = cc(1,2,k)+cc(1,3,k)
         cr2 = cc(1,1,k)+taur*tr2
         ch(1,k,1) = cc(1,1,k)+tr2
         ti2 = cc(2,2,k)+cc(2,3,k)
         ci2 = cc(2,1,k)+taur*ti2
         ch(2,k,1) = cc(2,1,k)+ti2
         cr3 = taui*(cc(1,2,k)-cc(1,3,k))
         ci3 = taui*(cc(2,2,k)-cc(2,3,k))
         ch(1,k,2) = cr2-ci3
         ch(1,k,3) = cr2+ci3
         ch(2,k,2) = ci2+cr3
         ch(2,k,3) = ci2-cr3
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            tr2 = cc(i-1,2,k)+cc(i-1,3,k)
            cr2 = cc(i-1,1,k)+taur*tr2
            ch(i-1,k,1) = cc(i-1,1,k)+tr2
            ti2 = cc(i,2,k)+cc(i,3,k)
            ci2 = cc(i,1,k)+taur*ti2
            ch(i,k,1) = cc(i,1,k)+ti2
            cr3 = taui*(cc(i-1,2,k)-cc(i-1,3,k))
            ci3 = taui*(cc(i,2,k)-cc(i,3,k))
            dr2 = cr2-ci3
            dr3 = cr2+ci3
            di2 = ci2+cr3
            di3 = ci2-cr3
            ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2
            ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2
            ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3
            ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3
  103    continue
  104 continue
      return
      end
      subroutine passb4 (ido,l1,cc,ch,wa1,wa2,wa3)
      dimension       cc(ido,4,l1)           ,ch(ido,l1,4)           ,
     1                wa1(*)     ,wa2(*)     ,wa3(*)
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         ti1 = cc(2,1,k)-cc(2,3,k)
         ti2 = cc(2,1,k)+cc(2,3,k)
         tr4 = cc(2,4,k)-cc(2,2,k)
         ti3 = cc(2,2,k)+cc(2,4,k)
         tr1 = cc(1,1,k)-cc(1,3,k)
         tr2 = cc(1,1,k)+cc(1,3,k)
         ti4 = cc(1,2,k)-cc(1,4,k)
         tr3 = cc(1,2,k)+cc(1,4,k)
         ch(1,k,1) = tr2+tr3
         ch(1,k,3) = tr2-tr3
         ch(2,k,1) = ti2+ti3
         ch(2,k,3) = ti2-ti3
         ch(1,k,2) = tr1+tr4
         ch(1,k,4) = tr1-tr4
         ch(2,k,2) = ti1+ti4
         ch(2,k,4) = ti1-ti4
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ti1 = cc(i,1,k)-cc(i,3,k)
            ti2 = cc(i,1,k)+cc(i,3,k)
            ti3 = cc(i,2,k)+cc(i,4,k)
            tr4 = cc(i,4,k)-cc(i,2,k)
            tr1 = cc(i-1,1,k)-cc(i-1,3,k)
            tr2 = cc(i-1,1,k)+cc(i-1,3,k)
            ti4 = cc(i-1,2,k)-cc(i-1,4,k)
            tr3 = cc(i-1,2,k)+cc(i-1,4,k)
            ch(i-1,k,1) = tr2+tr3
            cr3 = tr2-tr3
            ch(i,k,1) = ti2+ti3
            ci3 = ti2-ti3
            cr2 = tr1+tr4
            cr4 = tr1-tr4
            ci2 = ti1+ti4
            ci4 = ti1-ti4
            ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2
            ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2
            ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3
            ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3
            ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4
            ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4
  103    continue
  104 continue
      return
      end
      subroutine passb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
      dimension       cc(ido,5,l1)           ,ch(ido,l1,5)           ,
     1                wa1(*)     ,wa2(*)     ,wa3(*)     ,wa4(*)
      data tr11,ti11,tr12,ti12 /.309016994374947,.951056516295154,
     1-.809016994374947,.587785252292473/
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         ti5 = cc(2,2,k)-cc(2,5,k)
         ti2 = cc(2,2,k)+cc(2,5,k)
         ti4 = cc(2,3,k)-cc(2,4,k)
         ti3 = cc(2,3,k)+cc(2,4,k)
         tr5 = cc(1,2,k)-cc(1,5,k)
         tr2 = cc(1,2,k)+cc(1,5,k)
         tr4 = cc(1,3,k)-cc(1,4,k)
         tr3 = cc(1,3,k)+cc(1,4,k)
         ch(1,k,1) = cc(1,1,k)+tr2+tr3
         ch(2,k,1) = cc(2,1,k)+ti2+ti3
         cr2 = cc(1,1,k)+tr11*tr2+tr12*tr3
         ci2 = cc(2,1,k)+tr11*ti2+tr12*ti3
         cr3 = cc(1,1,k)+tr12*tr2+tr11*tr3
         ci3 = cc(2,1,k)+tr12*ti2+tr11*ti3
         cr5 = ti11*tr5+ti12*tr4
         ci5 = ti11*ti5+ti12*ti4
         cr4 = ti12*tr5-ti11*tr4
         ci4 = ti12*ti5-ti11*ti4
         ch(1,k,2) = cr2-ci5
         ch(1,k,5) = cr2+ci5
         ch(2,k,2) = ci2+cr5
         ch(2,k,3) = ci3+cr4
         ch(1,k,3) = cr3-ci4
         ch(1,k,4) = cr3+ci4
         ch(2,k,4) = ci3-cr4
         ch(2,k,5) = ci2-cr5
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ti5 = cc(i,2,k)-cc(i,5,k)
            ti2 = cc(i,2,k)+cc(i,5,k)
            ti4 = cc(i,3,k)-cc(i,4,k)
            ti3 = cc(i,3,k)+cc(i,4,k)
            tr5 = cc(i-1,2,k)-cc(i-1,5,k)
            tr2 = cc(i-1,2,k)+cc(i-1,5,k)
            tr4 = cc(i-1,3,k)-cc(i-1,4,k)
            tr3 = cc(i-1,3,k)+cc(i-1,4,k)
            ch(i-1,k,1) = cc(i-1,1,k)+tr2+tr3
            ch(i,k,1) = cc(i,1,k)+ti2+ti3
            cr2 = cc(i-1,1,k)+tr11*tr2+tr12*tr3
            ci2 = cc(i,1,k)+tr11*ti2+tr12*ti3
            cr3 = cc(i-1,1,k)+tr12*tr2+tr11*tr3
            ci3 = cc(i,1,k)+tr12*ti2+tr11*ti3
            cr5 = ti11*tr5+ti12*tr4
            ci5 = ti11*ti5+ti12*ti4
            cr4 = ti12*tr5-ti11*tr4
            ci4 = ti12*ti5-ti11*ti4
            dr3 = cr3-ci4
            dr4 = cr3+ci4
            di3 = ci3+cr4
            di4 = ci3-cr4
            dr5 = cr2+ci5
            dr2 = cr2-ci5
            di5 = ci2-cr5
            di2 = ci2+cr5
            ch(i-1,k,2) = wa1(i-1)*dr2-wa1(i)*di2
            ch(i,k,2) = wa1(i-1)*di2+wa1(i)*dr2
            ch(i-1,k,3) = wa2(i-1)*dr3-wa2(i)*di3
            ch(i,k,3) = wa2(i-1)*di3+wa2(i)*dr3
            ch(i-1,k,4) = wa3(i-1)*dr4-wa3(i)*di4
            ch(i,k,4) = wa3(i-1)*di4+wa3(i)*dr4
            ch(i-1,k,5) = wa4(i-1)*dr5-wa4(i)*di5
            ch(i,k,5) = wa4(i-1)*di5+wa4(i)*dr5
  103    continue
  104 continue
      return
      end
      subroutine fftout(mpts, xdat, step, xlo, xhi, nout, npts, xout)
c convert complex data xdat to a real array, using only
c that part of the complex array between [xlow, xhi].
      integer  mpts, npts, nout, nmin, npairs, i
      complex  xdat(mpts)
      real     xout(npts), step, dxi, xlo, xhi, small, tiny
      parameter (tiny = 1.e-4, small = 1.e-2)
c
      dxi    = 1 / max(tiny, step)
      nmin   = max(0, int(xlo * dxi + small ))
      npairs = max(1, int(xhi * dxi + small )) - nmin + 1
      nout   = min(npts, 2 * npairs)
      do 50 i= 1, npairs
         xout(2*i-1) = real (xdat( nmin + i ))
         xout(2*i  ) = aimag(xdat( nmin + i ))
 50   continue
      return
c end subroutine fftout
      end
      real function sumsqr(array, narray)
c  returns sum of squares of an array with dimension narray
      dimension  array(*)
      real       big, zero
      parameter( big = 1.e12, zero = 0.)
      sumsqr  = zero
      do 50 i = 1, narray
         if (abs(array(i)).lt.big) then
            sumsqr = sumsqr + array(i)*array(i)
         else
            sumsqr = sumsqr + big*big
         end if
 50   continue
      return
c  end real function sumsqr
      end
      subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa)
c
c  single precision levenberg-marquardt non-linear least square fitting
c  routine with finite difference approximation to the jacobian.
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
      integer m,n,info,lwa
      integer iwa(n)
      real tol
      real x(n),fvec(m),wa(lwa)
      external fcn
c     **********
c
c     subroutine lmdif1
c
c     the purpose of lmdif1 is to minimize the sum of the squares of
c     m nonlinear functions in n variables by a modification of the
c     levenberg-marquardt algorithm. this is done by using the more
c     general least-squares solver lmdif. the user must provide a
c     subroutine which calculates the functions. the jacobian is
c     then calculated by a forward-difference approximation.
c
c     the subroutine statement is
c
c       subroutine lmdif1(fcn,m,n,x,fvec,tol,info,iwa,wa,lwa)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions. fcn must be declared
c         in an external statement in the user calling
c         program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,iflag)
c         integer m,n,iflag
c         real x(n),fvec(m)
c         ----------
c         calculate the functions at x and
c         return this vector in fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of lmdif1.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an array of length n. on input x must contain
c         an initial estimate of the solution vector. on output x
c         contains the final estimate of the solution vector.
c
c       fvec is an output array of length m which contains
c         the functions evaluated at the output x.
c
c       tol is a nonnegative input variable. termination occurs
c         when the algorithm estimates either that the relative
c         error in the sum of squares is at most tol or that
c         the relative error between x and the solution is at
c         most tol.
c
c       info is an integer output variable. if the user has
c         terminated execution, info is set to the (negative)
c         value of iflag. see description of fcn. otherwise,
c         info is set as follows.
c
c         info = 0  improper input parameters.
c
c         info = 1  algorithm estimates that the relative error
c                   in the sum of squares is at most tol.
c
c         info = 2  algorithm estimates that the relative error
c                   between x and the solution is at most tol.
c
c         info = 3  conditions for info = 1 and info = 2 both hold.
c
c         info = 4  fvec is orthogonal to the columns of the
c                   jacobian to machine precision.
c
c         info = 5  number of calls to fcn has reached or
c                   exceeded 200*(n+1).
c
c         info = 6  tol is too small. no further reduction in
c                   the sum of squares is possible.
c
c         info = 7  tol is too small. no further improvement in
c                   the approximate solution x is possible.
c
c       iwa is an integer work array of length n.
c
c       wa is a work array of length lwa.
c
c       lwa is a positive integer input variable not less than
c         m*n+5*n+m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... lmdif
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer maxfev,mode,mp5n,nfev,nprint
      real epsfcn,factor,ftol,gtol,xtol,zero
      data factor,zero /1.0e2,0.0e0/
      info = 0
c
c     check the input parameters for errors.
c
      if (n .le. 0 .or. m .lt. n .or. tol .lt. zero
     *    .or. lwa .lt. m*n + 5*n + m) go to 10
c
c     call lmdif.
c
      maxfev = 200*(n + 1)
      ftol = tol
      xtol = tol
      gtol = zero
      epsfcn = zero
      mode = 1
      nprint = 0
      mp5n = m + 5*n
      call lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,wa(1),
     *           mode,factor,nprint,info,nfev,wa(mp5n+1),m,iwa,
     *           wa(n+1),wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1))
      if (info .eq. 8) info = 4
   10 continue
      return
c
c     last card of subroutine lmdif1.
c
      end
      subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
     *                 diag,mode,factor,nprint,info,nfev,fjac,ldfjac,
     *                 ipvt,qtf,wa1,wa2,wa3,wa4)
c
      integer m,n,maxfev,mode,nprint,info,nfev,ldfjac
      integer ipvt(n)
      real ftol,xtol,gtol,epsfcn,factor
      real x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n),wa1(n),wa2(n),
     *     wa3(n),wa4(m)
      external fcn
c     **********
c
c     subroutine lmdif
c
c     the purpose of lmdif is to minimize the sum of the squares of
c     m nonlinear functions in n variables by a modification of
c     the levenberg-marquardt algorithm. the user must provide a
c     subroutine which calculates the functions. the jacobian is
c     then calculated by a forward-difference approximation.
c
c     the subroutine statement is
c
c       subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn,
c                        diag,mode,factor,nprint,info,nfev,fjac,
c                        ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions. fcn must be declared
c         in an external statement in the user calling
c         program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,iflag)
c         integer m,n,iflag
c         real x(n),fvec(m)
c         ----------
c         calculate the functions at x and
c         return this vector in fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of lmdif.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an array of length n. on input x must contain
c         an initial estimate of the solution vector. on output x
c         contains the final estimate of the solution vector.
c
c       fvec is an output array of length m which contains
c         the functions evaluated at the output x.
c
c       ftol is a nonnegative input variable. termination
c         occurs when both the actual and predicted relative
c         reductions in the sum of squares are at most ftol.
c         therefore, ftol measures the relative error desired
c         in the sum of squares.
c
c       xtol is a nonnegative input variable. termination
c         occurs when the relative error between two consecutive
c         iterates is at most xtol. therefore, xtol measures the
c         relative error desired in the approximate solution.
c
c       gtol is a nonnegative input variable. termination
c         occurs when the cosine of the angle between fvec and
c         any column of the jacobian is at most gtol in absolute
c         value. therefore, gtol measures the orthogonality
c         desired between the function vector and the columns
c         of the jacobian.
c
c       maxfev is a positive integer input variable. termination
c         occurs when the number of calls to fcn is at least
c         maxfev by the end of an iteration.
c
c       epsfcn is an input variable used in determining a suitable
c         step length for the forward-difference approximation. this
c         approximation assumes that the relative errors in the
c         functions are of the order of epsfcn. if epsfcn is less
c         than the machine precision, it is assumed that the relative
c         errors in the functions are of the order of the machine
c         precision.
c
c       diag is an array of length n. if mode = 1 (see
c         below), diag is internally set. if mode = 2, diag
c         must contain positive entries that serve as
c         multiplicative scale factors for the variables.
c
c       mode is an integer input variable. if mode = 1, the
c         variables will be scaled internally. if mode = 2,
c         the scaling is specified by the input diag. other
c         values of mode are equivalent to mode = 1.
c
c       factor is a positive input variable used in determining the
c         initial step bound. this bound is set to the product of
c         factor and the euclidean norm of diag*x if nonzero, or else
c         to factor itself. in most cases factor should lie in the
c         interval (.1,100.). 100. is a generally recommended value.
c
c       nprint is an integer input variable that enables controlled
c         printing of iterates if it is positive. in this case,
c         fcn is called with iflag = 0 at the beginning of the first
c         iteration and every nprint iterations thereafter and
c         immediately prior to return, with x and fvec available
c         for printing. if nprint is not positive, no special calls
c         of fcn with iflag = 0 are made.
c
c       info is an integer output variable. if the user has
c         terminated execution, info is set to the (negative)
c         value of iflag. see description of fcn. otherwise,
c         info is set as follows.
c
c         info = 0  improper input parameters.
c
c         info = 1  both actual and predicted relative reductions
c                   in the sum of squares are at most ftol.
c
c         info = 2  relative error between two consecutive iterates
c                   is at most xtol.
c
c         info = 3  conditions for info = 1 and info = 2 both hold.
c
c         info = 4  the cosine of the angle between fvec and any
c                   column of the jacobian is at most gtol in
c                   absolute value.
c
c         info = 5  number of calls to fcn has reached or
c                   exceeded maxfev.
c
c         info = 6  ftol is too small. no further reduction in
c                   the sum of squares is possible.
c
c         info = 7  xtol is too small. no further improvement in
c                   the approximate solution x is possible.
c
c         info = 8  gtol is too small. fvec is orthogonal to the
c                   columns of the jacobian to machine precision.
c
c       nfev is an integer output variable set to the number of
c         calls to fcn.
c
c       fjac is an output m by n array. the upper n by n submatrix
c         of fjac contains an upper triangular matrix r with
c         diagonal elements of nonincreasing magnitude such that
c
c                t     t           t
c               p *(jac *jac)*p = r *r,
c
c         where p is a permutation matrix and jac is the final
c         calculated jacobian. column j of p is column ipvt(j)
c         (see below) of the identity matrix. the lower trapezoidal
c         part of fjac contains information generated during
c         the computation of r.
c
c       ldfjac is a positive integer input variable not less than m
c         which specifies the leading dimension of the array fjac.
c
c       ipvt is an integer output array of length n. ipvt
c         defines a permutation matrix p such that jac*p = q*r,
c         where jac is the final calculated jacobian, q is
c         orthogonal (not stored), and r is upper triangular
c         with diagonal elements of nonincreasing magnitude.
c         column j of p is column ipvt(j) of the identity matrix.
c
c       qtf is an output array of length n which contains
c         the first n elements of the vector (q transpose)*fvec.
c
c       wa1, wa2, and wa3 are work arrays of length n.
c
c       wa4 is a work array of length m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... spmpar,enorm,fdjac2,lmpar,qrfac
c
c       fortran-supplied ... abs,amax1,amin1,sqrt,mod
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iflag,iter,j,l
      real actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm,one,par,
     *     pnorm,prered,p1,p5,p25,p75,p0001,ratio,sum,temp,temp1,
     *     temp2,xnorm,zero
      real spmpar,enorm
      external spmpar, enorm
      data one,p1,p5,p25,p75,p0001,zero
     *     /1.0e0,1.0e-1,5.0e-1,2.5e-1,7.5e-1,1.0e-4,0.0e0/
c
c     epsmch is the machine precision.
c
      epsmch = spmpar(1)
c
      info = 0
      iflag = 0
      nfev = 0
c
c     check the input parameters for errors.
c
      if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m
     *    .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero
     *    .or. maxfev .le. 0 .or. factor .le. zero) go to 300
      if (mode .ne. 2) go to 20
      do 10 j = 1, n
         if (diag(j) .le. zero) go to 300
   10    continue
   20 continue
c
c     evaluate the function at the starting point
c     and calculate its norm.
c
      iflag = 1
      call fcn(m,n,x,fvec,iflag)
      nfev = 1
      if (iflag .lt. 0) go to 300
      fnorm = enorm(m,fvec)
c
c     initialize levenberg-marquardt parameter and iteration counter.
c
      par = zero
      iter = 1
c
c     beginning of the outer loop.
c
   30 continue
c
c     print message to let user know that routine is running
c                    added by matt newville july 1992
c
         if ( mod(iter,25) .eq. 0) then
           call messag('                    fitting ...')
         end if
c
c        calculate the jacobian matrix.
c
         iflag = 2
         call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4)
         nfev = nfev + n
         if (iflag .lt. 0) go to 300
c
c        if requested, call fcn to enable printing of iterates.
c
         if (nprint .le. 0) go to 40
         iflag = 0
         if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag)
         if (iflag .lt. 0) go to 300
   40    continue
c
c        compute the qr factorization of the jacobian.
c
         call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3)
c
c        on the first iteration and if mode is 1, scale according
c        to the norms of the columns of the initial jacobian.
c
         if (iter .ne. 1) go to 80
         if (mode .eq. 2) go to 60
         do 50 j = 1, n
            diag(j) = wa2(j)
            if (wa2(j) .eq. zero) diag(j) = one
   50       continue
   60    continue
c
c        on the first iteration, calculate the norm of the scaled x
c        and initialize the step bound delta.
c
         do 70 j = 1, n
            wa3(j) = diag(j)*x(j)
   70       continue
         xnorm = enorm(n,wa3)
         delta = factor*xnorm
         if (delta .eq. zero) delta = factor
   80    continue
c
c        form (q transpose)*fvec and store the first n components in
c        qtf.
c
         do 90 i = 1, m
            wa4(i) = fvec(i)
   90       continue
         do 130 j = 1, n
            if (fjac(j,j) .eq. zero) go to 120
            sum = zero
            do 100 i = j, m
               sum = sum + fjac(i,j)*wa4(i)
  100          continue
            temp = -sum/fjac(j,j)
            do 110 i = j, m
               wa4(i) = wa4(i) + fjac(i,j)*temp
  110          continue
  120       continue
            fjac(j,j) = wa1(j)
            qtf(j) = wa4(j)
  130       continue
c
c        compute the norm of the scaled gradient.
c
         gnorm = zero
         if (fnorm .eq. zero) go to 170
         do 160 j = 1, n
            l = ipvt(j)
            if (wa2(l) .eq. zero) go to 150
            sum = zero
            do 140 i = 1, j
               sum = sum + fjac(i,j)*(qtf(i)/fnorm)
  140          continue
            gnorm = amax1(gnorm,abs(sum/wa2(l)))
  150       continue
  160       continue
  170    continue
c
c        test for convergence of the gradient norm.
c
         if (gnorm .le. gtol) info = 4
         if (info .ne. 0) go to 300
c
c        rescale if necessary.
c
         if (mode .eq. 2) go to 190
         do 180 j = 1, n
            diag(j) = amax1(diag(j),wa2(j))
  180       continue
  190    continue
c
c        beginning of the inner loop.
c
  200    continue
c
c           determine the levenberg-marquardt parameter.
c
            call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2,
     *                 wa3,wa4)
c
c           store the direction p and x + p. calculate the norm of p.
c
            do 210 j = 1, n
               wa1(j) = -wa1(j)
               wa2(j) = x(j) + wa1(j)
               wa3(j) = diag(j)*wa1(j)
  210          continue
            pnorm = enorm(n,wa3)
c
c           on the first iteration, adjust the initial step bound.
c
            if (iter .eq. 1) delta = amin1(delta,pnorm)
c
c           evaluate the function at x + p and calculate its norm.
c
            iflag = 1
            call fcn(m,n,wa2,wa4,iflag)
            nfev = nfev + 1
            if (iflag .lt. 0) go to 300
            fnorm1 = enorm(m,wa4)
c
c           compute the scaled actual reduction.
c
            actred = -one
            if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2
c
c           compute the scaled predicted reduction and
c           the scaled directional derivative.
c
            do 230 j = 1, n
               wa3(j) = zero
               l = ipvt(j)
               temp = wa1(l)
               do 220 i = 1, j
                  wa3(i) = wa3(i) + fjac(i,j)*temp
  220             continue
  230          continue
            temp1 = enorm(n,wa3)/fnorm
            temp2 = (sqrt(par)*pnorm)/fnorm
            prered = temp1**2 + temp2**2/p5
            dirder = -(temp1**2 + temp2**2)
c
c           compute the ratio of the actual to the predicted
c           reduction.
c
            ratio = zero
            if (prered .ne. zero) ratio = actred/prered
c
c           update the step bound.
c
            if (ratio .gt. p25) go to 240
               if (actred .ge. zero) temp = p5
               if (actred .lt. zero)
     *            temp = p5*dirder/(dirder + p5*actred)
               if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1
               delta = temp*amin1(delta,pnorm/p1)
               par = par/temp
               go to 260
  240       continue
               if (par .ne. zero .and. ratio .lt. p75) go to 250
               delta = pnorm/p5
               par = p5*par
  250          continue
  260       continue
c
c           test for successful iteration.
c
            if (ratio .lt. p0001) go to 290
c
c           successful iteration. update x, fvec, and their norms.
c
            do 270 j = 1, n
               x(j) = wa2(j)
               wa2(j) = diag(j)*x(j)
  270          continue
            do 280 i = 1, m
               fvec(i) = wa4(i)
  280          continue
            xnorm = enorm(n,wa2)
            fnorm = fnorm1
            iter = iter + 1
  290       continue
c
c           tests for convergence.
c
            if (abs(actred) .le. ftol .and. prered .le. ftol
     *          .and. p5*ratio .le. one) info = 1
            if (delta .le. xtol*xnorm) info = 2
            if (abs(actred) .le. ftol .and. prered .le. ftol
     *          .and. p5*ratio .le. one .and. info .eq. 2) info = 3
            if (info .ne. 0) go to 300
c
c           tests for termination and stringent tolerances.
c
            if (nfev .ge. maxfev) info = 5
            if (abs(actred) .le. epsmch .and. prered .le. epsmch
     *          .and. p5*ratio .le. one) info = 6
            if (delta .le. epsmch*xnorm) info = 7
            if (gnorm .le. epsmch) info = 8
            if (info .ne. 0) go to 300
c
c           end of the inner loop. repeat if iteration unsuccessful.
c
            if (ratio .lt. p0001) go to 200
c
c        end of the outer loop.
c
         go to 30
  300 continue
c
c     termination, either normal or user imposed.
c
      if (iflag .lt. 0) info = iflag
      iflag = 0
      if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag)
      return
c
c     last card of subroutine lmdif.
c
      end
      real function enorm(n,x)
      integer n
      real x(n)
c     **********
c
c     function enorm
c
c     given an n-vector x, this function calculates the
c     euclidean norm of x.
c
c     the euclidean norm is computed by accumulating the sum of
c     squares in three different sums. the sums of squares for the
c     small and large components are scaled so that no overflows
c     occur. non-destructive underflows are permitted. underflows
c     and overflows do not occur in the computation of the unscaled
c     sum of squares for the intermediate components.
c     the definitions of small, intermediate and large components
c     depend on two constants, rdwarf and rgiant. the main
c     restrictions on these constants are that rdwarf**2 not
c     underflow and rgiant**2 not overflow. the constants
c     given here are suitable for every known computer.
c
c     the function statement is
c
c       real function enorm(n,x)
c
c     where
c
c       n is a positive integer input variable.
c
c       x is an input array of length n.
c
c     subprograms called
c
c       fortran-supplied ... abs,sqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i
      real agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs,x1max,x3max,
     *     zero
      data one,zero,rdwarf,rgiant /1.0e0,0.0e0,3.834e-20,1.304e19/
      s1 = zero
      s2 = zero
      s3 = zero
      x1max = zero
      x3max = zero
      floatn = n
      agiant = rgiant/floatn
      do 90 i = 1, n
         xabs = abs(x(i))
         if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70
            if (xabs .le. rdwarf) go to 30
c
c              sum for large components.
c
               if (xabs .le. x1max) go to 10
                  s1 = one + s1*(x1max/xabs)**2
                  x1max = xabs
                  go to 20
   10          continue
                  s1 = s1 + (xabs/x1max)**2
   20          continue
               go to 60
   30       continue
c
c              sum for small components.
c
               if (xabs .le. x3max) go to 40
                  s3 = one + s3*(x3max/xabs)**2
                  x3max = xabs
                  go to 50
   40          continue
                  if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2
   50          continue
   60       continue
            go to 80
   70    continue
c
c           sum for intermediate components.
c
            s2 = s2 + xabs**2
   80    continue
   90    continue
c
c     calculation of norm.
c
      if (s1 .eq. zero) go to 100
         enorm = x1max*sqrt(s1+(s2/x1max)/x1max)
         go to 130
  100 continue
         if (s2 .eq. zero) go to 110
            if (s2 .ge. x3max)
     *         enorm = sqrt(s2*(one+(x3max/s2)*(x3max*s3)))
            if (s2 .lt. x3max)
     *         enorm = sqrt(x3max*((s2/x3max)+(x3max*s3)))
            go to 120
  110    continue
            enorm = x3max*sqrt(s3)
  120    continue
  130 continue
      return
c
c     last card of function enorm.
c
      end
      subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1,
     *                 wa2)
      integer n,ldr
      integer ipvt(n)
      real delta,par
      real r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n),wa2(n)
c     **********
c
c     subroutine lmpar
c
c     given an m by n matrix a, an n by n nonsingular diagonal
c     matrix d, an m-vector b, and a positive number delta,
c     the problem is to determine a value for the parameter
c     par such that if x solves the system
c
c           a*x = b ,     sqrt(par)*d*x = 0 ,
c
c     in the least squares sense, and dxnorm is the euclidean
c     norm of d*x, then either par is zero and
c
c           (dxnorm-delta) .le. 0.1*delta ,
c
c     or par is positive and
c
c           abs(dxnorm-delta) .le. 0.1*delta .
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then lmpar expects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q transpose)*b. on output
c     lmpar also provides an upper triangular matrix s such that
c
c            t   t                   t
c           p *(a *a + par*d*d)*p = s *s .
c
c     s is employed within lmpar and may be of separate interest.
c
c     only a few iterations are generally needed for convergence
c     of the algorithm. if, however, the limit of 10 iterations
c     is reached, then the output par will contain the best
c     value obtained so far.
c
c     the subroutine statement is
c
c       subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,
c                        wa1,wa2)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle contains the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q transpose)*b.
c
c       delta is a positive input variable which specifies an upper
c         bound on the euclidean norm of d*x.
c
c       par is a nonnegative variable. on input par contains an
c         initial estimate of the levenberg-marquardt parameter.
c         on output par contains the final estimate.
c
c       x is an output array of length n which contains the least
c         squares solution of the system a*x = b, sqrt(par)*d*x = 0,
c         for the output par.
c
c       sdiag is an output array of length n which contains the
c         diagonal elements of the upper triangular matrix s.
c
c       wa1 and wa2 are work arrays of length n.
c
c     subprograms called
c
c       minpack-supplied ... spmpar,enorm,qrsolv
c
c       fortran-supplied ... abs,amax1,amin1,sqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,iter,j,jm1,jp1,k,l,nsing
      real dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001,sum,temp,zero
      real spmpar,enorm
      data p1,p001,zero /1.0e-1,1.0e-3,0.0e0/
c
c     dwarf is the smallest positive magnitude.
c
      dwarf = spmpar(2)
c
c     compute and store in x the gauss-newton direction. if the
c     jacobian is rank-deficient, obtain a least squares solution.
c
      nsing = n
      do 10 j = 1, n
         wa1(j) = qtb(j)
         if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1
         if (nsing .lt. n) wa1(j) = zero
   10    continue
      if (nsing .lt. 1) go to 50
      do 40 k = 1, nsing
         j = nsing - k + 1
         wa1(j) = wa1(j)/r(j,j)
         temp = wa1(j)
         jm1 = j - 1
         if (jm1 .lt. 1) go to 30
         do 20 i = 1, jm1
            wa1(i) = wa1(i) - r(i,j)*temp
   20       continue
   30    continue
   40    continue
   50 continue
      do 60 j = 1, n
         l = ipvt(j)
         x(l) = wa1(j)
   60    continue
c
c     initialize the iteration counter.
c     evaluate the function at the origin, and test
c     for acceptance of the gauss-newton direction.
c
      iter = 0
      do 70 j = 1, n
         wa2(j) = diag(j)*x(j)
   70    continue
      dxnorm = enorm(n,wa2)
      fp = dxnorm - delta
      if (fp .le. p1*delta) go to 220
c
c     if the jacobian is not rank deficient, the newton
c     step provides a lower bound, parl, for the zero of
c     the function. otherwise set this bound to zero.
c
      parl = zero
      if (nsing .lt. n) go to 120
      do 80 j = 1, n
         l = ipvt(j)
         wa1(j) = diag(l)*(wa2(l)/dxnorm)
   80    continue
      do 110 j = 1, n
         sum = zero
         jm1 = j - 1
         if (jm1 .lt. 1) go to 100
         do 90 i = 1, jm1
            sum = sum + r(i,j)*wa1(i)
   90       continue
  100    continue
         wa1(j) = (wa1(j) - sum)/r(j,j)
  110    continue
      temp = enorm(n,wa1)
      parl = ((fp/delta)/temp)/temp
  120 continue
c
c     calculate an upper bound, paru, for the zero of the function.
c
      do 140 j = 1, n
         sum = zero
         do 130 i = 1, j
            sum = sum + r(i,j)*qtb(i)
  130       continue
         l = ipvt(j)
         wa1(j) = sum/diag(l)
  140    continue
      gnorm = enorm(n,wa1)
      paru = gnorm/delta
      if (paru .eq. zero) paru = dwarf/amin1(delta,p1)
c
c     if the input par lies outside of the interval (parl,paru),
c     set par to the closer endpoint.
c
      par = amax1(par,parl)
      par = amin1(par,paru)
      if (par .eq. zero) par = gnorm/dxnorm
c
c     beginning of an iteration.
c
  150 continue
         iter = iter + 1
c
c        evaluate the function at the current value of par.
c
         if (par .eq. zero) par = amax1(dwarf,p001*paru)
         temp = sqrt(par)
         do 160 j = 1, n
            wa1(j) = temp*diag(j)
  160       continue
         call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2)
         do 170 j = 1, n
            wa2(j) = diag(j)*x(j)
  170       continue
         dxnorm = enorm(n,wa2)
         temp = fp
         fp = dxnorm - delta
c
c        if the function is small enough, accept the current value
c        of par. also test for the exceptional cases where parl
c        is zero or the number of iterations has reached 10.
c
         if (abs(fp) .le. p1*delta
     *       .or. parl .eq. zero .and. fp .le. temp
     *            .and. temp .lt. zero .or. iter .eq. 10) go to 220
c
c        compute the newton correction.
c
         do 180 j = 1, n
            l = ipvt(j)
            wa1(j) = diag(l)*(wa2(l)/dxnorm)
  180       continue
         do 210 j = 1, n
            wa1(j) = wa1(j)/sdiag(j)
            temp = wa1(j)
            jp1 = j + 1
            if (n .lt. jp1) go to 200
            do 190 i = jp1, n
               wa1(i) = wa1(i) - r(i,j)*temp
  190          continue
  200       continue
  210       continue
         temp = enorm(n,wa1)
         parc = ((fp/delta)/temp)/temp
c
c        depending on the sign of the function, update parl or paru.
c
         if (fp .gt. zero) parl = amax1(parl,par)
         if (fp .lt. zero) paru = amin1(paru,par)
c
c        compute an improved estimate for par.
c
         par = amax1(parl,par+parc)
c
c        end of an iteration.
c
         go to 150
  220 continue
c
c     termination.
c
      if (iter .eq. 0) par = zero
      return
c
c     last card of subroutine lmpar.
c
      end
      subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
      integer m,n,lda,lipvt
      integer ipvt(lipvt)
      logical pivot
      real a(lda,n),rdiag(n),acnorm(n),wa(n)
c     **********
c
c     subroutine qrfac
c
c     this subroutine uses householder transformations with column
c     pivoting (optional) to compute a qr factorization of the
c     m by n matrix a. that is, qrfac determines an orthogonal
c     matrix q, a permutation matrix p, and an upper trapezoidal
c     matrix r with diagonal elements of nonincreasing magnitude,
c     such that a*p = q*r. the householder transformation for
c     column k, k = 1,2,...,min(m,n), is of the form
c
c                           t
c           i - (1/u(k))*u*u
c
c     where u has zeros in the first k-1 positions. the form of
c     this transformation and the method of pivoting first
c     appeared in the corresponding linpack subroutine.
c
c     the subroutine statement is
c
c       subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
c
c     where
c
c       m is a positive integer input variable set to the number
c         of rows of a.
c
c       n is a positive integer input variable set to the number
c         of columns of a.
c
c       a is an m by n array. on input a contains the matrix for
c         which the qr factorization is to be computed. on output
c         the strict upper trapezoidal part of a contains the strict
c         upper trapezoidal part of r, and the lower trapezoidal
c         part of a contains a factored form of q (the non-trivial
c         elements of the u vectors described above).
c
c       lda is a positive integer input variable not less than m
c         which specifies the leading dimension of the array a.
c
c       pivot is a logical input variable. if pivot is set true,
c         then column pivoting is enforced. if pivot is set false,
c         then no column pivoting is done.
c
c       ipvt is an integer output array of length lipvt. ipvt
c         defines the permutation matrix p such that a*p = q*r.
c         column j of p is column ipvt(j) of the identity matrix.
c         if pivot is false, ipvt is not referenced.
c
c       lipvt is a positive integer input variable. if pivot is false,
c         then lipvt may be as small as 1. if pivot is true, then
c         lipvt must be at least n.
c
c       rdiag is an output array of length n which contains the
c         diagonal elements of r.
c
c       acnorm is an output array of length n which contains the
c         norms of the corresponding columns of the input matrix a.
c         if this information is not needed, then acnorm can coincide
c         with rdiag.
c
c       wa is a work array of length n. if pivot is false, then wa
c         can coincide with rdiag.
c
c     subprograms called
c
c       minpack-supplied ... spmpar,enorm
c
c       fortran-supplied ... amax1,sqrt,min0
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kmax,minmn
      real ajnorm,epsmch,one,p05,sum,temp,zero
      real spmpar,enorm
      data one,p05,zero /1.0e0,5.0e-2,0.0e0/
c
c     epsmch is the machine precision.
c
      epsmch = spmpar(1)
c
c     compute the initial column norms and initialize several arrays.
c
      do 10 j = 1, n
         acnorm(j) = enorm(m,a(1,j))
         rdiag(j) = acnorm(j)
         wa(j) = rdiag(j)
         if (pivot) ipvt(j) = j
   10    continue
c
c     reduce a to r with householder transformations.
c
      minmn = min0(m,n)
      do 110 j = 1, minmn
         if (.not.pivot) go to 40
c
c        bring the column of largest norm into the pivot position.
c
         kmax = j
         do 20 k = j, n
            if (rdiag(k) .gt. rdiag(kmax)) kmax = k
   20       continue
         if (kmax .eq. j) go to 40
         do 30 i = 1, m
            temp = a(i,j)
            a(i,j) = a(i,kmax)
            a(i,kmax) = temp
   30       continue
         rdiag(kmax) = rdiag(j)
         wa(kmax) = wa(j)
         k = ipvt(j)
         ipvt(j) = ipvt(kmax)
         ipvt(kmax) = k
   40    continue
c
c        compute the householder transformation to reduce the
c        j-th column of a to a multiple of the j-th unit vector.
c
         ajnorm = enorm(m-j+1,a(j,j))
         if (ajnorm .eq. zero) go to 100
         if (a(j,j) .lt. zero) ajnorm = -ajnorm
         do 50 i = j, m
            a(i,j) = a(i,j)/ajnorm
   50       continue
         a(j,j) = a(j,j) + one
c
c        apply the transformation to the remaining columns
c        and update the norms.
c
         jp1 = j + 1
         if (n .lt. jp1) go to 100
         do 90 k = jp1, n
            sum = zero
            do 60 i = j, m
               sum = sum + a(i,j)*a(i,k)
   60          continue
            temp = sum/a(j,j)
            do 70 i = j, m
               a(i,k) = a(i,k) - temp*a(i,j)
   70          continue
            if (.not.pivot .or. rdiag(k) .eq. zero) go to 80
            temp = a(j,k)/rdiag(k)
            rdiag(k) = rdiag(k)*sqrt(amax1(zero,one-temp**2))
            if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80
            rdiag(k) = enorm(m-j,a(jp1,k))
            wa(k) = rdiag(k)
   80       continue
   90       continue
  100    continue
         rdiag(j) = -ajnorm
  110    continue
      return
c
c     last card of subroutine qrfac.
c
      end
      subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
      integer n,ldr
      integer ipvt(n)
      real r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)
c     **********
c
c     subroutine qrsolv
c
c     given an m by n matrix a, an n by n diagonal matrix d,
c     and an m-vector b, the problem is to determine an x which
c     solves the system
c
c           a*x = b ,     d*x = 0 ,
c
c     in the least squares sense.
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then qrsolv expects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q transpose)*b. the system
c     a*x = b, d*x = 0, is then equivalent to
c
c                  t       t
c           r*z = q *b ,  p *d*p*z = 0 ,
c
c     where x = p*z. if this system does not have full rank,
c     then a least squares solution is obtained. on output qrsolv
c     also provides an upper triangular matrix s such that
c
c            t   t               t
c           p *(a *a + d*d)*p = s *s .
c
c     s is computed within qrsolv and may be of separate interest.
c
c     the subroutine statement is
c
c       subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle contains the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q transpose)*b.
c
c       x is an output array of length n which contains the least
c         squares solution of the system a*x = b, d*x = 0.
c
c       sdiag is an output array of length n which contains the
c         diagonal elements of the upper triangular matrix s.
c
c       wa is a work array of length n.
c
c     subprograms called
c
c       fortran-supplied ... abs,sqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kp1,l,nsing
      real cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero
      data p5,p25,zero /5.0e-1,2.5e-1,0.0e0/
c
c     copy r and (q transpose)*b to preserve input and initialize s.
c     in particular, save the diagonal elements of r in x.
c
      do 20 j = 1, n
         do 10 i = j, n
            r(i,j) = r(j,i)
   10       continue
         x(j) = r(j,j)
         wa(j) = qtb(j)
   20    continue
c
c     eliminate the diagonal matrix d using a givens rotation.
c
      do 100 j = 1, n
c
c        prepare the row of d to be eliminated, locating the
c        diagonal element using p from the qr factorization.
c
         l = ipvt(j)
         if (diag(l) .eq. zero) go to 90
         do 30 k = j, n
            sdiag(k) = zero
   30       continue
         sdiag(j) = diag(l)
c
c        the transformations to eliminate the row of d
c        modify only a single element of (q transpose)*b
c        beyond the first n, which is initially zero.
c
         qtbpj = zero
         do 80 k = j, n
c
c           determine a givens rotation which eliminates the
c           appropriate element in the current row of d.
c
            if (sdiag(k) .eq. zero) go to 70
            if (abs(r(k,k)) .ge. abs(sdiag(k))) go to 40
               cotan = r(k,k)/sdiag(k)
               sin = p5/sqrt(p25+p25*cotan**2)
               cos = sin*cotan
               go to 50
   40       continue
               tan = sdiag(k)/r(k,k)
               cos = p5/sqrt(p25+p25*tan**2)
               sin = cos*tan
   50       continue
c
c           compute the modified diagonal element of r and
c           the modified element of ((q transpose)*b,0).
c
            r(k,k) = cos*r(k,k) + sin*sdiag(k)
            temp = cos*wa(k) + sin*qtbpj
            qtbpj = -sin*wa(k) + cos*qtbpj
            wa(k) = temp
c
c           accumulate the tranformation in the row of s.
c
            kp1 = k + 1
            if (n .lt. kp1) go to 70
            do 60 i = kp1, n
               temp = cos*r(i,k) + sin*sdiag(i)
               sdiag(i) = -sin*r(i,k) + cos*sdiag(i)
               r(i,k) = temp
   60          continue
   70       continue
   80       continue
   90    continue
c
c        store the diagonal element of s and restore
c        the corresponding diagonal element of r.
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
  100    continue
c
c     solve the triangular system for z. if the system is
c     singular, then obtain a least squares solution.
c
      nsing = n
      do 110 j = 1, n
         if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1
         if (nsing .lt. n) wa(j) = zero
  110    continue
      if (nsing .lt. 1) go to 150
      do 140 k = 1, nsing
         j = nsing - k + 1
         sum = zero
         jp1 = j + 1
         if (nsing .lt. jp1) go to 130
         do 120 i = jp1, nsing
            sum = sum + r(i,j)*wa(i)
  120       continue
  130    continue
         wa(j) = (wa(j) - sum)/sdiag(j)
  140    continue
  150 continue
c
c     permute the components of z back to components of x.
c
      do 160 j = 1, n
         l = ipvt(j)
         x(l) = wa(j)
  160    continue
      return
c
c     last card of subroutine qrsolv.
c
      end
      real function spmpar(i)
      integer i
      real rmach(3)
ccc-      real function spmpar(i)
ccc-      integer i
c     **********
c
c     function spmpar
c
c***************************************************************
cc     rewritten to eliminate machine dependence of precision
cc     so as to give the same precision for all machines. for
cc     feffit, epsilon is set to 1.e-06, the minimum number is
cc     1.e-30, and the maximum is 1.e+30.
cc     to restore the orginal version, uncomment all lines
cc     beginning with  "ccc-", and comment out all other lines.
cc                             matt newville     oct 1992
c***************************************************************
c
c     this function provides single precision machine parameters
c     when the appropriate set of data statements is activated (by
c     removing the c from column 1) and all other data statements are
c     rendered inactive. most of the parameter values were obtained
c     from the corresponding bell laboratories port library function.
c
c     the function statement is
c
c       real function spmpar(i)
c
c     where
c
c       i is an integer input variable set to 1, 2, or 3 which
c         selects the desired machine parameter. if the machine has
c         t base b digits and its smallest and largest exponents are
c         emin and emax, respectively, then these parameters are
c
c         spmpar(1) = b**(1 - t), the machine precision,
c
c         spmpar(2) = b**(emin - 1), the smallest magnitude,
c
c         spmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude.
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c
c
c
c     **********
ccc-       integer mcheps(2)
ccc-       integer minmag(2)
ccc-       integer maxmag(2)
ccc-       real rmach(3)
ccc-       equivalence (rmach(1),mcheps(1))
ccc-       equivalence (rmach(2),minmag(1))
ccc-       equivalence (rmach(3),maxmag(1))
c
c     machine constants for the ibm 360/370 series,
c     the amdahl 470/v6, the icl 2900, the itel as/6,
c     the xerox sigma 5/7/9 and the sel systems 85/86.
c
c     data rmach(1) / z3c100000 /
c     data rmach(2) / z00100000 /
c     data rmach(3) / z7fffffff /
c
c     machine constants for the honeywell 600/6000 series.
c
c     data rmach(1) / o716400000000 /
c     data rmach(2) / o402400000000 /
c     data rmach(3) / o376777777777 /
c
c     machine constants for the cdc 6000/7000 series.
c
c     data rmach(1) / 16414000000000000000b /
c     data rmach(2) / 00014000000000000000b /
c     data rmach(3) / 37767777777777777777b /
c
c     machine constants for the pdp-10 (ka or ki processor).
c
c     data rmach(1) / "147400000000 /
c     data rmach(2) / "000400000000 /
c     data rmach(3) / "377777777777 /
c
c     machine constants for the pdp-11.
c
c     data mcheps(1),mcheps(2) / 13568,     0 /
c     data minmag(1),minmag(2) /   128,     0 /
c     data maxmag(1),maxmag(2) / 32767,    -1 /
c
c     machine constants for the burroughs 5700/6700/7700 systems.
c
c     data rmach(1) / o1301000000000000 /
c     data rmach(2) / o1771000000000000 /
c     data rmach(3) / o0777777777777777 /
c
c     machine constants for the burroughs 1700 system.
c
c     data rmach(1) / z4ea800000 /
c     data rmach(2) / z400800000 /
c     data rmach(3) / z5ffffffff /
c
c     machine constants for the univac 1100 series.
c
c     data rmach(1) / o147400000000 /
c     data rmach(2) / o000400000000 /
c     data rmach(3) / o377777777777 /
c
c     machine constants for the data general eclipse s/200.
c
c     note - it may be appropriate to include the following card -
c     static rmach(3)
c
c     data minmag/20k,0/,maxmag/77777k,177777k/
c     data mcheps/36020k,0/
c
c     machine constants for the harris 220.
c
c     data mcheps(1),mcheps(2) / '20000000, '00000353 /
c     data minmag(1),minmag(2) / '20000000, '00000201 /
c     data maxmag(1),maxmag(2) / '37777777, '00000177 /
c
c     machine constants for the cray-1.
c
c     data rmach(1) / 0377224000000000000000b /
c     data rmach(2) / 0200034000000000000000b /
c     data rmach(3) / 0577777777777777777776b /
c
c     machine constants for the prime 400.
c
c     data mcheps(1) / :10000000153 /
c     data minmag(1) / :10000000000 /
c     data maxmag(1) / :17777777777 /
c
c     machine constants for the vax-11.
c
ccc-       data mcheps(1) /  13568 /
ccc-       data minmag(1) /    128 /
ccc-       data maxmag(1) / -32769 /
       data rmach(1), rmach(2), rmach(3) /1.e-06,1.e-30,1.e+30 /
       spmpar = rmach(i)
       return
c
ccc-       spmpar = rmach(i)
ccc-       return
c
c     last card of function spmpar.
c
ccc-       end
c end function spmpar
       end
      subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
      integer m,n,ldfjac,iflag
      real epsfcn
      real x(n),fvec(m),fjac(ldfjac,n),wa(m)
      external fcn
c     **********
c
c     subroutine fdjac2
c
c     this subroutine computes a forward-difference approximation
c     to the m by n jacobian matrix associated with a specified
c     problem of m functions in n variables.
c
c     the subroutine statement is
c
c       subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa)
c
c     where
c
c       fcn is the name of the user-supplied subroutine which
c         calculates the functions. fcn must be declared
c         in an external statement in the user calling
c         program, and should be written as follows.
c
c         subroutine fcn(m,n,x,fvec,iflag)
c         integer m,n,iflag
c         real x(n),fvec(m)
c         ----------
c         calculate the functions at x and
c         return this vector in fvec.
c         ----------
c         return
c         end
c
c         the value of iflag should not be changed by fcn unless
c         the user wants to terminate execution of fdjac2.
c         in this case set iflag to a negative integer.
c
c       m is a positive integer input variable set to the number
c         of functions.
c
c       n is a positive integer input variable set to the number
c         of variables. n must not exceed m.
c
c       x is an input array of length n.
c
c       fvec is an input array of length m which must contain the
c         functions evaluated at x.
c
c       fjac is an output m by n array which contains the
c         approximation to the jacobian matrix evaluated at x.
c
c       ldfjac is a positive integer input variable not less than m
c         which specifies the leading dimension of the array fjac.
c
c       iflag is an integer variable which can be used to terminate
c         the execution of fdjac2. see description of fcn.
c
c       epsfcn is an input variable used in determining a suitable
c         step length for the forward-difference approximation. this
c         approximation assumes that the relative errors in the
c         functions are of the order of epsfcn. if epsfcn is less
c         than the machine precision, it is assumed that the relative
c         errors in the functions are of the order of the machine
c         precision.
c
c       wa is a work array of length m.
c
c     subprograms called
c
c       user-supplied ...... fcn
c
c       minpack-supplied ... spmpar
c
c       fortran-supplied ... abs,amax1,sqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j
      real eps,epsmch,h,temp,zero
      real spmpar
      data zero /0.0e0/
c
c     epsmch is the machine precision.
c
      epsmch = spmpar(1)
c
      eps = sqrt(amax1(epsfcn,epsmch))
      do 20 j = 1, n
         temp = x(j)
         h = eps*abs(temp)
         if (h .eq. zero) h = eps
         x(j) = temp + h
         call fcn(m,n,x,wa,iflag)
         if (iflag .lt. 0) go to 30
         x(j) = temp
         do 10 i = 1, m
            fjac(i,j) = (wa(i) - fvec(i))/h
   10       continue
   20    continue
   30 continue
      return
c
c     last card of subroutine fdjac2.
c
      end
       subroutine fiterr(fcn,nfit,nvar,mfit,mvar,fbest,ftemp,fjac,
     $      alpha,iprint,iounit,istep,x,delta,correl,ierror,iflag)
c
c     error analysis for a fit using the minpack routines
c
c     given a subroutine, *fcn*, to generate a fitting function
c     with *nfit* evaluations from a set of *nvar* variables,
c     with best-fit values *x* and residuals *fbest* determined,
c     this will return the uncertainties in *x* to *delta*, and
c     the correlations between the variables in *correl*.
c
c     copyright 1994 university of washington         matt newville
c
c  arguments:
c     fcn     name of subroutine to generate fitting function,    [in]
c             with call statement as for minpack routines :
c                   call fcn(nfit,nvar,x,f,ier)
c     nfit    number of function evaluations for call to fcn      [in]
c     nvar    number of variables                                 [in]
c     mfit    dimension of arrays for function evaluations        [in]
c     mvar    dimension of arrays for variables                   [in]
c     fbest   array of fit residual for best fit         (mfit)   [in]
c     ftemp   array of fit residuals for constructing    (mfit) [work]
c             jacobian. on output, this is equal to fbest.
c     fjac    array of finite difference jacobian   (mfit,mvar) [work]
c     alpha   curvature and covariance matrix       (mvar,mvar) [work]
c     iprint  integer print flag for debug messages               [in]
c     iounit  open fortran unit for debug messages                [in]
c     istep   maximum number of loops in error evaluation         [in]
c     x       array of best fit values for variables     (mvar)   [in]
c     delta   array of uncertainties for the variables   (mvar)  [out]
c     correl  array of two-variable correlations    (mvar,mvar)  [out]
c     ierror  integer flag that is non-zero if error bars        [out]
c             cannot be estimated because the curvature
c             matrix cannot be inverted, so that one or
c             more of the variables do not affect the fit.
c     iflag   integer array whose elements are 1 if the   (mvar) [out]
c             corresponding variable is suspected of
c             causing the failure of the inversion of the
c             curvature matrix. these may be null variables.
c
c  required external subprograms:
c     fcn,  gaussj (both subroutines)
c
c     the algorithm here is to construct and invert the nvar x nvar
c     curvature matrix  alpha, whose elements are found by summing
c     over the elements of the jacobian matrix, fjac:
c        fjac(i,j) = dfvect(i) / dx(j)   (i = 1, nfit; j = 1, nvar)
c     where fvect is the residual array for the fit and dx is a small
c     change in one variable away from the best-fit solution. then
c        alpha(j,k) = alpha(k,j)
c                   = sum_(i=1)^nfit (fjac(i,j) * fjac(i,k))
c
c     the inverse of alpha gives the curvature matrix, whose diagonal
c     elements are used as the uncertainties and whose off-diagonal
c     elements give the correlations between variables.
c--------------------------------------------------------------------
       integer  mfit,mvar,nfit,nvar,i,k,j,iloop,istep, istepx
       integer  iflag(mvar), ierror, iprint, iounit, ier
       real     fbest(mfit), ftemp(mfit), fjac(mfit,mvar)
       real     x(mvar), correl(mvar,mvar), alpha(mvar,mvar)
       real     delta(mvar), delx, sum, tempx
       real     eps, epsdef, tiny, zero, two
       parameter (zero   = 0.e0,   two  = 2.e0  )
       parameter (epsdef = 1.0e-2, tiny = 1.0e-10)
       external  fcn, gaussj
c
       if (iprint.ge.4)  write (iounit,*) '>>>> fiterr start'
       istepx= max(1, istep)
       ier   = 0
       ierror= 0
       iloop = 0
 10    continue
       iloop = iloop  + 1
c
c     construct jacobian using the best possible guess for the
c     relative error in each variable to evaluate the derivatives.
c     if not available, use 1% of the value for the variable.
       do 50 j = 1, nvar
          tempx = x(j)
          eps   = delta(j) / (two * max(tiny, abs(tempx)))
          if (iloop .eq. 1)        eps = epsdef
          delx = max( tiny, eps * abs(tempx) )
          x(j) = tempx + delx
          if (iprint.ge.4)  write (iounit,*) '>>>> call fcn'
          call fcn(nfit, nvar, x, ftemp, ier)
          if (ier .lt. 0) then
             if (iprint.ge.4)  write (iounit,*) '>>>> fcn died'
             go to 65
          end if
          if (iprint.ge.4)
     $      write (iounit,*) '    >> in loop: tempx,delx',tempx,delx
          do 30 i = 1, nfit
             fjac(i,j) = ( fbest(i) - ftemp(i)) / delx
 30       continue
          x(j)  = tempx
 50    continue
 65    continue
c
c   re-evaluate best-fit to restore any common block stuff
       call fcn(nfit,nvar,x,ftemp,ier)
c
c     collect the symmetric curvature matrix, store in alpha
       if (iprint.ge.5)  then
          write (iounit,*) '   curvature matrix:'
          write (iounit,*) '     j , k , alpha(j,k)'
       end if
       do 180 j = 1, nvar
          do 160 k = 1, j
             sum  = zero
             do 140 i = 1, nfit
                sum = sum  + fjac(i,j) * fjac(i,k)
 140         continue
             alpha(j,k) = sum
             if (k.ne.j) alpha(k,j) = sum
             if (iprint.ge.5)  write (iounit,*) j, k, alpha(j,k)
 160      continue
 180   continue
c
c     invert alpha to give the covariance matrix.  gaussj does
c     gauss-jordan elimination which will die if the matrix is
c     singular. although more efficient versions of this method
c     exist, in the event of a singular matrix, this one will
c     preserve the original matrix and set ier to 1.
       ier   = 0
       call gaussj(alpha,nvar,mvar,ier)
c
c     if alpha could not be inverted, flag those variables with
c     small diagonal components of alpha - these are the likely
c     null variables that caused the matrix inversion to fail.
       if (ier.ge.1) then
          ierror = 1
          if (iprint.ge.4) write(iounit,*)
     $             '!!!inversion failed!!!     i, alpha(i,i) '
          do 250 i = 1, nvar
             iflag(i) = 0
             if (iprint.ge.4)  write(iounit,*) i, alpha(i,i)
             if (abs(alpha(i,i)).le. tiny)  iflag(i) = 1
 250      continue
          return
       end if
c
c     alpha now contains the covariance matrix, and is easily
c     converted into delta, the uncertainty for each variable,
c     and correl, the two-variable correlation matrix.
       if (iprint.ge.4)  then
          write (iounit,*) ' fiterr done with loop = ',iloop
          write (iounit,*) '     j , delta(j)'
       end if
       do 360 i = 1, nvar
          delta(i) = max(tiny, sqrt( abs( alpha(i,i)) ))
          if (iprint.ge.4) write (iounit,*) i, delta(i)
          do 330 j = 1, i
             correl(j,i) =  alpha(j,i) / (delta(i) * delta(j))
             correl(i,j) = correl(j,i)
 330      continue
 360   continue
c
c     try it a second time with better estimates for the values
c     of deltax for the derivatives to get the jacobian matrix.
       if ( iloop .lt. istepx ) go to 10
c
c     finished
       if (iprint.ge.4)  write (iounit,*) '>>>> fiterr done'
       return
c     end routine fiterr
       end
       subroutine gaussj(a, n, ma, ier)
c
c     gauss-jordan elimination to invert a matrix.
c          based on a routine in 'numerical recipes' by
c          press, flannery, teukolsky, and vetterling.
c  inputs :
c    a     matrix to invert (dimension)
c    n     number of elements in a to use (i.e. that aren't zero)
c    ma    dimension of array a  (current maximum is 100 x 100)
c  outputs:
c    a     inverted matrix if ier = 0
c          input matrix    if ier = 1
c    ier   error code, set to 1 if matrix cannot be inverted
c
c                                              matt newville
c--------------------------------------------------------------
       parameter (nmax = 100)
       parameter (zero = 0., one = 1.)
       dimension a(ma, ma) , asav(nmax, nmax)
       dimension ipiv(nmax), indxr(nmax),indxc(nmax)
c
       irow = 0
       icol = 0
       ier  = 0
       if ( (n.gt.nmax) .or. (n.gt.ma) ) then
          call messag('  gaussj error: matrix too big ')
          ier  = 1
          return
       end if
c  initialize ipiv, and keep a spare version
c  of the input matrix around just in case
       do 30 i = 1, n
          ipiv(i) = 0
          do 20 j = 1, n
             asav(j,i) = a(j,i)
 20       continue
 30    continue
c
c  main loop over the columns to be reduced
c
       do 300 i = 1, n
          big = zero
c                                   search for a pivot element
          do 120 j = 1, n
             if (ipiv(j).ne.1) then
                do 100 k = 1, n
                   if (ipiv(k).eq.0) then
                      if ( abs(a(j,k)) .ge. big) then
                         big  = abs(a(j,k))
                         irow = j
                         icol = k
                      endif
                   elseif (ipiv(k).gt.1) then
                      ier = 1
                      go to 500
                   endif
 100            continue
             endif
 120      continue
          ipiv(icol) = ipiv(icol) + 1
c                                    a pivot has been found
          if (irow.ne.icol) then
             do 160 l = 1, n
                dum        = a(irow, l)
                a(irow, l) = a(icol, l)
                a(icol, l) = dum
 160         continue
          endif
c     divide the pivot row by the pivot element
          indxr(i) = irow
          indxc(i) = icol
          if (a(icol, icol).eq.zero) then
             ier = 1
             go to 500
          end if
          pivinv       = one / a(icol, icol)
          a(icol,icol) = one
          do 200 l = 1, n
             a(icol, l) = a(icol, l) * pivinv
 200      continue
c     reduce the rows except for the pivot one
          do 250 ll = 1, n
             if (ll.ne.icol) then
                dum        = a(ll, icol)
                a(ll,icol) = zero
                do 220 l = 1, n
                   a(ll,l) = a(ll,l) - a(icol,l) * dum
 220            continue
             endif
 250      continue
 300   continue
c
c   unscramble the solution, by interchanging column pairs
c   in the reverse order that the permutation was done
c
       do 400 i = n, 1, -1
          if (indxr(i) .ne. indxc(i)) then
             do 350 j = 1, n
                dum           = a(j,indxr(i))
                a(j,indxr(i)) = a(j,indxc(i))
                a(j,indxc(i)) = dum
 350         continue
          endif
 400   continue
c
c     if any errors happened, restore original matrix
c
 500   continue
       if (ier.ne.0) then
          do 540 i = 1, n
             do 520 j = 1, n
                a(j,i) = asav(j,i)
 520         continue
 540      continue
       end if
c
       return
c  end subroutine gaussj
       end
      subroutine fitlog
c
c      write log file to summarize fitting run for feffit.
c      the layout here is hoped to be user-friendly.
c      feel free to change any of this at any time.
c
c      copyright 1993 university of washington         matt newville
c
c----------------------------------------------------------------------
c        include 'fitcom.h'
c{fitcom.h
c  common blocks for feffit
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c fitcom.h}
c---------------------------------------------------------------------
       character*40 winstr(8), logfil, stat*7, outstr*128
       real         par(mdpths, mpthpr), rfmin, rfave
       real         redchi, sqrchi, order, small, ten
       real         tmp1(mvarys**2), tmp2(mvarys**2)
       integer      ilog
       data  winstr(1) /'hanning window sills'/
       data  winstr(2) /'hanning window fraction'/
       data  winstr(3) /'gaussian window'/
       data  winstr(4) /'lorentzian window'/
       data  winstr(5) /'parzen window '/
       data  winstr(6) /'welch window '/
       data  winstr(7) /'sine window '/
       data  winstr(8) /'gaussian window (2nd form)'/
       data  rfmin, small, ten   / 0.05000, 1.e-5, 10.0/
       data stat   /'unknown'/
c----------------------------------------------------------------------
       if (vaxflg)  stat = 'new'
c  determine log file name (usually trivial)
c  but if not, find the *last* "."
       logfil = 'feffit.log'
       if (inpfil.ne.'feffit.inp') then
          call triml(inpfil)
          idot  = max(1,istrln(inpfil))
          if (index(inpfil(1:idot),'.').ne.0) then
 15          continue
             if (index(inpfil(idot:idot),'.').eq.0) then
                idot = idot - 1
                go to 15
             end if
          end if
          logfil = inpfil(1:idot) //'log'
       end if
c  open log file
       ilog   = 0
       ierr   = 0
       iex    = 0
       call openfl(ilog, logfil, stat, iex, ierr)
       if (ierr.lt.0) call finmsg(1002,' ',logfil,0)
c
c  write preliminary messages:
       ilen   = max(1, istrln(versn))
       write(ilog,9002) '   '//versn(1:ilen)
       write(ilog,9904)
c  list input data sets, titles for each
c  also, compute average r-factor
       if (ndata.eq.0) then
          write(ilog,9003) 'no input data files.'
       else
          if (ndata.eq.1) then
             write(ilog,9003) 'input data file:'
          else
             write(ilog,9003) 'input data files:'
          endif
          rfave  = zero
          do 80 n = 1, ndata
             rfave = rfave + rfactr(n)
             if (ndata.gt.1)  write(ilog,9055) '-> data set ',n
             if (datain(n)) then
                ilen = max(1, istrln(chifil(n)))
                outstr = 'input data chi file = '
     $               //chifil(n)(:ilen)//', skey = '//skey(n)
             else
                outstr = ' no input data file given'
             endif
             ilen = max(1,istrln(outstr))
             write(ilog,9005) outstr(1:ilen)
c##<bkg
             if (bkgdat(n)) then
                ilen = max(1, istrln(bkgfil(n)))
                outstr = 'used bkg(k) from file = '
     $               //bkgfil(n)(:ilen)//', skey = '//skeyb(n)
                ilen = max(1,istrln(outstr))
                write(ilog,9005) outstr(1:ilen)
             end if
             if (bkgfit(n)) then
                write(ilog,9005) '  fitted background spline to data'
                write(ilog,9015) '  with rbkg = ', rbkg(n),
     $               '  and n_knots = ',nbkg(n)
             end if
c##bkg>
 80       continue
       end if
       write(ilog,9902)
c----------------------------------------------------------------
c  preliminary : list data sets, weight for each
c     full fit : total indep. points, fit parameters, chi-square, reduced
c     full fit : variables, uncertainties, correlations, init. guesses
c     full fit : user-defined functions
c
       xnu    = xnidp - numvar
       outstr = 'fit results, goodness of fit, and error analysis:'
       ilen = max(1,istrln(outstr))
       write(ilog,9003) outstr(1:ilen)
       if (abs(tranq-2).gt.small) then
          write(ilog,9910) 'used tranquada correction = ', tranq
       end if
       if (rm2flg) write(ilog,9903) 'used {reff}^{-2} in XAFS Eqn'
       if (ndata.gt.1)
     $      write(ilog,9055) 'number of data sets           = ',ndata
       write(ilog,9060) 'independent points in data    = ',xnidp
       write(ilog,9055) 'number of variables in fit    = ',numvar
       write(ilog,9060) 'degrees of freedom in fit     = ',xnu
       rfave = rfave / ndata
       write(ilog,9035) 'r-factor of fit               = ',rfave
       if (rfave.gt.rfmin)  write(ilog,9903)
     $     ' warning: this r-factor is too big.  the fit might be bad.'
       if (chisqr.lt. 999 999) then
          write(ilog,9035) 'chi-square                    = ',chisqr
       else
          write(ilog,9036) 'chi-square                    = ',chisqr
       end if
       redchi =  chisqr
       if (xnu.gt.0) then
          redchi =  chisqr / xnu
          if (redchi.lt. 999 999) then
           write(ilog,9035) 'reduced chi-square            = ',redchi
          else
           write(ilog,9036) 'reduced chi-square            = ',redchi
          end if
       elseif (xnu.eq.0) then
          write(ilog,9005) 'questionable fit: all independent ',
     $         'points were used in fit!'
       else
          write(ilog,9005) 'invalid fit: more variables than',
     $         ' independent points !'
       end if
       write(ilog,9003) ' '
c
c---------------------------------------------------------------
c  write out the variables and uncertainties, and correlations
c
       if (numvar.le.0) then
          write(ilog,9005) 'no variables were used in feffit'
       else
          outstr = 'feffit found the following values for '//
     $             'the variables:'
          ilen = max(1,istrln(outstr))
          write(ilog,9005) outstr(1:ilen)
          outstr = 'variable            best fit value    '//
     $             'uncertainty  initial guess'
          ilen = max(1,istrln(outstr))
          write(ilog,9002) '      '//outstr(1:ilen)
c
c    go through all values, deciding which were variables, and
c    if any "set" values (user-defined functions) were used.
          sqrchi =   sqrt(abs(redchi))
          do 140 i = 1, numvar
             ilen = max(15,  istrln(vnames(i)))
             write(ilog,9070) vnames(i)(1:ilen),'=', xfinal(i),
     $            sqrchi * delta(i), xguess(i)
 140      continue
          write(ilog,9003) '    '
c    if successfully calculated, report error bars,
c    otherwise report which variables might be the problem ones
          if (ierbar.lt.0) then
             write(ilog,9002)
     $     '       uncertainties could not be estimated. at least'
             write(ilog,9002)
     $     '       one of the variables does not affect the fit.'
             do 180 nv = 1, numvar
                   ilen = max(25, istrln(vnames(nv) ))
                   if (abs(xfinal(nv) - xguess(nv)).le.small) then
                      write(ilog,9007)  '      check  '
     $                     //vnames(nv)(1:ilen)
                   end if
 180         continue
          else
c
c write out correlation matrix, sorted so that most highly correlated
c pairs of variables are printed first.
c       first load array with abs(correl) and with j*numvar + i
             write(ilog,9005) 'correlation between variables '
             outstr = 'variable #1    variable #2         correlation'
             ilen = max(1,istrln(outstr))
             write(ilog,9007) outstr(1:ilen)
             ntmp = 0
             if (numvar.eq.2) then
                 ilen = max(15, istrln(vnames(1)))
                 jlen = max(15, istrln(vnames(2)))
                 write(ilog,9080) vnames(1)(:ilen),
     $                            vnames(2)(:jlen), correl(1,2)
             elseif (numvar.gt.2) then
                do 230 nvr1 = 1, numvar
                   do 220 nvr2 = nvr1+1, numvar
                      ntmp       = ntmp + 1
                      tmp1(ntmp) = abs(correl(nvr1, nvr2))
                      tmp2(ntmp) = nvr2 * numvar + nvr1
 220               continue
 230            continue
                call sort2(ntmp,tmp1,tmp2)
                do 270 n  = ntmp, 1, -1
                   ind = int(tmp2(n))
                   if (ind.gt.0) then
                      nvr1 = mod(ind, numvar)
                      nvr2 = ind / numvar
                      corr = abs( correl(nvr1,nvr2) )
                      if (corr.ge.cormin) then
                         ilen = max(15, istrln(vnames(nvr1)))
                         jlen = max(15, istrln(vnames(nvr2)))
                         write(ilog,9080) vnames(nvr1)(:ilen),
     $                     vnames(nvr2)(:jlen), correl(nvr1,nvr2)
                      else
                         outstr='all other correlations are less than'
                         ilen   = max(1, istrln(outstr))
                         write(ilog,9030) outstr(1:ilen+1), cormin
                         go to 275
                      endif
                   endif
 270            continue
 275            continue

c
             end if
cc             write(ilog,9903)
cc     $'--------------------------------------------------------------'
cc             write(ilog,9903)
cc     $'the uncertainties and correlations listed above are estimated '
cc             write(ilog,9903)
cc     $'under the assumption that the errors are normally distributed.'
cc             write(ilog,9903)
cc     $'                                                              '
cc             write(ilog,9903)
cc     $'the uncertainties given are estimated to increase the best-fit'
cc             write(ilog,9903)
cc     $'value of chi-square by the value of reduced chi-square.       '
cc             write(ilog,9903)
cc     $'     this assumes the fit is "good" and that the value of     '
cc             write(ilog,9903)
cc     $'     the measurement uncertainty was poorly estimated.        '
cc             write(ilog,9903)
cc     $'--------------------------------------------------------------'
          end if
       end if
c
c--------------------------------------------------------------
c  for each data set :
c     titles, fft, indep. points, measure uncertainty, chi-square
c     feff paths, with path parameters
c
       id = 1
 500   continue
       if (ndata.gt.1)  then
         write(ilog,9904)
         write(ilog,9055) 'data set ',id
         write(ilog,9003) 'measurements for this data set only:'
       end if
c data file name
       if (datain(id)) then
          ilen = max(1, istrln(chifil(id)))
          outstr = 'input data chi file = '
     $             //chifil(id)(:ilen)//', skey = '//skey(id)
          write(ilog,9005) 'user titles:'
          do 540 i = 1, mtitle
             call triml(titles(i,id))
             ilen = istrln(titles(i,id))
             if (ilen.gt.0) write(ilog,9007) titles(i,id)(:ilen)
 540      continue
c
       else
          outstr = ' no input data used'
       endif
       ilo = max(1,istrln(outstr))
       write(ilog,9005) outstr(1:ilo)
c
c information content and uncertainty information for this data
       write(ilog,9005) 'measurement uncertainty of data:'
       write(ilog,9035) '             ... in k-space     = ',sigdtk(id)
       write(ilog,9035) '             ... in r-space     = ',sigdtr(id)
       write(ilog,9035) '             ... in q-space     = ',sigdtq(id)
       write(ilog,9035) 'user-chosen weight for data     = ',sigwgt(id)
       write(ilog,9035) 'weight used for chi-square      = ',weight(id)
       write(ilog,9035) 'independent points in data      = ',xinfo(id)
       if (ndata.gt.1) then
          write(ilog,9035) 'partial chi-square for data set = ',
     $         chi2dt(id)
          write(ilog,9035) 'r-factor for data set           = ',
     $         rfactr(id)
       else
          write(ilog,9035) 'chi-square                      = ',
     $         chi2dt(id)
          write(ilog,9035) 'r-factor                        = ',
     $         rfactr(id)
       end if
c fitting range, fft details
       if (ifft(id).eq.0) then
          write(ilog,9005) 'fitting was done in original k-space'
          write(ilog,9902)
          write(ilog,9020) 'k range    = [',qmin(id),',',qmax(id),' ]'
       elseif (ifft(id).eq.1) then
          write(ilog,9005) 'fitting was done in r-space'
          write(ilog,9020) 'r range    = [',rmin(id),',',rmax(id),' ]'
          write(ilog,9902)
          write(ilog,9003) 'fourier transform information:'
          write(ilog,9020) 'k range    = [',qmin(id),',',qmax(id),' ]'
          write(ilog,9030) 'k weight   =  ', qweigh(id)
          write(ilog,9020) 'dk1, dk2   =  ',qwin1(id),',',qwin2(id),' '
          write(ilog,9005) 'window type= '//winstr(iqwin(id) + 1)
       elseif (ifft(id).eq.2) then
          write(ilog,9005) 'fitting was done in '//
     $         'backtransformed k-space'
          write(ilog,9020) 'k range    = [',qmin(id),',',qmax(id),' ]'
          write(ilog,9902)
          write(ilog,9003) 'fourier transform information (k->r):'
          write(ilog,9020) 'k range    = [',qmin(id),',',qmax(id),' ]'
          write(ilog,9030) 'k weight   =  ', qweigh(id)
          write(ilog,9020) 'dk1, dk2   =  ',qwin1(id),',',qwin2(id),' '
          write(ilog,9005) 'window type= '//winstr(iqwin(id) + 1)
          write(ilog,9003) 'fourier transform information (r->k):'
          write(ilog,9020) 'r range    = [',rmin(id),',',rmax(id),' ]'
          write(ilog,9030) 'r weight   =  ', rweigh(id)
          write(ilog,9020) 'dr1, dr2   =  ',rwin1(id),',',rwin2(id),' '
          write(ilog,9005) 'window type= '//winstr(irwin(id) + 1)
       endif
       write(ilog,9055) 'number of points in fft for fitting = ',mftfit
       write(ilog,9055) 'number of points in fft for outputs = ',mftwrt
       write(ilog,9902)
c--------------------------------------------------------------
c  write out the "set" values of user defined functions
       if (nmathx.eq.numvar) then
          outstr = 'no "set" values were used in feffit'
          write(ilog,9005) outstr
       else
          outstr = 'feffit found the following values '//
     $             'for the "fixed" values:'
          ilo = max(1,istrln(outstr))
          write(ilog,9005) outstr(1:ilo)
c     ----------------------------------------
c     first evaluate the set values for this data set
          inpath    = max(1, jdtpth(1,id))
          jfeff     = max(1, jpthff(inpath))
          reff      = max(small, refpth(jfeff))
          ixpath    = jfeff
          consts(4) = reff
          call setval(numvar+1,nmathx,icdval,maxval,micode,
     $          consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
          do 700 i = numvar+1, nmathx
             ilen      = max(20, istrln(vnames(i)))
             order     = abs(log( abs( values(i)) + small ))
             if (order.lt.ten) then
                write(outstr,9310) vnames(i)(1:ilen), values(i)
             else
                write(outstr,9320) vnames(i)(1:ilen), values(i)
             end if
             if (icdval(1,i).gt.ixlocl)
     $            call append(outstr,'          (local) ',im)
             ilo = max(1,istrln(outstr))
             write(ilog,9005) outstr(1:ilo)
 700      continue
          write(ilog,9902)
       end if
c     ----------------------------------------
c     for each path, write out the index and label, and
c     calculate and save the numerical path parameters.
c
c write out names of feff.dat files
       write(ilog,9003) 'path   feff file name'
c
c    iuser    "user path index" written in feffit.inp
c    inpath   "internal path index"  for the path parameters [mpaths]
c    ifeff    "feff path index"  for the feff files          [mfffil]
c    idpath   "data path index"  for each data set  [0:mdpths, mdata]
c    pointers held in common:
c            jdtpth(idpath,idata) = inpath
c            jdtusr(idpath,idata) = iuser
c            jpthff(inpath)       = ifeff
       do 1500 ipath = 1, mdpths
          inpath = jdtpth(ipath,id)
          if (inpath.gt.0) then
             jfeff  = jpthff(inpath)
             ixpath = jfeff
             juser  = jdtusr(ipath, id)
             call triml(feffil(jfeff))
             ilen = max(1, istrln(feffil(jfeff)))
             if (iffrec(jfeff).eq.0) then
                write(ilog,9100) juser, feffil(jfeff)(1:ilen)
             else
                write(ilog,9105) juser, feffil(jfeff)(1:ilen),
     $               iffrec(jfeff)
             endif
          end if
 1500  continue
c write out user id's
       write(ilog,9902)
       write(ilog,9003) 'path   identification '
       do 1600 ipath = 1, mdpths
          inpath = jdtpth(ipath,id)
          if (inpath.gt.0) then
             jfeff  = jpthff(inpath)
             juser  = jdtusr(ipath, id)
             call triml(pthlab(inpath))
             ilen = min(70, istrln(pthlab(inpath)) )
             if (ilen.le.0) then
                ilen = min(70, max(1, istrln(feffil(jfeff))))
                if (iffrec(jfeff).eq.0) then
                   write(pthlab(inpath),9450)
     $                  feffil(jfeff)(1:ilen), refpth(jfeff),
     $                  degpth(jfeff), nlgpth(jfeff)
                else
                   write(pthlab(inpath),9455)
     $                  feffil(jfeff)(1:ilen), iffrec(jfeff),
     $     refpth(jfeff), degpth(jfeff), nlgpth(jfeff)
                end if
             endif
             ilen = min(70, max(1, istrln(pthlab(inpath))))
             write(ilog,9100) juser, pthlab(inpath)(1:ilen)
          end if
 1600  continue
c--------------------------------------------------------------
c path parameters
c  evaluate the path parameters from the values and defaults
       do 2000 idpath = 1, mdpths
          inpath    = jdtpth(idpath,id)
          if (inpath.eq.0)    go to 1990
          jfeff     = jpthff(inpath)
          reff      = refpth(jfeff)
          ixpath    = jfeff
          consts(4) = reff
c     evaluate the non-variable values
c  evaluate the non-variable values
c     in case they depend on reff, local values to data set, etc
c##          if (numvar.gt.0) then
             nstart = nconst + numvar + 1
             call setval(nstart,nmathx,icdval,maxval,micode,
     $          consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
c##          end if
c     evaluate the path parameters from the values and defaults
c     (these were found in fitfun before this routine was called)
          do 1950 i = 1, mpthpr
             par(idpath,i) = decod(icdpar(1, i, inpath), micode,
     $                             consts, values, defalt(i))
 1950     continue
c
 1990     continue
 2000  continue
c     write out first set of numerical path parameters
       write(ilog,9902)
       outstr = 'path    degen     amp        e0'//
     $          '    {reff + delr}   delr        sigma2'
       ilo = max(1,istrln(outstr))
       write(ilog,9003) outstr(1:ilo)
       do 3500 idpath = 1, mdpths
          inpath = jdtpth(idpath,id)
          if (inpath.gt.0) then
             jfeff     = jpthff(inpath)
             write(ilog,9150) jdtusr(idpath, id), degpth(jfeff),
     $            par(idpath, jps02), par(idpath, jpe0),
     $            refpth(jfeff) + par(idpath, jpdelr),
     $            par(idpath, jpdelr), par(idpath, jpsig2)
          end if
 3500  continue
c
c   e_imag, third and fourth cumulants, phase shift
       write(ilog,9902)
       outstr = 'path      ei        third      fourth'
       if (dphflg) call append(outstr,'     dphase',im)
       ilo = istrln(outstr)
       write(ilog,9003) outstr(1:ilo)
c
       do 3600 idpath = 1, mdpths
          inpath = jdtpth(idpath,id)
          if (inpath.gt.0) then
             jfeff  = jpthff(inpath)
             if (.not.dphflg) then
                write (ilog,9253) jdtusr(idpath, id),
     $               par(idpath, jpei ), par(idpath, jp3rd),
     $               par(idpath, jp4th)
             else
                write (ilog,9254) jdtusr(idpath, id),
     $               par(idpath, jpei ), par(idpath, jp3rd),
     $               par(idpath, jp4th), par(idpath, jpdpha)
             end if
          end if
 3600  continue
c
c  continue to next data set
c
       id = id + 1
       if (id.le.ndata) go to 500
c   finished
       write(ilog,9902)
       close(unit=ilog)
       return
c
c     formats
 9002  format(2x,a)
 9003  format(3x,a)
 9005  format(5x,a)
 9007  format(7x,a)
 9015  format(5x, a, f6.3, 1x, a, i3)
 9020  format(5x,2(a,f10.5),a)
 9030  format(5x,a,f10.5)
 9035  format(5x,a,f14.6)
 9036  format(5x,a,e14.6)
 9055  format(5x,a,2x,i5)
 9060  format(5x,a,f11.3)
 9070  format(7x,2a,3(2x,f14.6))
 9080  format(7x,2a,2x,f14.6)
 9100  format(2x,i5,3x,a)
 9105  format(2x,i5,3x,a,1x,',',1x,i5)
 9150  format(4x,i3,3x,f6.2,3x,f7.4,2x,f9.5,3x,f8.4,2x,f9.5,3x,f10.6)
 9253  format(4x,i5,3(1x,f10.6))
 9254  format(4x,i5,4(1x,f10.6))
 9255  format(4x,i5,5(1x,f10.6))
 9256  format(4x,i5,6(1x,f10.6))
 9310  format(2x,a,' = ',f14.6)
 9320  format(2x,a,' = ',e14.6)
 9450  format(a,': r=',f6.3,'; n=',f6.2,'; nlegs=',i3)
 9455  format(a,' ,',i5,': r=',f6.3,'; n=',f6.2,'; nlegs=',i3)
 9903  format(3x,'>> ',a,' <<')
 9910  format(3x,'>> ',a,f9.4,' <<')
 9902  format(2x,70('-'))
 9904  format(2x,70('='))
c
c end subroutine fitlog
       end
       subroutine fitprm
c
c      compute uncertainties in all values described by an
c      encoded math expression, held in integer code icdval,
c      as generated by encod and ordered by fixicd.
c
c     copyright 1995 university of washington         matt newville
c--------------------------------------------------------------------
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c
       integer i, j, k, idp, iex, ierr, ilen, istrln
       integer nstart, id, idpath, inpath, jfeff
       character outstr*128, fil*128, stat*10
       real     tiny, scale, oldval, two, decod, eval
       real     dvdx(maxval,mvarys),   dpdx(mpthpr,mvarys)
       real     par(mpthpr), dpar(mpthpr), rfave
       real     redchi, sum, dx, pold, thous, xnu
       parameter (tiny = 1.0e-10, two = 2.)
       parameter (thous = 0.001)
       external  eval, istrln, decod
       data fil, stat, idp /  'feffit.prm',  'unknown', 0/
c
       redchi =  chisqr
       xnu    = xnidp - numvar
       if (xnu.gt.0)     redchi =  chisqr / xnu
       scale = sqrt(abs(redchi))
       call openfl(idp, fil, stat, iex, ierr)
       if (ierr.lt.0) call finmsg(1001,fil,' ',0)
       do 10 i = 1, nmathx
          delval(i) = zero
 10    continue
c
c  write preliminary message
       ilen   = max(1, istrln(versn))
       write(idp,9005) versn(1:ilen)
       write(idp,9002) '==================================='//
     $            '==================================='
c  list input data sets, titles for each
c  also, compute average r-factor
       if (ndata.eq.0) then
          write(idp,9003) 'no input data files.'
       else
          if (ndata.eq.1) then
             write(idp,9003) 'input data file:'
          else
             write(idp,9003) 'input data files:'
          endif
          rfave  = zero
          do 30 n = 1, ndata
             rfave = rfave + rfactr(n)
             if (ndata.gt.1)  write(idp,9009) '-> data set ',n
             if (datain(n)) then
                ilen = max(1, istrln(chifil(n)))
                outstr = 'input data chi file = '
     $               //chifil(n)(:ilen)//', skey = '//skey(n)
             else
                outstr = ' no input data file given'
             endif
             ilen = istrln(outstr)
             write(idp,9005) outstr(1:ilen)
c##<bkg
             if (bkgdat(n)) then
                ilen = max(1, istrln(bkgfil(n)))
                outstr = 'used bkg(k) from file = '
     $               //bkgfil(n)(:ilen)//', skey = '//skeyb(n)
                ilen = istrln(outstr)
                write(idp,9005) outstr(1:ilen)
             end if
             if (bkgfit(n)) then
                write(idp,9005) '  fitted background spline to data'
                write(idp,9905) '  with rbkg = ', rbkg(n),
     $               '  and n_knots = ',nbkg(n)
             end if
c##bkg>
 30       continue
          rfave = rfave / ndata
       end if
c then write down goodness of fit statistics
       if (ndata.gt.1)
     $      write(idp,9055) 'number of data sets           = ',ndata
       write(idp,9060) 'independent points in data    = ',xnidp
       write(idp,9055) 'number of variables in fit    = ',numvar
       write(idp,9060) 'degrees of freedom in fit     = ',xnidp -numvar
       write(idp,9035) 'r-factor of fit               = ',rfave
       if (chisqr.lt. 999 999) then
          write(idp,9035) 'chi-square                    = ',chisqr
       else
          write(idp,9036) 'chi-square                    = ',chisqr
       end if
       redchi =  chisqr
       if (xnu.gt.0) then
          redchi =  chisqr / xnu
          if (redchi.lt. 999 999) then
           write(idp,9035) 'reduced chi-square            = ',redchi
          else
           write(idp,9036) 'reduced chi-square            = ',redchi
          end if
       elseif (xnu.eq.0) then
          write(idp,9005) 'questionable fit: all independent ',
     $         'points were used in fit!'
       else
          write(idp,9005) 'invalid fit: more variables than',
     $         ' independent points !'
       end if
       write(idp,9003) ' '


c first, do best-fit and uncertainties in variables.
c pretty simple, but don't forget to rescale by redchi!
       if (numvar.le.0) write(idp,9003) '------ No Variables '

       write(idp,9002) '  uncertainties in variables and "set" values:'
       if (numvar.ge.1) then
          write(idp,9002)  '---- variables: '
          do 50 i = 1, numvar
             values(i) = xfinal(i)
             delval(i) = scale * delta(i)
             call wrtprm(idp, 0, 20, vnames(i), 0, values(i), delval(i))
 50       continue
       end if
c
c second, do the obvious constants, which have dval = zero.
       if (nconst.ge.1) then
          write(idp,9002)  '---- some obvious constants: '
          do 80 i = numvar+1, nconst+numvar
             delval(i)   = zero
             oldval    = values(i)
             values(i) = decod(icdval(1,i),micode,consts,values,oldval)
             call wrtprm(idp, 0, 20, vnames(i), 0, values(i), delval(i))
 80       continue
       end if
       nstart = nconst + numvar + 1
c
cc       print*, '##fitprm:  2'
c--------------------------------------------------------------
c here's the tricky part:
c     for the rest, we have to calculate derivatives of the
c     values with respect to the previous values.
c     this is done for each data set, with path = path 1
c     then we calculate the uncertainties in the path
c     parameters themselves.
       id        = 1
       idpath    = 1
       inpath    = jdtpth(idpath,id)
       if (inpath.le.0) go to 1000
       jfeff     = jpthff(inpath)
       ixpath    = jfeff
       if (jfeff.le.0) go to 1000
       consts(4) = refpth(jfeff)
       consts(5) = degpth(jfeff)
       if (numvar.ge.1) then
          do 200 j = 1, numvar
             dx        = max( tiny , delval(j) )
             values(j) = xfinal(j) - dx / two
             call setval(nstart,nmathx,icdval,maxval,micode,consts,
     $            mconst,values,icdloc,mlocal,mdata,ixlocl,id)
             values(j) = xfinal(j) + dx /two
             do 160 i = nstart, nmathx
                oldval    = values(i)
                values(i) = eval(icdval, maxval, micode, consts,
     $               mconst, values, oldval, icdloc,
     $               mlocal, mdata,  ixlocl,  id, i )
                dvdx(i,j) = (values(i) - oldval ) / dx
 160         continue
             values(j) = xfinal(j)
             call setval(nstart,nmathx,icdval,maxval,micode,consts,
     $            mconst,values,icdloc,mlocal,mdata,ixlocl,id)
 200      continue
       end if
c    now collect sum of squares of derivatives
c    to give delval of the set values.
       do 500 i = nstart, nmathx
          sum = zero
          if (numvar.ge.1) then
             do 480 j = 1, numvar
                sum = sum + (delval(j) * dvdx(i,j))**2
                if (j.lt.numvar) then
                   do 460 k = j+1, numvar
                      sum = sum + two  * delval(j)  * delval(k)
     $                     * dvdx(i,j) * dvdx(i,k)  * correl(j,k)
 460               continue
                end if
 480         continue
          end if
          delval(i) = sqrt( abs ( sum ) )
 500   continue
c
c write 'em out
       write(idp,9002)  '---- more complicated set values: '
       do 900 i = nstart, nmathx
          call wrtprm(idp, 0, 20, vnames(i), 0, values(i), delval(i))
 900   continue
c
c now the path parameters
 1000  continue
       do 5000 id = 1, ndata
          if (ndata.gt.1)  write(idp,9009) ' ---------- data set ',id
          do 4000 idpath = 1, mdpths
             inpath    = jdtpth(idpath,id)
             if (inpath.eq.0)    go to 3990
             juser     =  jdtusr(idpath,id)
             write(idp,9009) '--- path: ', juser
             jfeff     = jpthff(inpath)
             if (jfeff.eq.0)     go to 3990
             reff      = refpth(jfeff)
             if (reff.le.thous)  go to 3990
             degen     = degpth(jfeff)
             ixpath    = jfeff
             consts(4) = reff
             consts(5) = degen
             if (numvar.ge.1) then
                do 1500 j = 1, numvar
                   dx        = max( tiny , delval(j) )
                   values(j) = xfinal(j) - dx / two
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                   do 1250 i = 1, mpthpr
                      par(i) = decod(icdpar(1, i, inpath), micode,
     $                     consts, values, defalt(i))
 1250              continue
                   values(j) = xfinal(j) + dx /two
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                   do 1350 i = 1, mpthpr
                      pold   = par(i)
                      par(i) = decod(icdpar(1, i, inpath), micode,
     $                     consts, values, defalt(i))
                      dpdx(i,j) = (par(i) - pold ) / dx
 1350              continue
                   values(j) = xfinal(j)
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                   do 1450 i = 1, mpthpr
                      par(i) = decod(icdpar(1, i, inpath), micode,
     $                     consts, values, defalt(i))
 1450              continue
 1500           continue
             else
                   call setval(nstart,nmathx,icdval,maxval,micode,
     $        consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
                do 1800 i = 1, mpthpr
                   par(i) = decod(icdpar(1, i, inpath), micode,
     $                  consts, values, defalt(i))
 1800           continue
             end if
c    now collect sum of squares of derivatives
c    to give delval of the path parameters
             do 2500 i = 1, mpthpr
                sum = zero
                if ((numvar.ge.1).and.(icdpar(1,1,inpath).ne.0)) then
                   do 2400 j = 1, numvar
                      sum = sum + (delval(j) * dpdx(i,j))**2
                      if (j.lt.numvar) then
                         do 2300 k = j+1, numvar
                            sum = sum + two * delval(j) * delval(k)
     $                          * dpdx(i,j) * dpdx(i,k) * correl(j,k)
 2300                    continue
                      end if
 2400              continue
                end if
                dpar(i) = sqrt( abs ( sum ) )
 2500        continue
c print out
             do 3000 i = 1, mpthpr
                if (icdpar(1, i, inpath).ne.0) then
                   call wrtprm(idp,1,10,parnam(i),juser,par(i),dpar(i))
                end if
 3000        continue
 3990        continue
 4000     continue
 5000  continue
 8000  continue
       close(idp)

 9002  format(1x,'%', a)
 9003  format(1x,'% ', a)
 9005  format(1x,'%   ', a)
 9009  format(1x,'% ',a,i5)

 9035  format(5x,a,f14.6)
 9036  format(5x,a,e14.6)
 9055  format(5x,a,2x,i5)
 9060  format(5x,a,f11.3)

 9905  format(1x,'%   ', a,f6.3,1x,a,i3)
       return
c     end routine fitprm
       end

      subroutine wrtprm(iout, ifmt, mlen, name, i1, x1, x2)
c simple dump of named parameters to (unit=iout) with choice of formats
c     ifmt=0  ->   " name  =   x1  % +/- % x2 "
c     ifmt=1  ->   " name  i1  x1  % +/- % x2 "
      character name*(*)
      real  x1, x2, ten, order, tiny
      parameter (ten = 10.,  tiny = 1.e-8)
      integer   ilen, istrln, iout, ifmt, mlen, i1
      external  istrln
      ilen    = max(mlen,  istrln(name))
      order   = abs(log(tiny + abs(x1) ) )
      if ((order.gt.ten).and.(ifmt.eq.0)) then
         write(iout,250) name(1:ilen),    x1, x2
      elseif ((order.gt.ten).and.(ifmt.eq.1)) then
         write(iout,200) name(1:ilen),i1, x1, x2
      elseif ((order.le.ten).and.(ifmt.eq.0)) then
         write(iout,150) name(1:ilen),    x1, x2
      elseif ((order.le.ten).and.(ifmt.eq.1)) then
         write(iout,100) name(1:ilen),i1, x1, x2
      end if
 100  format(3x,a,' ',i4,' ',f14.7,'  % +/- %', f14.7)
 150  format(3x,a,' = ',     f14.7,'  % +/- %', f14.7)
 200  format(3x,a,' ',i4,' ',e14.5,'  % +/- %', e14.5)
 250  format(3x,a,' = ',     e14.5,'  % +/- %', e14.5)
      return
      end
       subroutine fitout
c
c   chi(k), chi(r), and chi(q) for data, theory, correction to
c   background and the contribution to the total theory from
c   each path, and written out. most of the code here is for
c   writing documents.
c
c      copyright 1993 university of washington         matt newville
c----------------------------------------------------------------------
c        include 'fitcom.h'
c{fitcom.h
c  common blocks for feffit
c        include 'const.h'
c{const.h: constants & parameters for feffit -*-fortran-*-
       integer   maxpts, mpaths, mdpths
       integer   mvarys, maxval, mconst, micode, mpthpr, mffttl
       integer   maxdoc, mtitle, mdata, mlocal
c  mdata, mvarys greatly affect program size and could be
c  reduced for smaller machines.  (mdata = 5, mvarys = 20)
       parameter(mdata  =   16) ! number of data sets
       parameter(mvarys =  128) ! number of variables
       parameter(mdpths =  512) ! number of paths per data set
       parameter(mpaths = 1024) ! number of total paths in all paths
c                           note: (mpaths < mdata * mdpths) _is_ allowed
       parameter(maxpts = 2048) 
       parameter(mconst = 2048)
       parameter(maxval = 2048)
c for feff.dat files
       integer  mffpts,  mfffil, maxleg
       parameter(mffpts = 128,  mfffil = 256, maxleg =  7)
c parameters are less important for program size
       parameter(maxdoc =  20, mtitle =   10, mffttl =   10)
       parameter(mlocal =  16, micode =   64, mpthpr =   10)
c real parameters:
       real      etok, zero, one, qgrid, pi
       parameter(zero=0.,one=1., qgrid =0.05000000)
       parameter(etok =0.2624682917, pi = 3.141592653589793)
c special indices for path parameters:
c jpnull = no path param; jppath , jplabl for "path" & "label"
c rest are the numerical path params, ranging from 1 to mpthpr
       integer  jpnull, jppath, jplabl, jps02,  jpe0, jpei, jpdpha
       integer  jpdelr, jpsig2,  jp3rd, jp4th
       parameter(jpnull =-10, jppath = -2, jplabl =-1)
       parameter(jps02  =  1, jpe0   =  2, jpei   = 3, jpdpha = 4)
       parameter(jpdelr =  5, jpsig2 =  6, jp3rd  = 7, jp4th  = 8)
c const.h}



c        include 'fefdat.h'
c{fefdat.h
c feff.dat information for each path
       integer iptpth(0:maxleg, mfffil), iffrec(mfffil)
       integer nlgpth(mfffil), izpth(0:maxleg, mfffil), ixpath
       real    degpth(mfffil), refpth(mfffil), qfeff(mffpts, mfffil)
       real    theamp(mffpts, mfffil), thepha(mffpts, mfffil)
       real    realp( mffpts, mfffil), xlamb( mffpts, mfffil)
       real    rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil)
       common /fefdat/ ixpath, nlgpth, izpth, iptpth, iffrec, rwgpth,
     $      degpth, refpth, ratpth, theamp, thepha, qfeff, realp, xlamb
c fefdat.h}
c        include 'chars.h'
c{chars.h: character strings for feffit
       character*128  outfil(mdata), chifil(mdata), bkgfil(mdata)
       character*128  titles(mtitle, mdata), fefttl(mffttl, mfffil)
       character*128  feffil(mfffil), pthlab(mpaths), messg
       character*100 doc(maxdoc, mdata), inpfil, versn
       character*16  parnam(mpthpr), frminp, frmout, asccmt*2
       character*10  skey(mdata), skeyb(mdata), vnames(maxval)*64
       common /chars/ frminp, frmout, skey, doc, outfil, chifil,
     $      titles, pthlab, feffil, fefttl, vnames, versn,
     $      messg, parnam, bkgfil, skeyb, asccmt, inpfil
c chars.h}
c        include 'math.h'
c{math.h:  numbers and integer codes for math expressions in feffit
       real     defalt(mpthpr), consts(mconst)
       real     values(maxval), delval(maxval)
       integer  icdpar(micode,mpthpr,mpaths)
       integer  icdval(micode, maxval), jpthff(mpaths)
       integer  icdloc(micode, mlocal, mdata), ixlocl
       parameter(ixlocl = 16384)
       integer  jdtpth(0:mdpths,mdata), jdtusr(0:mdpths,mdata)
       common /mthval/ defalt, consts, values, delval, icdpar,
     $                 icdval, icdloc, jdtpth, jdtusr, jpthff
c math.h}
c        include 'varys.h'
c{varys.h
c  values for variables of fit and error analysis in feffit
c (nmathx = number of user defined math expressions)
       real     xguess(mvarys), xfinal(mvarys), delta(mvarys)
       real     correl(mvarys, mvarys), chisqr, usrtol
       integer  ifxvar, numvar, nvuser, nmathx, nconst
       integer  ierbar, nerstp
       common /varys/ xguess, xfinal,  delta, correl, chisqr,
     $                usrtol, numvar, nvuser, ifxvar,
     $                ierbar, nerstp, nmathx, nconst
c varys.h}
c        include 'fft.h'
c{fft.h: parameters for fourier transforms in feffit
       real     wfftc(4*maxpts + 15), qwin1(mdata), qwin2(mdata)
       real     rwin1(mdata), rwin2(mdata), rweigh(mdata)
       real     qweigh(mdata), qmin(mdata), qmax(mdata)
       real     rmin(mdata), rmax(mdata)
       integer  nqfit(mdata), nqpts(mdata), nrpts(mdata)
       integer  iqwin(mdata), irwin(mdata), ifft(mdata)
       integer  jffphs(mdata), mftfit, mftwrt
       common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh,
     $              nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh,
     $              nqfit, mftfit, mftwrt, ifft, jffphs, wfftc
c fft.h}
c        include 'data.h'
c{data.h
c  data and fitting numbers in feffit
       real chiq(maxpts,mdata),thiq(maxpts,mdata),thiqr(maxpts,mdata)
       real qwindo(maxpts,mdata), rwindo(maxpts,mdata)
       real q1st(mdata), qlast(mdata), chifit(maxpts, mdata), xnidp
       real sigdtr(mdata),sigdtk(mdata),sigdtq(mdata), xinfo(mdata)
       real sigwgt(mdata),weight(mdata),chi2dt(mdata),rfactr(mdata)
       integer  ndoc(mdata), nkey(mdata), nchi(mdata), ndata
       integer  inform, nkeyb(mdata)
       common /data/  q1st, qlast, thiq, thiqr, chiq, chifit,
     $      qwindo, rwindo, sigdtr, sigdtk, sigdtq, sigwgt,
     $      weight, chi2dt, rfactr, xinfo,
     $      xnidp, ndoc, nkey, nchi, ndata, inform, nkeyb
c data.h}
c        include 'bkg.h'
c{bkg.h
c   background removal parameters in feffit...
       integer   mtknot, korder, nbkg(mdata)
       parameter (mtknot = 30, korder = 4 )
       logical  bkgfit(mdata), bkgout, bkgdat(mdata)
       real  qknot(mtknot,mdata), rbkg(mdata), bkgq(maxpts,mdata)
       common /bkgrnd/ bkgfit, bkgdat, bkgout, nbkg, qknot,
     $                 rbkg, bkgq
c bkg.h}
c        include 'inout.h'
c{inout.h
c  miscellaneous input/output stuff in feffit
       real    rlast, cormin, tranq,rwght1, rwght2
       integer iprint, mdocxx
       logical allout, kspcmp, kspout, rspout, qspout, degflg
       logical datain(mdata), rm2flg, dphflg
       logical noout, nofit, final, vaxflg, dosflg, macflg
       logical pcout, pcfit, prmout, chkdat
       common /inout/ rlast,cormin,tranq,rwght1,rwght2,iprint,mdocxx,
     $      final,allout, kspcmp,kspout,rspout,qspout,
     $      degflg, prmout, pcout, pcfit, chkdat,
     $      datain, noout, nofit,vaxflg,dosflg,macflg,rm2flg,dphflg
c inout.h}
c fitcom.h}
c---------------------------------------------------------------------
       integer   lenfvc, istrln,  juser, j,labl, ntitle
       integer   jofl, ipre, ilen, ixs, iexist, im, iend, mftsav, jdd
       integer   i, mfit, id, ibscf, jtmp, idoc, j0, nqdata
       integer   jfeff, jtitle, ix, inpath, idpath, ititle
       real      reff, degen, rsmall, rgrid
       parameter(lenfvc = mdata*maxpts)
       character*128 outksp, outrsp, outenv, outpre
       character*10  skyk, skyr, skyq, sdelim
       character*100 outdoc(maxdoc)
       real        xbest(mvarys), temp(lenfvc)
       real        par(mpthpr),  qhi, decod, bvalue
       integer     imxpre
       external   istrln, bvalue, decod
       data        qhi, j0  / 20.0,  0/
       data  sdelim / ',})/]\\' /
c imxpre is one less than longest file name prefix
       imxpre  = 64
       if (vaxflg)  imxpre = 28
       if (dosflg)  imxpre =  7
       do 10 i = 1, maxdoc
          outdoc(i) = ' '
 10    continue
c
c  reset number of fft points, so that fft uses mftwrt points,
c  giving a fine rgrid for output.  mftfit, which used in fitfun,
c  must be temporarily overwritten.  usually mftwrt.ge.mftfit.
c  the default for mftwrt is maxpts.
c  notes : - wfftc needs to be re-initialized with cffti
c          - mftfit must be reset after calling fitfun.
c          - wfftc will need to be re-initialized with ccffti
c               in any other routine which follows this one.
       mftsav = mftfit
       if (mftfit.ne.mftwrt)  call cffti(mftwrt, wfftc)
       mftfit  = mftwrt
       mftwrt  = maxpts
c
       rgrid   = pi / (qgrid * mftfit)
       rsmall  = rgrid / 100
       mfit    = 0

       do 50 id = 1, ndata
          nrpts(id) = int( (rmax(id) - rmin(id) + rsmall) /rgrid) + 1
          mfit      = mfit + 2 * nrpts(id)
  50   continue
       mfit = min(mfit, lenfvc)
c  call fitfun to evaluate final version of best fit
       ifxvar  = 0
       do 70 i = 1, numvar
          xbest(i) = xfinal(i)
 70    continue
       call fitfun(mfit, numvar, xbest, temp, iend)
       mftfit  = mftsav
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c  for each data set:
c       write out the data in k, r, and q space
c       write out the full model in k, r, and q space
c       write out the background in k, r, and q space
c       write out each path contribution in k, r, and q space
c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
       id = 1
 100   continue
c   construct output file names
         ilen = min(imxpre, max(1, istrln(outfil(id))))
c     find the last occurance of '.' that is *after* any
c     subdirectory delimeter (stored in sdelim)
         ipre = ilen
 122     continue
            ipre  = ipre - 1
            if (ipre.le.0) go to 124
            if (index(sdelim, outfil(id)(ipre:ipre)).ne.0)  then
               ipre = ilen + 1
               go to 124
            end if
            if (outfil(id)(ipre:ipre).ne.'.')  go to 122
 124     continue
         ipre = ipre - 1
         if (ipre.le.0) ipre  = ilen
c
         if (frmout.eq.' ') frmout = frminp
         if (frmout.eq.' ') frmout = 'ascii'
         outpre = outfil(id)(1:ipre)
         call smcase(frmout, 'a')
         if (frmout(1:2).eq.'uw') then
            outksp = outpre(1:ipre)//'.chi'
            outrsp = outpre(1:ipre)//'.rsp'
            outenv = outpre(1:ipre)//'.env'
         else
            outksp = outpre(1:ipre)//'k.xxx'
            outrsp = outpre(1:ipre)//'r.xxx'
            outenv = outpre(1:ipre)//'q.xxx'
         end if
         jofl = max(1, istrln(outksp))
c   write a message
         if ((.not.kspout).and.(.not.rspout)
     $                    .and.(.not.qspout)) then
            messg = 'no output files written ! '
            im    =  max(1, istrln(messg))
            go to 8000
         else
            messg = '          '
            im    = 10
            if (kspout) call append(messg,' '//outksp(:jofl)//' ',im)
            if (rspout) call append(messg,' '//outrsp(:jofl)//' ',im)
            if (qspout) call append(messg,' '//outenv(:jofl)//' ',im)
         end if
         call messag('      '//messg(:im))
c
c construct rwindo for output fft
         call window(maxpts, irwin(id), rwin1(id),
     $        rwin2(id), rmin(id), rmax(id), rgrid, rwindo(1,id) )
c
c  output for data chi
         iexist = 1
         if (datain(id)) then
            if (frmout(1:2).ne.'uw') then
               outksp = outpre(1:ipre)//'k.dat'
               outrsp = outpre(1:ipre)//'r.dat'
               outenv = outpre(1:ipre)//'q.dat'
            end if
            qlast(id) = min(qhi, qlast(id))
            skyk = ' '
            skyr = ' '
            skyq = ' '
            call xfsout(chiq(1,id),thiqr(1,id),frmout,vaxflg,
     $           outksp,outrsp,outenv,.false.,kspout,rspout,qspout,
     $           iexist,skyk,skyr,skyq,asccmt,mdocxx,
     $           qwindo(1,id),qweigh(id),rwindo(1,id),rweigh(id),
     $           wfftc,mftwrt,rlast,q1st(id),qlast(id),
     $           pcout, qfeff(1,jffphs(id)),thepha(1,jffphs(id)), 
     $           mffpts,qgrid,ndoc(id),doc(1,id))
c     write a message
            if ((skyk.eq.' ').and.(skyr.eq.' ')
     $                       .and.(skyq.eq.' ')) then
               messg = 'data not written to output files'
            else
               messg = 'data written to'
               if (skyk.ne.' ') call append(messg,' chi(k) ',im)
               if (skyr.ne.' ') call append(messg,' chi(r) ',im)
               if (skyq.ne.' ')
     $              call append(messg,' filtered chi(k)',im)
            end if
         else
            messg = 'no data to write to output files'
         end if
         im = max(1, istrln(messg))
         call messag('           '// messg(:im))
c------------------------------------------------------------------
c  output for full theory chi
c
c  output documents
         call triml(titles(1,id))
         outdoc(1) = 'feffit result: '//titles(1,id)
         if (iqwin(id).eq.1) then
            write(outdoc(2),9220) qmin(id), qmax(id),
     $           qweigh(id), qwin1(id)
         elseif (iqwin(id).eq.0) then
            write(outdoc(2),9260) qmin(id), qmax(id),
     $                            qweigh(id), qwin1(id), qwin2(id)
         else
            write(outdoc(2),9280) qmin(id), qmax(id), qweigh(id),
     $                            qwin1(id), qwin2(id), iqwin(id)
         end if
         write(outdoc(3),9301) rmin(id), rmax(id), xinfo(id)
         if (datain(id)) then
             ixs = max(1, istrln(skey(id)))
             ix  = min(52-ixs, max(1, istrln(chifil(id))))
             write(outdoc(4),9360) skey(id)(1:ixs),chifil(id)(1:ix)
         else
             write(outdoc(4),9380)
         end if
c  jtitle gives the index for the next doc line to fill
         jtitle = 5
         do 220 ititle = 1, mtitle
            jlen = min(100, istrln( titles(ititle,id)))
            if (jlen.gt.0) then
               outdoc(jtitle) = '{ '//titles(ititle,id)(1:jlen)
               jtitle = jtitle + 1
            end if
 220     continue
c  get the rest documents from the first feffnnnn.dat used.
         idoc  = jtitle
         do 280 idpath = 1, mdpths
            inpath = jdtpth(idpath,id)
            if (inpath.gt.0) then
               jfeff = jpthff(inpath)
               jtmp  = 1
 240           continue
               if ( (idoc.le.maxdoc) .and. (jtmp.le.mffttl)) then
                  outdoc(idoc) = fefttl(jtmp, jfeff)
                  idoc = idoc + 1
                  jtmp = jtmp + 1
                  go to 240
               end if
               go to 285
            end if
 280     continue
 285     continue
c
c documents complete, so write out data :
         if (frmout(1:2).ne.'uw') then
            outksp = outpre(1:ipre)//'k.fit'
            outrsp = outpre(1:ipre)//'r.fit'
            outenv = outpre(1:ipre)//'q.fit'
         end if
         skyk = ' '
         skyr = ' '
         skyq = ' '
         call xfsout(thiq(1,id),thiqr(1,id),frmout,vaxflg,
     $        outksp,outrsp,outenv,kspcmp,kspout,rspout,qspout,
     $        iexist,skyk,skyr,skyq,asccmt,mdocxx,
     $        qwindo(1,id),qweigh(id),rwindo(1,id),rweigh(id),
     $        wfftc,mftwrt,rlast,q1st(id),qlast(id),
     $        pcout, qfeff(1,jffphs(id)),thepha(1,jffphs(id)), 
     $        mffpts,qgrid,idoc,outdoc)
c     write a message
         if ((skyk.eq.' ').and.(skyr.eq.' ')
     $                    .and.(skyq.eq.' ')) then
            messg = 'full theory not written to output files'
            im    = istrln(messg)
         else
            messg = 'full theory written to'
            if (skyk.ne.' ') call append(messg,' chi(k) ',im)
            if (skyr.ne.' ') call append(messg,' chi(r) ',im)
            if (skyq.ne.' ')
     $           call append(messg,' filtered chi(k)',im)
         end if
         call messag('           '//messg(:im))
c------------------------------------------------------------------
c  outputs for background
         if (bkgout.and.(bkgfit(id).or.bkgdat(id)) ) then
c     ibscf holds place in xvar list of where the spline coefs
c     for the current data set are kept.
            ibscf  = nvuser+1
            if (id.gt.1) then
               do 290 jdd = 2, id
                  ibscf = ibscf + nbkg(jdd-1)
 290           continue
            endif
            nqdata = min(maxpts, max(2, nqfit(id)) + 10)
            if (bkgfit(id)) then
               do 300 i = 1, nqdata
                  thiq(i, id) =  bvalue(qknot(1,id), xfinal(ibscf),
     $                 nbkg(id), korder, qgrid*(i-1),j0)
 300           continue
            else
               do 320 i = 1, nqdata
                  thiq(i, id) = zero
 320           continue
            end if
c     construct documents for background
            write(outdoc(1),9410) rbkg(id), nbkg(id)
c
c documents complete, so write out data :
            if (frmout(1:2).ne.'uw') then
               outksp = outpre(1:ipre)//'k.bkg'
               outrsp = outpre(1:ipre)//'r.bkg'
               outenv = outpre(1:ipre)//'q.bkg'
            end if
            skyk = ' '
            skyr = ' '
            skyq = ' '
            call xfsout(thiq(1,id),thiqr(1,id),frmout,vaxflg,
     $           outksp,outrsp,outenv,.false.,kspout,rspout,qspout,
     $           iexist,skyk,skyr,skyq,asccmt,mdocxx,
     $           qwindo(1,id),qweigh(id),rwindo(1,id),rweigh(id),
     $           wfftc,mftwrt,rlast,q1st(id),qlast(id),
     $           pcout, qfeff(1,jffphs(id)),thepha(1,jffphs(id)), 
     $           mffpts,qgrid,idoc,outdoc)
c     write a message
            if ((skyk.eq.' ').and.(skyr.eq.' ')
     $           .and.(skyq.eq.' ')) then
               messg = 'background not written to output files'
               im = max(1, istrln(messg))
            else
               messg = 'background written to'
               if (skyk.ne.' ') call append(messg,' chi(k) ',im)
               if (skyr.ne.' ') call append(messg,' chi(r) ',im)
               if (skyq.ne.' ')
     $              call append(messg,' filtered chi(k)',im)
            end if
            call messag('           '//messg(:im))
         elseif((.not.bkgout).and.(bkgdat(id).or.bkgfit(id))) then
            messg = 'background not written to output files'
            im = max(1, istrln(messg))
            call messag('           '//messg(:im))
         end if
c------------------------------------------------------------------
c  outputs for individual paths
c  optional outputs
         if (.not.allout)  then
            messg = 'not writing out data for individual paths'
            im = max(1, istrln(messg))
            call messag('           '//messg(:im))
         else
c-- for each path.................
            iexist = 0
            nqdata = min(maxpts, max(2, nqfit(id)) + 10)
            do 1000 idpath = 1, mdpths
               inpath    = jdtpth(idpath,id)
               if (inpath.eq.0)    go to 990
               jfeff     = jpthff(inpath)
               reff      = refpth(jfeff)
               degen     = degpth(jfeff)
               ixpath    = jfeff
               consts(4) = reff
c  evaluate the non-variable values
c   in case they depend on reff, local values to data set, etc
               nstart = nconst + numvar + 1
               call setval(nstart,nmathx,icdval,maxval,micode,
     $            consts,mconst,values,icdloc,mlocal,mdata,ixlocl,id)
c
c     evaluate the path parameters from the values and defaults
c    (these were found in fitfun before this routine was called)
               do 500 i = 1, mpthpr
                  par(i) = decod(icdpar(1, i, inpath), micode,
     $                 consts, values, defalt(i))
 500           continue
c  evaluate chi(k) for this path
               call chipth(theamp(1,jfeff), thepha(1,jfeff), 
     $ qfeff(1,jfeff),xlamb(1, jfeff), realp(1, jfeff), mffpts, 
     $ reff, degen, par(jps02), par(jpe0), par(jpei), par(jpdpha),
     $ par(jpdelr), par(jpsig2),par(jp3rd), par(jp4th), 
     $ tranq, rm2flg, nqdata, maxpts, thiqr(1,id), thiq(1,id))
c
c---- done evaluating theoretical chi for this path
c---  documents
               juser = jdtusr(idpath, id)
               ilen  = min(40, max(1, istrln( feffil(jfeff))))
               call triml(pthlab(inpath))
               labl = min(55, max(1, istrln( pthlab(inpath))))
               if (labl.le.0) then
                  if (iffrec(jfeff).eq.0) then
                     write(outdoc(1),9440) juser,feffil(jfeff)(1:ilen),
     $                    reff, degen, nlgpth(jfeff)
                  else
                     write(outdoc(1),9445) juser,feffil(jfeff)(1:ilen),
     $                iffrec(jfeff), reff, degen, nlgpth(jfeff)
                  end if
               else
                  write(outdoc(1),9460) juser,pthlab(inpath)(1:labl)
               end if
               write(outdoc(3), 9480) par(jpe0),par(jps02),
     $              par(jpdelr),par(jpsig2)
               if (dphflg) then
                  write(outdoc(4), 9540) par(jpei), par(jp3rd),
     $                 par(jp4th), par(jpdpha)
               else
                  write(outdoc(4), 9542) par(jpei), par(jp3rd),
     $                 par(jp4th)
               end if
               if (iffrec(jfeff).eq.0) then
                  write(outdoc(jtitle),9560) feffil(jfeff)(1:ilen)
               else
                  write(outdoc(jtitle),9565) feffil(jfeff)(1:ilen),
     $                 iffrec(jfeff)
               end if
               write(outdoc(jtitle + 1),9580) reff, degen
               ntitle  = jtitle + 2
c   write out path coordinates to titles
               do 600 i = 0, nlgpth(jfeff) - 1
                  j   = ntitle + i
                  if (i.eq.0) then
                     write(outdoc(j),9620) '>', ratpth(1,i,jfeff),
     $                    ratpth(2,i,jfeff), ratpth(3,i,jfeff),
     $                    iptpth(i,jfeff), izpth(i,jfeff)
                  else
                     write(outdoc(j),9640) '>', ratpth(1,i,jfeff),
     $                    ratpth(2,i,jfeff), ratpth(3,i,jfeff),
     $                    iptpth(i,jfeff), izpth(i,jfeff)
                  end if
 600           continue
c   fill in titles with those from feff file
               ntitle  = jtitle + 1 + nlgpth(jfeff)
               idoc    = maxdoc
               do 700 i = 1, mffttl
                  j   = ntitle + i
                  if(j.le.maxdoc)  outdoc(j) = fefttl (i, jfeff )
 700           continue
c     write data output for each path even if it is a repeat
               if (frmout(1:2).ne.'uw') then
                  if (juser.lt.1000) then
                     write(outksp(ipre+3:),740)  juser
                     write(outrsp(ipre+3:),740)  juser
                     write(outenv(ipre+3:),740)  juser
 740                 format (i3.3)
                  end if
               end if
               skyk = ' '
               skyr = ' '
               skyq = ' '
               call xfsout(thiq(1,id),thiqr(1,id),frmout,vaxflg,
     $              outksp,outrsp,outenv,kspcmp,kspout,rspout,qspout,
     $              iexist,skyk,skyr,skyq,asccmt,mdocxx,
     $              qwindo(1,id),qweigh(id),rwindo(1,id),rweigh(id),
     $              wfftc,mftwrt,rlast,q1st(id),qlast(id),
     $              pcout, qfeff(1,jffphs(id)),thepha(1, jffphs(id)), 
     $              mffpts,qgrid,idoc,outdoc)
c     write a message
               if ((skyk.eq.' ').and.(skyr.eq.' ')
     $              .and.(skyq.eq.' ')) then
                  write(messg,9130)'path ',juser,' not written '
               else
                  write(messg,9130)'path ',juser,' written to '
                  if (skyk.ne.' ') call append(messg,' chi(k) ',im)
                  if (skyr.ne.' ') call append(messg,' chi(r) ',im)
                  if (skyq.ne.' ')
     $                 call append(messg,' filtered chi(k)',im)
               end if
               im = max(1, istrln(messg))
               call messag('           '//messg(:im))
 990           continue
 1000       continue
c-------  done looping through all the paths
c  repeat message saying which files were written
            messg = 'wrote files '
            im    = 10
            if (kspout) call append(messg,' '//outksp(:jofl)//' ',im)
            if (rspout) call append(messg,' '//outrsp(:jofl)//' ',im)
            if (qspout) call append(messg,' '//outenv(:jofl)//' ',im)
            call messag('        '//messg(:im))
c-------end
         end if
         id = id + 1
         if (id.le.ndata) go to 100
8000   continue
       return
c
c     formats
 9130  format(a,i5,a)
 9220  format ('k range = [',2f6.2,']; kweight =',f6.2,
     $      '; hanning fraction =',f5.3)
 9260  format ('k range = [',2f6.2,']; kweight =',f6.2,
     $      '; dk1, dk2 =[',2f6.2,']')
 9280  format ('k range = [',2f6.2,']; kw =',f5.2,
     $      '; dk1,dk2 =[',2f6.2,']; iqwin=',i2)
 9300  format ('r range = [',2f6.2,']; ',i3,
     $      ' independent points in data')
 9301  format ('r range = [',2f6.2,']; ',f6.2,
     $      ' independent points in data')
 9360  format ('fit to data: skey "',a,'" in file ', a)
 9380  format ('no data was used. feff files combined without fitting')
 9410  format('feffit background:  rbkg = ',f6.3, ' n_knots = ', i3)
 9440  format('> path',i6,': ',a,'; r=',f6.3,'; n=',f6.2,'; nlegs=',i3)
 9445  format('> path',i6,': ',a,',',i5,'; r=',f6.3,'; n=',f6.2,
     $      '; nlegs=',i3)
 9460  format('> path',i5,': ',a)
 9480  format('path  : e0 =',f8.4,'; amp =',f9.4,'; delr =',
     $      f9.5,'; sigma2 =',f10.6)
 9540  format('params: ei =',f8.4,'; 3rd =',f9.6,';  4th =',f9.6,
     $      '; dphase =',f10.6)
 9542  format('params: ei =',f8.4,'; 3rd =',f9.6,';  4th =',f9.6)
 9560  format('<<< feff data file used: ',a)
 9565  format('<<< feff data file used: ',a,',',i6)
 9580  format('path:   x         y         z   ipot iz ; r_eff =',
     $      f7.4,'; n_degen=',f6.2)
 9620  format(a,1x,f9.5,1x,f9.5,1x,f9.5,2x,i2,2x,i2,8x,'absorbing atom')
 9640  format(a,1x,f9.5,1x,f9.5,1x,f9.5,2x,i2,2x,i2)
c end subroutine fitout
       end
       subroutine xfsout(chiq,chiqr,format,vax,filchi,filrsp,filenv,
     $      cmpchi,chiflg,rspflg,envflg,
     $      iexist,skychi,skyrsp,skyenv,cmt, ndocx,
     $      qwind, qweigh, rwind, rweigh,
     $      wfftc, mfft, rlast, qoutlo, qouthi, pcflg, qfeff, phafef,
     $      mfeff, qgrid, ndoc, doc)
c
c      given chi(k) and a whole lot of input parameters, this will
c      write output files with chi(k), chi(r), and backtransformed
c      chi(k).  for peculiar historical reasons, i will use the
c      convention that env and p refer to the two arrays for
c      backtransformed chi(k), and chi and q to the two arrays
c      for unfiltered chi(k).  the letter k is taken to be ambiguous
c      here (and a fortran integer) so it will be completely avoided.
c
c      copyright 1993 university of washington         matt newville
c
c  inputs:
c    chiq     array of unfiltered chi(k) data, on grid
c               such that chiq(1) = chi(k=0.)
c    filchi   name of output raw-k-space file to write
c    filrsp   name of output r-space file to write
c    filenv   name of output filtered-k-space file to write
c    format   format of output files (uwxafs of ascii)
c    vax      logical flag for writing binary data in vax format
c    chiflg   logical flag for writing raw-k-space data
c    rspflg   logical flag for writing r-space data
c    envflg   logical flag for writing filtered-k-space data
c    ndoc     number of document lines to write out
c    doc      documents to write out
c    qoutlo   lowest value in raw-k-space to write out data
c    qouthi   highest value in raw-k-space to write out data
c    qgrid    k-grid spacing for writing out data and fft
c    qweigh   k-weight to use for fft
c    qwin1    window parameter #1 for  k->r  ft
c    qwin2    window parameter #2 for  k->r  ft
c    wfftc    work array for fft (initialized with cffti using mfft )
c    mfft     number of points to use in fft ( .le.2048 )
c    rlast    highest r value to write out
c    iexist   integer flag for rewriting data to a uwexafs file
c  outputs:
c    skychi   output skey of chi(k) file (raw-k-space)
c    skyrsp   output skey of chi(r) file (r-space)
c    skyenv   output skey of env(p) file (filtered-k-space)
c
c    note mfft must be less than or equal to 2048
c
ccc       implicit none
       integer  maxpts, i, nqout, nqouth, nqoutl, nkyout, nrout,ndocx
       real     qouthi, qoutlo, qsmall, qgrid, rsmall, rgrid, rlast
       integer  nfft, iexist, ndoc,  mfft, mfeff
       real     zero, pi
       parameter (maxpts = 2048, mxmpts=2048)
       parameter (zero = 0,  pi = 3.141592653589793)
       character*128 filchi, filrsp, filenv, cmt*2
       character*100 doc(*)
       character*5   skychi, skyrsp, skyenv, format*10, type*10
       real          chiq(mfft), chiqr(mfft), wfftc(4*mfft+15)
       real          rwind(mfft), qwind(mfft), rweigh, qweigh
       real          xdata(maxpts), yreal(maxpts), yimag(maxpts)
       real          yphas(maxpts), yampl(maxpts)
       real          qfeff(mfeff), phafef(mfeff)
       complex       cchiq(mxmpts), cchir(mxmpts), coni
       parameter  (coni = (0,1))
       logical      vax, chiflg, rspflg, envflg, cmpchi, pcflg
c
c   initialize
       do 20 i = 1, maxpts
          xdata(i) = zero
          yreal(i) = zero
          yimag(i) = zero
          yampl(i) = zero
          yphas(i) = zero
          cchiq(i) = cmplx(zero, zero)
          cchir(i) = cmplx(zero, zero)
 20    continue

c check that mfft .le. maxpts
       nfft = maxpts
       rgrid  = pi / ( nfft * qgrid)
       rsmall = rgrid / 100.0
       qsmall = qgrid / 100.0
       nqoutl   = int( (qoutlo + qsmall) / qgrid )
       if (nqoutl.lt.0) nqoutl = 0
       nqouth   = int( (qouthi + qsmall) / qgrid )
       nqout  = nqouth - nqoutl + 1
       nrout  = int( (rlast + rsmall) / rgrid )
c
c   construct chi(k) on q range [qoutlo, qouthi]
       do 200 i = 1, nqout
          xdata(i) = qoutlo + (i-1)*qgrid
          yreal(i) = chiq(nqoutl + i)
 200   continue
c
c  k - space
       if (chiflg) then
          type   = 'chi'
          if (cmpchi) then
             call smcase(format,'u')
             if (format(1:2).ne.'uw') type   = 'env'
             do 240 i = 1, nqout
                yimag(i) = chiqr(nqoutl + i)
 240         continue
          end if
          nkyout = 0
c   write out chi(q) on q range [qoutlo, qouthi]
cc          print*, 'xfsout: outdat chi: ', filchi(1:20), ':'
          call outdat(type, format, filchi, vax,
     $         cmt, skychi, nkyout, ndoc, ndocx, doc,
     $         nqout, xdata, yreal, yimag, yampl, yphas, iexist)
          do 320 i = 1, nqout + 10
             xdata(i) = zero
             yreal(i) = zero
             yimag(i) = zero
             yampl(i) = zero
             yphas(i) = zero
 320       continue
       end if
c
c  construct chi(r)
c  construct complex chi(k)
c  take fft of complex chi(k) to get cchir
       if (rspflg.or.envflg) then
          if (pcflg) then
             ipos = 1
             do 400 i = 1, nfft
                q = (i-1) * qgrid
                call lintrp(qfeff, phafef, mfeff, q, ipos,  pha)
                cchiq(i) = cmplx(chiq(i), zero) * exp(-coni * pha)
 400         continue
          else
             do 430 i = 1, nfft
                cchiq(i) = cmplx(chiq(i), zero)
 430         continue
          end if
c          do ix = 20, 30
c             print*, nfft, ix, ix*qgrid, qwind(ix), cchiq(ix)
c          end do
          call xafsft(nfft, cchiq, qwind, qgrid, qweigh,
     $         wfftc, 1, cchir)
       end if
c
c write chi(r) on r range [0.,rlast]
       if (rspflg) then
          do 500 i = 1, nrout
             xdata(i) = (i-1)*rgrid
             yreal(i) = real ( cchir(i))
             yimag(i) = aimag( cchir(i))
             yampl(i) = zero
             yphas(i) = zero
 500      continue
          type   = 'rsp'
          nkyout = 0
cc          print*, 'xfsout: outdat rsp: ', filrsp(1:20), ':'
          call outdat(type, format, filrsp, vax,
     $         cmt, skyrsp, nkyout, ndoc, ndocx, doc,
     $         nrout, xdata, yreal, yimag, yampl, yphas, iexist)
       end if
c
c construct env(k) on q range [qoutlo, qouthi]
       if (envflg) then
c  take back-fft of complex chir to get crhiq
          call xafsft(nfft, cchir, rwind, rgrid, rweigh, wfftc,
     $         -1, cchiq)
          do 800 i = 1, nqout
             xdata(i) = qoutlo + (i-1)*qgrid
             yreal(i) = real ( cchiq(i+nqoutl))
             yimag(i) = aimag( cchiq(i+nqoutl))
             yampl(i) = zero
             yphas(i) = zero
 800      continue
          type   = 'env'
          nkyout = 0
cc          print*, 'xfsout: outdat env: ', filenv(1:20), ':'
          call outdat(type, format, filenv, vax,
     $         cmt, skyenv, nkyout, ndoc, ndocx, doc,
     $         nqout, xdata, yreal, yimag, yampl, yphas, iexist)
       end if
       return
c     end subroutine xfsout
       end