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.98 c update 18-sep-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 2.97 05-mar-02 included in ifeffit c 2.98 18-sep-02 fixed bug in fixicd making 'debye(20,20)' look like c a constant so that set parameters and path params c depending on this value were not always updated. c---------------------------------------------------------------------- c include 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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 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.98 18-Sep-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, cphase, sphase, $ realp, xlamb, nlgpth, izpth, iptpth) c check that initial guesses for path parameters are "reasonable" call fitck2 c do non-linear-least-squares fit to determine best-fit values and c uncertainties in fitted parameters call messag(' - finding best-fit values for the variables') 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 subroutine triml (string) c removes leading blanks. character*(*) string, blank*1 parameter (blank = ' ') c-- all blank and null strings are special cases. jlen = istrln(string) if (jlen .eq. 0) return c-- find first non-blank char do 10 i = 1, jlen if (string (i:i) .ne. blank) 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 function istrln(str) c returns index of last non-blank character, c 0 if string is null or blank. character*(*) str, blank*1 parameter (blank = ' ') ilen = len(str) istrln = 0 if ((str(1:1).eq.char(0)) .or. (str.eq.blank)) return do 10 l = ilen, 1, -1 if (str(l:l) .ne. blank) then istrln = l return endif 10 continue return c end function istrln 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 lower (str) c changes a-z to lower case. ascii specific character*(*) str parameter(iupa= 65, iupz= 90, idif= 32) do 10 j = 1, len(str) 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 upper (str) c changes a-z to upper case. ascii specific character*(*) str parameter(iloa= 97, iloz=122, idif= 32) do 10 j = 1, len(str) 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 unblnk (string) c c remove blanks from a string integer i, ilen, j character*(*) string, str*256, blank*1 parameter (blank = ' ') ilen = min(256, max(1, istrln(string))) j = 0 str = blank do 10 i = 1, ilen if (string(i:i).ne.blank) then j = j+1 str(j:j) = string(i:i) end if 10 continue string = blank 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 parameter (itab = 9) character*(*) string, blank parameter (blank = ' ') 10 continue i = index(string, char(itab)) if (i .ne. 0) then string(i:i) = blank go to 10 end if return c end subroutine untab end subroutine uncomm(str) c c purpose: remove comments from a string c c arguments: c str string to modify [in/out] c notes: c 1. '*' is a comment iff it occurs in col 1 c 2. char(10) and char(12) are end-of-line comments c 3. '!', '#', and '%' are end-of-line comments that c can be protected by matching " ", ' ', ( ), [], or {} c c requires: istrln, triml, echo c c copyright 1997 matt newville integer i, istrln, ilen, iprot character*(*) str, copen*5, cclose*5, eol*3, spec*2, s*1 character*1 blank, star parameter(blank = ' ',star = '*') external istrln data copen, cclose, eol / '[{"''(', ']}"'')', '!#%' / c spec(1:2) = char(10)//char(12) call triml(str) ilen = istrln(str) if ((ilen.le.0).or.(str(1:1).eq.star)) then str = blank i = 1 else iprot = 0 do 50 i = 1, ilen s = str(i:i) if (iprot.le.0) then iprot = index(copen,s) elseif (iprot.le.5) then if (s.eq.cclose(iprot:iprot)) iprot = 0 else cc call echo('** uncomm confusion: iprot out of range') return end if c if the string is unprotected, look for end-of-line comment characters if (((iprot.eq.0).and.(index(eol,s).ne.0)).or. $ index(spec,s).ne.0) go to 60 50 continue i = ilen + 1 60 continue end if str = str(1:i-1) c end subroutine uncomm 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 rmdels(s,s1,s2) c c remove general enclosing delimeters from a string character*(*) s, s1, s2, t*512 call triml(s) i = istrln(s) t = s if ((s(1:1).eq.s1) .and. (s(i:i).eq.s2)) s = t(2:i-1) return end c c subroutine rmpars(str) c c remove enclosing parentheses for a string c character*(*) str c call rmdels(str,'(',')') c return c end subroutine rmquot(str) c remove enclosing single or double quotes from a string character*(*) str call rmdels(str,'''','''') call rmdels(str,'"','"') return end subroutine undels(s) c remove an enclosing delimiter from a string character*(*) s, op*5, cl*5 integer j data op, cl / '[{"''(', ']}"'')'/ j = index(op,s(1:1)) if (j.ne.0) then call rmdels(s, op(j:j), cl(j:j) ) end if return 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 logical isnum external isnum ierr = -999 if (isnum(str)) then ierr = 0 write(fmt, 10) min(999,max(2,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 = -998 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 = real(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 first character is c '0', 'f' or 'n' (not case-sensitive) character*(*) str, test*5 parameter (test = 'fnFN0') logical flag integer ierr ierr = 0 flag = index(test,str(1:1)).eq.0 return c end subroutine str2lg end subroutine str2il(str,miar,niar,iar,ierr) c convert a string into an integer _list_, c supporting syntax like '1-2,12,4,6-8' returns c iar = 1,2,4,6,7,8,12 niar = 7 c c returns ierr = -1 if string clearly non-integer character*(*) str , s*128, sint*32 integer miar, niar, iar(miar), ierr, istrln integer i, ibeg logical dash external istrln s = str call triml(s) ilen = istrln(s)+1 s = s(1:ilen-1)//'^' do 20 i = 1, miar iar(i) = 0 20 continue niar = 0 ierr = -1 ix1 = 0 dash = .false. if (ilen.gt.1) then i = 1 ibeg = 1 100 continue i = i + 1 if ((s(i:i).eq.',') .or. (s(i:i).eq.'^')) then sint = s(ibeg:i-1) ibeg = i+1 if (dash) then call str2in(sint,ix,ierr) do 130 j = ix1, ix niar = niar + 1 iar(niar) = j 130 continue else call str2in(sint,ix,ierr) niar = niar + 1 iar(niar) = ix end if dash = .false. elseif (s(i:i).eq.'-') then sint = s(ibeg:i-1) dash = .true. call str2in(sint,ix1,ierr) ibeg = i+1 end if if (s(i:i).ne.'^') go to 100 end if c now remove the zeroth one! niar = niar - 1 c return c end subroutine str2il 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 - if '+' or '-' is seen after a digit, 'deDE' must be seen. 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, isign integer jexp, jsign logical ldig, l_op external istrln c str = string c call triml(str) iexp = 0 jexp = 0 idec = 0 isign = 0 ldig = .false. l_op = .false. isnum = .false. do 100 i = 1, max(1, istrln(string)) j = index(number,string(i:i)) cc print*, 'X ' , i, j, ' : ' , str(i:i) if (j.le.0) go to 200 if (j.ge.10) ldig = .true. if((j.ge.1).and.(j.le.4)) then iexp = iexp + 1 jexp = i endif if (j.eq.5) idec = idec + 1 if ((j.eq.7).or.(j.eq.8)) then isign= isign +1 if ((i .gt. 1) .and. (i .ne. (jexp+1))) then l_op = .true. endif endif 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. if ((iexp.eq.0).and.(isign.gt.1)) isnum = .false. if (jexp.eq.1) isnum = .false. isnum = isnum .and. (.not.l_op) cc print*, 'ISNUM: ', string(1:istrln(string)) cc print*, ' ', isnum, l_op, iexp, idec, isign 200 continue return c end logical function isnum 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.1) then isdat = .true. do 50 i = 1, nwords isdat = isdat .and. isnum(words(i)) 50 continue end if return end subroutine bwords (str, 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. character*(*) str, words(nwords) character blank, comma, equal, s 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) mwords = nwords nwords = 0 call untab (str) call triml (str) ilen = istrln (str) c-- all blank string is special case if (ilen .eq. 0) return c-- ibeg is beginning character of a word ibeg = 1 betw = .true. comfnd = .true. do 10 i = 1, ilen s = str(i:i) if (s .eq. blank) then if (.not. betw) then nwords = nwords + 1 words (nwords) = str (ibeg : i-1) betw = .true. comfnd = .false. endif elseif ((s.eq.comma).or.(s.eq.equal)) then if (.not. betw) then nwords = nwords + 1 words (nwords) = str(ibeg : i-1) betw = .true. elseif (comfnd) then nwords = nwords + 1 words (nwords) = blank endif comfnd = .true. else if (betw) then betw = .false. ibeg = i endif endif if (nwords .ge. mwords) return 10 continue c if (.not. betw .and. nwords .lt. mwords) then nwords = nwords + 1 words (nwords) = str (ibeg :ilen) endif return c end subroutine bwords end subroutine bkeys(str, mkeys, keys, values, nkeys) c c purpose: break a string into {key,value} pairs. c arguments: c str string to break into pairs [in] c mkeys dimension of arrays keys and values [in] c keys character array of keys [out] c values character array of values [out] c nkeys number of keys found [out] c c parsing rules: c 1. a key is a word terminated by whitespace, an equal sign, c a comma, or the final close paren. keys are converted to c lower case before returning. c c 2. a value is a more general string, terminated by either c an "unprotected" comma or the final "unprotected" close paren. c Any part of the string can be "protected" by either matching c single quotes, double quotes, parens, braces, or brackets. c In fact, *all* of these pairs must be matched for the c value to terminate. the values are left in their original case. c c 3. If a key does not have a value (because a comma or the last close c paren gets in the way) the value will be set to '%undef%'. c note that str2lg will interpret this as "true"!, and that it c will never make sense as any other value. c c example: x =13.214, File = B.dat, Verbose, sig = sqrt(A + min(b,c)) c will return these pairs: c key value c x 13.214 c file B.dat c verbose %undef% c sig sqrt(A + min(b,c)) c c routines needed: istrln, triml, lower, rmdels, echo c c copyright (c) 1998 matt newville c integer istrln, i, j, ilen, ibeg integer nkeys, mkeys, nk, jprot character*(*) str, keys(mkeys), values(mkeys), tmp*64 character s, t, u, blank, comma, equal, semicl character copen*3, cclose*3, undef*8 logical lcomma, seek_key, have_key parameter (blank = ' ',comma = ',',equal = '=',semicl = ';') parameter (undef = '%undef%') external istrln data copen, cclose / '[{(', ']})'/ c c initialize nkeys = 0 do 10 i = 1, mkeys keys(i) = blank values(i) = undef 10 continue have_key = .false. seek_key = .true. lcomma = .false. ibeg = 1 iprot = 0 jprot = 0 c c check for valid string to parse ilen = istrln(str) cc print*,'BKEYS:',str(1:ilen),':' if (ilen .eq. 0) return c c loop through string i = 0 100 continue i = i + 1 s = str(i:i) c test for opening/closing delimiters c and march over protected strings if ((s.eq.'''').or.(s.eq.'"')) then t = s cc print*, ' quote: ', t 120 continue i = i + 1 if ((str(i:i).ne.t).and.(i.lt.ilen)) goto 120 else iprot = index(copen,s) if ((iprot.ge.1).and.(iprot.le.3)) then cc print*, ' iprot = ',iprot , s, i jprot= jprot + 1 t = copen(iprot:iprot) u = cclose(iprot:iprot) 130 continue i = i + 1 if (str(i:i).eq.t) jprot = jprot + 1 if (str(i:i).eq.u) jprot = jprot - 1 if ((i.lt.ilen).and.(jprot.ne.0)) goto 130 end if endif lcomma = s.eq.comma c looking for keyword: c we've seen the beginning of a keyword, and now we see the end: c keyword ends at "=",","," ", or the final positon if (seek_key) then if (((s.eq.equal).or.lcomma.or.(i.eq.ilen))) then nkeys = nkeys + 1 if (nkeys .ge. mkeys) go to 150 keys(nkeys) = str(ibeg:i-1) if ((i.eq.ilen).and.(.not.lcomma).and.(s.ne.equal)) $ keys(nkeys) = str(ibeg:i) cc print*, 'found key : ', nkeys, ' ', keys(nkeys)(1:32) ibeg = min(i + 1, ilen) seek_key = .false. have_key = .false. c a bare word counts as a key with value= undefined (as above) if (lcomma .or.(i.eq.ilen) ) then seek_key = .true. call triml(keys(nkeys)) ij = istrln(keys(nkeys)) if (index(keys(nkeys)(1:ij),blank).ne.0) then tmp = keys(nkeys)(1:ij) c c call echo(' syntax error: '//tmp) keys(nkeys) = blank end if end if elseif (.not.have_key) then have_key = s.ne.blank end if c looking for a value: ends at a comma or the final postion else if (lcomma.or.(i.eq.ilen)) then values(nkeys) = str(ibeg:i-1) if ((i.eq.ilen).and.(.not.lcomma)) $ values(nkeys) = str(ibeg:) ibeg = min( i + 1, ilen) seek_key = .true. end if end if if (i.le.ilen) goto 100 150 continue c c finally, we may have ended with a one-letter keyword, in which case c have_key is true if (have_key) then nkeys = nkeys + 1 keys(nkeys) = str(ibeg:) call triml(keys(nkeys)) end if c c now clean up keys and values, eliminate blank and invalid keys nk = nkeys nkeys = 0 do 500 i = 1, nk if (keys(i).ne.blank .and. keys(i).ne.comma .and. $ keys(i).ne.equal .and. keys(i).ne.semicl) then nkeys = nkeys + 1 keys(nkeys) = keys(i) call triml( values(i)) if (values(i)(1:1).eq.equal) then values(i) = values(i)(2:) call triml(values(i) ) end if call rmquot(values(i)) do 470 j = 1, 3 call rmdels(values(i),copen(j:j),cclose(j:j)) 470 continue call triml( values(i)) values(nkeys) = values(i) if (values(nkeys).ne.undef) call lower(keys(nkeys)) call triml(keys(nkeys)) end if lk = istrln(keys(i)) lv = istrln(values(i)) cc print*, i,' |', keys(i)(1:lk),' | ', values(i)(1:lv), '|' 500 continue return c end subroutine bkeys 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 -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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 xnidp = zero inform = 0 ndata = 0 rlast = 10.d0 cormin = 0.25d0 rwght1 = 15.d0 rwght2 = 25.d0 tranq = 2.d0 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 = 0 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 sqwin(i) = 'hanning' srwin(i) = 'hanning' 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 -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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, jinit, ie integer nfil, jl, iuser, idpath, inpath, iffx, iunky parameter(maxwrd = 30, mfil = 10) character*2048 str, string, strdum, stat*10 character*128 words(maxwrd), wrdsor(maxwrd) character*32 wins(8) character keywrd*128, key*3, prompt*20 logical errskp, path0, flag integer itemp, itfeff, ifeff, ititle, idata, iparam integer ilcl, jlcl,icom(mfil), ix external istrln c c initialization itemp = 0 itfeff = 0 ititle = 0 idata = 1 ilcl = 0 ix = 0 wins(1) = 'hanning' wins(2) = 'fhanning' wins(3) = 'gaussian window' wins(4) = 'kaiser-bessel' wins(5) = 'parzen' wins(6) = 'welch' wins(7) = 'sine' 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 str2dp(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 str2dp(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 str2dp(words(2), sigdtk(idata), ierr ) elseif ( (keywrd.eq.'sigr').or.(keywrd.eq.'epsr')) then call str2dp(words(2), sigdtr(idata), ierr ) c-- maximum correlation to report elseif (keywrd.eq.'cormin') then call str2dp(words(2), cormin, ierr ) elseif (keywrd.eq.'rwght1') then call str2dp(words(2), rwght1, ierr ) elseif (keywrd.eq.'rwght2') then call str2dp(words(2), rwght2, ierr ) c-- hack for playing with user tolerance elseif (keywrd.eq.'toler') then call str2dp(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 str2dp(words(2), rlast, ierr ) c keywords for fft stuff c-- number of points in fft for fit ( found from qmin, qmax) c elseif (keywrd.eq.'max_fft_fit') then c call str2in(words(2), mftfit, ierr ) cc-- number of points in fft for writing out data ( 2048) c elseif (keywrd.eq.'max_fft_out') then c call str2in(words(2), mftwrt, ierr ) c-- minimum r for fit range elseif (keywrd.eq.'rmin') then call str2dp(words(2), rmin(idata), ierr ) c-- maximum r for fit range elseif (keywrd.eq.'rmax') then call str2dp(words(2), rmax(idata), ierr ) c-- minimum k for fit range / fourier transform elseif ((keywrd.eq.'kmin').or.(keywrd.eq.'qmin')) then call str2dp(words(2), qmin(idata), ierr ) c-- maximum k for fit range / fourier transform elseif ((keywrd.eq.'kmax').or.(keywrd.eq.'qmax')) then call str2dp(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 str2dp(words(2), qweigh(idata), ierr ) c-- window sill fourier transform window parameter(s) elseif (keywrd(1:4).eq.'win') then sqwin(idata) = words(2) elseif (keywrd(1:4).eq.'iwin') then call str2in(words(2), ix, ierr ) sqwin(idata) = wins(ix+1) srwin(idata) = sqwin(idata) c-- window sill fourier transform window parameter(s) elseif ((keywrd.eq.'iqwin').or.(keywrd.eq.'ikwin')) then call str2in(words(2), ix, ierr ) sqwin(idata) = wins(ix+1) c-- window sill fourier transform window parameter(s) elseif (keywrd.eq.'irwin') then call str2in(words(2), ix, ierr ) srwin(idata) = wins(ix+1) cc-- gaussian fourier window c elseif (keywrd.eq.'gauss') then c call str2dp(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 str2dp(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 str2dp(words(2), qwin2(idata), ierr ) elseif ((keywrd.eq.'dk1').or.(keywrd.eq.'dq1')) then call str2dp(words(2), qwin1(idata), ierr ) elseif ((key.eq.'dk').or.(key.eq.'dq')) then call str2dp(words(2), qwin1(idata), ierr ) qwin2(idata) = qwin1(idata) c-- r-space window parameters elseif (key.eq.'dr2') then call str2dp(words(2), rwin2(idata), ierr ) elseif (key.eq.'dr1') then call str2dp(words(2), rwin1(idata), ierr ) cc elseif (key.eq.'dr') then cc call str2dp(words(2), rwin1(idata), ierr ) cc rwin2(idata) = rwin1(idata) c-- optical transform phase factors c elseif (keywrd.eq.'rpha') then c call str2dp(words(2), rphas(idata), ierr ) c elseif (keywrd.eq.'qpha') then c call str2dp(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 str2dp(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 cc print*, ' INP path ! ', ifeff, feffil(ifeff) 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 cc print*, ' itfeff = ', itfeff, ifeff, inpath 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 cc print*, 'FITINP: ndata = ', ndata 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 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 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 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////////////////////////////////////////////////////////////////////// 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) call triml(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 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 endif if (is.le.31) str(i:i) = blank 20 continue return c end subroutine sclean 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 newfil(file, iofile) c c open a new file to unit iofile c if iofile > 0 , that file is closed c if an old file named file exists, it is deleted! implicit none character*(*) file, str*128 integer iofile, iex, ier logical exist str = file if (iofile.gt.0) then close(iofile) iofile = 0 end if inquire(file=str, exist=exist) if (exist) then call openfl(iofile, str, 'old', iex, ier) close(iofile,status='delete') iofile = 0 end if cc iofile = 3 call openfl(iofile, str, 'unknown', iex, ier) if ((iex.lt.0).or. (ier.ne.0)) iofile = -1 c end subroutine newfil 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 implicit none character*(*) file, status, stat*10 integer iunit, iexist, ierr logical exist, open c c make sure there is a unit number, and that it's pointing to c an unopened logical unit number other than 5 or 6 ierr = -3 iexist = 0 iunit = max(1, iunit) 10 continue inquire (unit=iunit, opened=open) if (open) then iunit = iunit + 1 if ((iunit.eq.5).or.(iunit.eq.6)) iunit = 7 goto 10 endif 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 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 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 implicit none integer nv, ni, nc, ierr, icode(ni) character*(*) string, vnames(nv) double precision consts(nc), pi, one, zero integer maxlen, jconst, ileft, iright, icomma parameter(one = 1.d0, zero = 0.d0, pi = 3.141592653589793d0) 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, maxeol integer ibfr, iaft, ibefr, iaftr, ivarln, istrln integer j, jt, jstack, jcomma, ii, it, i, nbrstr double precision xreal parameter (number = '1234567890 .' , opera = '+-*/^(), ') parameter (mtherr =' math encoding error: ') parameter (synerr =' math encoding error: syntax error') parameter (encerr =' math encoding error: encod error') external istrln, nbrstr 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*, 'ENCOD HERE: ', 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 str2dp(string(istr:isave), 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 cc print*, '4000: encod ', str(1:40) cc print*, ' code: ' cc do i = 1, maxlen, 3 cc if (itemp(i).ne.0) print*,itemp(i),itemp(i+1),itemp(i+2) cc 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 cc print*, ' comma hunt ', i, ieqn, icomma 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. cc print*, 'STACK: ' , j, jt, jstack 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 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 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--------------------------------------------------------------------- implicit none 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-------------------------------------------------------------------- implicit none 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 parameter ( operas = '*/+-') parameter ( digits = '0123456789') external istrln, nbrstr 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-------------------------------------------------------------------- implicit none 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--------------------------------------------------------------------- implicit none 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 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---------------------------------------------------------------------- c common blocks for feffit c include 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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} character*10 ftype, frmtmp, strtmp*128 character*100 docb(maxdoc) double precision qtemp(maxpts), chitmp(maxpts), rrmmax double precision qbtemp(maxpts), bkgtmp(maxpts), qrange double precision tmp1(maxpts), tmp2(maxpts), tmp3(maxpts) double precision drinfo(mdata) , xlog2, percnt, two, rsmall double precision drmin, q, qsmall, xexpo, dr_1k double precision dqmin, xqmax, xqmin integer mftmin, id, ilen, istrln, isky, ist, ndocb integer nexpo, nrmin, nrmax, ntmp, ii, iv, imsg integer nbkgf, ipos, iposb, i, nq1st, nqmin, nqmax parameter(xlog2 = 0.69314718056d0, percnt = 1.d-2, two = 2.d0) parameter(xqmin = 20.d0, xqmax = 35.d0) c----------------------------------------------------------------------- c drmin is used as the spacing in r-space to use in the fit, drmin = pi/( qgrid * mftfit) 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) rsmall = rgrid * 0.01d0 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 cc print*, ' call window' call window(sqwin(id), qwin1(id), $ qwin2(id), qmin(id), qmax(id), qgrid, $ maxpts, qwindo(1,id) ) call window(srwin(id), rwin1(id), $ rwin2(id), rmin(id), rmax(id), rgrid, $ maxpts, rwindo(1,id) ) c 700 continue if (xinfo(1).lt.two) xinfo(1) = two if (xnidp.lt.two) xnidp = two inform = int(xnidp) c xexpo = log ( float (mftfit)) / xlog2 nexpo = min(11, max(8, nint(xexpo)) ) c c make sure rlast is smaller than 10pi = pi/2/qgrid rrmmax = (pi/two) / qgrid if (rlast.gt.rrmmax) rlast = rrmmax call cffti(mftfit, wfftc) cc print*, ' end of fitdat: ' cc print*, mftfit cc print*, ' q/r grid ', qgrid, rgrid 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--------------------------------------------------------------------- implicit none character*(*) filtyp, format, skey, filnam, doc(*) character*10 type, symkey, form, formin, errmsg*128 double precision xdata(*), yreal(*), yimag(*) double precision yampl(*), yphas(*) logical vax integer irecl, ndatmx, ndocmx, ier, ilen, istrln integer ndata, ndoc, nkey external istrln data ndocmx, ndatmx / 19, 4096/ c--------------------------------------------------------------------- c some initializations irecl = 512 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 echo(' inpdat error: file not found ') elseif (ier.eq.-2) then call echo(' inpdat error: unknown file format = '//formin) elseif (ier.eq.-3) then call echo(' inpdat error: poorly formatted ascii data? ') elseif (ier.eq.-4) then call echo(' inpdat error: no data in ascii format file? ') end if if (ier.ne.0) then errmsg = ' for file ' // filnam ilen = istrln(errmsg) call echo( errmsg(1:ilen) ) stop endif if ((formin.ne.' ').and.(formin(1:2).ne.form(1:2))) then call echo(' inpdat warning: the requested format was'// $ ' incorrect!') call echo(' form = '//form(1:5) ) call echo(' 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) ) cc print*, 'inpout: ', form(1:2) 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 echo(' inpdat error: unknown file format = '// form) ilen = min(54, max(1, istrln(filnam))) errmsg = ' for file ' // filnam(1:ilen) call echo( 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--------------------------------------------------------------------- implicit none integer ilen , istrln, j, i, mxword, ndoc, ndata, iounit integer iexist, ierr, nwords, idoc, id double precision zero parameter( zero = 0.d0, mxword = 5) double precision xdata(*), yreal(*), yimag(*) double precision xinp(mxword), yampl(*), yphas(*) logical isdat character*(*) filnam, doc(*) character*32 words(mxword), line*128, status*10, file*128 external istrln, isdat c--------------------------------------------------------------------- 10 format(a) file = filnam ilen = istrln(file) if (ilen.le.0) then call echo( ' 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) 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 call sclean(line) 410 continue call untab(line) call bwords(line,nwords,words) if (nwords.le.1) goto 600 do 450 i = 1, nwords call str2dp(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 print*, ' inpout:' c do i = 1, 4 c print*, xdata(i), yreal(i) c end do c close data file and return close(iounit) return c error handling c open file - error 900 continue call echo(' inpcol: error opening file '//file(1:ilen) ) go to 990 c end or error at reading documents 950 continue 960 continue call echo( ' inpcol: error reading file '//file(1:ilen) ) call echo(' during reading of documents.') go to 990 c error at reading numerical data 980 continue call echo( ' inpcol: error reading file '//file(1:ilen) ) call echo(' 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--------------------------------------------------------------------- implicit none integer maxpts, ilen, i, ndata, iounit, irecl, istrln integer ier, nie, nkey, ndocln, ndoc, ndsent, nbuff, maxdoc double precision zero parameter( maxpts = 2048, zero = 0.d0 , maxdoc=20) character*(*) ftypin, skey, filein, documt(*) character*10 type, ftype, safefl*8, abrtfl*8 character*128 filnam, messg character*100 docbuf(maxdoc) double precision xdata(*), yreal(*), yimag(*) double precision yampl(*), yphas(*) real buffer(maxpts) external istrln 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 echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'openrf error code ',ier call echo(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 echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'gftype error code ',ier call echo(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 echo(messg//filnam(:ilen)) messg = ' file type for this file is ' call echo(messg//type) messg = ' file type requested was ' call echo(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 echo(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 echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'gskey error code ',ier call echo(messg) stop end if if (skey.eq.' ') then write (messg, '(1x,2a,i4)') 'inpuwx: found no skey ', $ 'for nkey =',nkey call echo(messg) call echo(' 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 echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'gnkey error code ',ier call echo(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 echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'gdlen error code ',ier call echo(messg) stop end if if (ndoc.gt.ndocln) ndoc = ndocln c then get the documents call getdoc(iounit, docbuf, ndoc, skey, nkey, ndsent, ier) do 300 i = 1, ndsent documt(i) = docbuf(i) 300 continue if (ier.eq.6) then messg = 'inpuwx error: reading file ' call echo(messg//filnam(:ilen) ) messg = ' no skey or nkey given to specify record, ' call echo(messg) messg = ' or an incorrect skey or nkey given ' call echo(messg) stop elseif (ier.ne.0) then messg = 'inpuwx: error getting documents for ' call echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'getdoc error code ',ier call echo(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 echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'getrec error code ',ier call echo(messg) stop end if c : close file call closrf(iounit,ier) if (ier.ne.0) then messg = 'inpuwx: error closing data file ' call echo(messg//filnam(:ilen)) write (messg, '(9x,a,i4)') 'closrf error code ',ier call echo(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 echo(messg//filnam(:ilen)) messg = ' file type for this file is ' call echo(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--------------------------------------------------------------------- implicit none integer ndoc, ndocx, ndata, iexist, ilen, nkey, idoc character*(*) filtyp, format, filnam, skey, doc(*), comm character*32 type, form double precision xdata(*), yreal(*), yimag(*) double precision 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 echo('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--------------------------------------------------------------------- implicit none integer ndoc, ndocx, ndata, ilen, nkey, idoc, jdoc, i, istrln integer mxl, mxlp1, ixmsg, ierr, iexist, iounit, imsg double precision zero, xdata(*), yreal(*), yimag(*) double precision yampl(*), yphas(*) parameter (zero = 0.d0, mxl = 76) character*(*) filtyp, filnam, doc(*), comm character*80 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)]') external istrln 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 echo(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----------------------------------------------------------------------- implicit none integer maxpts, maxdoc, nkey, irecl, ndoc, iexist, ndata,idoc integer ierr, iounit, ier, i, nbuff, imsg, istrln, ilen double precision zero parameter(maxpts = 2048, maxdoc = 19, zero = 0.d0) character*(*) filein, ftypin, doc(*), skey character*10 skyout, ftype, type, filnam*128, messg*128 character*100 docout(maxdoc), abrtfl*8, safefl*8 double precision xdata(*), yreal(*), yimag(*) double precision 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 echo(messg(:imsg)) write(messg, '(9x,a,i3)' ) 'openrf error code ',ier call echo(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 echo(messg//filnam(:ilen)) messg = ' file type for this file is ' call echo(messg//type) messg = ' file type requested was ' call echo(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 echo('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 c c this holds simple replacements for ifeffit routines c to be used by the 'libxafs' routines c c c included in this file are: c echo echo_init setsca getsca c c IMPORTANT: DO NOT link into libifeffit.a!!! c 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////////////////////////////////////////////////////////////////////// c subroutine echo(str) integer istrln, n external istrln character*(*) str,form*8 parameter (form = '(1x,a)' ) n = max(1, istrln(str)) write(*,form) str(1:n) return end subroutine echo_init implicit none integer i i = 0 return end subroutine setsca(str,x) implicit none character*(*) str double precision x return 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////////////////////////////////////////////////////////////////////// integer function nofx(x,array,npts) c c return index in array with value closest to scalar x. c arguments c x value to find in array c array double precision array (monotonically increasing) c npts number of points in array c implicit none integer npts, imin, imax, inc, it double precision array(npts), x, xit, xave c c hunt by bisection imin = 1 imax = npts inc = ( imax - imin ) / 2 10 continue it = imin + inc xit = array(it) if ( x .lt. xit ) then imax = it else if ( x .gt. xit ) then imin = it else nofx = it return endif inc = ( imax - imin ) / 2 if ( inc .gt. 0 ) go to 10 c x is between imin and imin+1 xave = ( array(imin) + array(imin+1) ) / 2 if ( x .lt. xave ) then nofx = imin else nofx = imin + 1 endif return c end function nofx end integer function nofxsp(x,array,npts) c c return index in array with value closest to scalar x. c arguments c x value to find in array c array single precision array (monotonically increasing) c npts number of points in array c integer npts, imin, imax, inc, it real array(npts), x c c hunt by bisection imin = 1 imax = npts inc = ( imax - imin ) / 2 10 continue it = imin + inc xit = array(it) if ( x .lt. xit ) then imax = it else if ( x .gt. xit ) then imin = it else nofxsp = it return endif inc = ( imax - imin ) / 2 if ( inc .gt. 0 ) go to 10 c bisection xave = ( array(imin) + array(imin+1) ) / 2. if ( x .lt. xave ) then nofxsp = imin else nofxsp = imin + 1 endif return c end function nofxsp end subroutine hunt(xar, npts, xin, jlo) c c return jlo=lower-bound index of a value xin in array xar(n) c such that xar(jlo) <= xin < xar(jlo+1). c arguments: c xar monotonically increasing array [in] c npts length of xar [in] c xin value to hunt for [in] c jlo initial guess / output index [in/out] c implicit none integer npts, jlo, jhi, inc, jm double precision xar(npts), xin logical dohunt c first, decide if we really need to do a hunt at all c or if the initial guess (jlo) was good enough: it often is! cc print*, '-> hunt ', npts, xin,jlo, xar(1), xar(2), xar(3) dohunt = .true. jlo = min(npts-1,max(1,jlo)) if ((xin.gt.xar(jlo)) .and. (xin.lt.xar(jlo+1))) then dohunt = .false. elseif (xin.le.xar(1)) then jlo = 1 dohunt = .false. elseif (xin.ge.xar(npts)) then jlo = npts - 1 dohunt = .false. c c check next interval -- often the right choice if the current cc interval was not. elseif (jlo.le.npts-2) then if ((xin.gt.xar(jlo+1)) .and. (xin.le.xar(jlo+2))) then jlo = jlo + 1 dohunt = .false. end if c end if c hunt the old-fashioned way: if (dohunt) then cc print*, 'hunt: real hunt ', jlo, xin, xar(jlo),xar(jlo+1) cc $ ,xar(jlo+2),xar(jlo+3) if (jlo.le.0.or.jlo.gt.npts) then c the input jlo is not useful -- do bisection jlo = 0 jhi = npts+1 go to 30 endif inc = 1 c look ever further away to bracket value c hunting up from current guess if (xin.ge.xar(jlo)) then 10 continue jhi=jlo+inc if (jhi.gt.npts) then jhi=npts+1 elseif (xin.ge.xar(jhi)) then jlo=jhi inc=inc+inc go to 10 endif else c hunting down from current guess jhi=jlo 20 continue jlo=jhi-inc if (jlo.lt.1) then jlo=0 elseif (xin.lt.xar(jlo)) then jhi=jlo inc=inc+inc go to 20 endif endif c now use bisection to reduce c the bracket interval to 1 30 continue if (jhi.ne.(jlo+1)) then jm = (jhi + jlo) / 2 if (xin.gt.xar(jm)) then jlo=jm else jhi=jm endif go to 30 end if end if jlo = min(npts-1,max(1,jlo)) return c end subroutine hunt end subroutine xterp(xnew, nxnew, y, ny, x, nx, iterp, ierr) c c interpolate yold(xold) to ynew(xnew) using interpolation c scheme defined by iterp c arguments c xnew xnew array on input [in/out] c ynew array on output c y yold array [in] c x xold array [in] c iterp interpolation method c c copyright (c) 1998 matt newville implicit none c include 'maxpts.h' c{maxpts.h -*-fortran-*- integer maxpts, maxsize_array parameter(maxsize_array = 8192) parameter(maxpts = maxsize_array) c} integer nx, ny, nxnew, i, ierr, ip, iterp double precision x(*), y(*), xnew(*) double precision tmp(maxpts), coefs(maxpts) ierr = 0 ip = 1 c ccc print*, ' XTERP: ', iterp ny = min(nx,ny) if (iterp .eq. 0) then do 20 i = 1, nxnew call lintrp(x, y, ny, xnew(i), ip, tmp(i)) 20 continue elseif (iterp .eq. 1) then do 30 i = 1, nxnew call qintrp(x, y, ny, xnew(i), ip, tmp(i)) 30 continue elseif (iterp .eq. 2) then call splcoefs(x, y, ny, coefs, tmp) do 80 i = 1, nxnew call splint(x, y, coefs, ny, xnew(i), ip, tmp(i)) 80 continue end if c do 100 i = 1, nxnew xnew(i) = tmp(i) 100 continue return c end subroutine xterp end subroutine xiterp(x, y, ny, xval, ipos, iterp, yout) c c copyright (c) 1998 matt newville implicit none c include 'maxpts.h' c{maxpts.h -*-fortran-*- integer maxpts, maxsize_array parameter(maxsize_array = 8192) parameter(maxpts = maxsize_array) c} integer nx, ny, m, i, ierr, ip, iterp, ipos double precision x(*), y(*), xval, yout double precision tmp(maxpts), coefs(maxpts) common /spl_coefs/ coefs save if (iterp .lt. 1) iterp = 1 if (iterp .gt. 3) iterp = 3 m = ny if (iterp .eq. 1) then call lintrp(x, y, m, xval, ipos, yout) elseif (iterp .eq. 2) then call qintrp(x, y, m, xval, ipos, yout) elseif (iterp .eq. 3) then if (ipos .le.1) call splcoefs(x, y, m, coefs, tmp) call splint(x, y, coefs, m, xval, ipos, yout) endif return c end subroutine xterp end subroutine splcoefs(x, y, npts, c, t) c c calculate simple (natural) cubic spline coefficients c given a pair of arrays x, y c c c: output array c t: temporary work array implicit none integer npts, ip, i double precision x(*), y(*), c(*), t(*) double precision tiny, zero, xin, yout, one parameter (zero = 0.d0, one = 1.d0) double precision s, p, dxp, dxm, dx2 cc print*, '>> splcoefs ' c(1) = zero t(1) = zero c(npts) = zero do 20 i = 2, npts - 1 dx2 = one / ( x(i+1) - x(i-1) ) dxp = one / ( x(i+1) - x(i) ) dxm = one / ( x(i) - x(i-1) ) s = dx2 * ( x(i) - x(i-1) ) p = one / (2 + s * c(i-1)) c(i) = (s - one) * p t(i) = p * $ (6*dx2*((y(i+1)-y(i))*dxp - (y(i)-y(i-1))*dxm) - s*t(i-1)) 20 continue do 30 i = npts-1,1, -1 c(i) = c(i)*c(i+1) + t(i) 30 continue return end subroutine splint(x, y, c, npts, xin, ip, yout) c c simple natural cubic spline interpolation using c array of coefficients for splcoefs c implicit none integer npts, ip double precision x(*), y(*), c(*) double precision xin, yout, sixth, dx, dxi, a,b parameter (sixth = 1.d0 / 6.d0) c make sure ip is in range c find ip such that x(ip) <= xin <= x(ip+1) call hunt(x, npts, xin, ip) dx = x(ip+1) - x(ip) dxi = 1.d0 / dx a = (x(ip+1) - xin ) * dxi b = (xin - x(ip)) * dxi yout= a*y(ip) + b*y(ip+1) + dx*dx* sixth * $ (a*(a*a-1)*c(ip) + b*(b*b-1)*c(ip+1)) return 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 implicit none integer npts, ip double precision x(*), y(*), tiny, xin, yout parameter (tiny = 1.d-11) c find ip such that x(ip) <= xin < x(ip+1) call hunt(x, npts, xin, 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---------------------------------------------------------------- implicit none integer npts, ip, i1, i2, i3a, i3b, imin, imax double precision x(npts), y(npts), tiny, xin, yout double precision dxi3a, dxi3b, dx12, dx13b, dx23a, dx23b double precision youta, youtb, dxi1, dxi2, dx13a parameter (tiny = 1.d-11) 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 find ip such that x(ip) <= xin < x(ip+1) call hunt(x, npts, xin, ip) yout = y(ip) c 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 integer function iff_get_interp(s) character*(*) s, t*16 integer i, istrln external istrln t = s call triml(t) i = istrln(t) j = 2 if (t(1:4) .eq. 'line') j = 1 if (t(1:4) .eq. 'quad') j = 2 if (t(1:5) .eq. 'cubic') j = 3 if (t(1:6) .eq. 'spline') j = 3 iff_get_interp = j end double precision function determ(array,nord,nrows) c c calculate determinate of a square matrix c c arguments (all strictly input): c array matrix to be analyzed c nord order of matrix c nrows first dimension of matrix in calling routine c c copyright (c) 1998 matt newville c c base on bevington "data reduction and error analysis c for the physical sciences" pg 294 c implicit double precision (a-h,o-z) integer nord, nrows, i, j, k double precision array(nrows,nrows) logical iszero determ = 1 do 150 k=1,nord c if (array(k,k).eq.0) then iszero = .true. do 120 j=k,nord if (array(k,j).ne.0) then iszero =.false. do 100 i=k,nord saved = array(i,j) array(i,j) = array(i,k) array(i,k) = saved 100 continue determ = -determ end if 120 continue if (iszero) then determ = 0 return end if c end if determ = determ*array(k,k) if (k.lt.nord) then k1 = k+1 do 140 i=k1,nord do 130 j=k1,nord array(i,j) = array(i,j)- $ array(i,k)*array(k,j)/array(k,k) 130 continue 140 continue end if 150 continue c end double precision function determ end double precision function bessi0(x) c c zero-ordered modified Bessel function I_0(x) for real x c from abramowitz and stegun p 378 double precision x, v, y, c double precision a1,a2,a3,a4,a5,a6 double precision 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 double precision function sumsqr(array, narray) c returns sum of squares of an array with dimension narray double precision array(*), big, zero parameter( big = 1.d17, zero = 0d0) 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 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 integer isave, jump, i double precision xph(3), pi, twopi, old, xphmin, ph parameter (pi = 3.14159 26535 89793 23846 26433d0) parameter (twopi = 2 * pi) isave = 1 xph(1) = ph - old jump = int( (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. 1.d-2) isave = i 10 continue ph = old + xph(isave) return c end subroutine pijump end subroutine polyft(xfit1,xfit2,xdata,ydata,ndata,nterms,aout) c c get coefficients for polynomial fit : c ydata = aout(1) + aout(2)*xdata + aout(3) *xdata^2 + ... c the fit is done between xdata = [xfit1, xfit2] c c arguments: c xfit1 lower bound of fitting range (single precision) (in) c xfit2 upper bound of fitting range (single precision) (in) c xdata array of abscissa values for data (single precision) (in) c ydata array of ordinate values for data (single precision) (in) c ndata length of data arrays (in) c nterms number of terms in polynomial (in) c aout coefficients of fitted polynomial (single precision) (out) c c requires functions nofx and determ. c note that double and single precision are mixed here. c most internal, working arrays use dp (as does routine determ) c c c copyright (c) 1998 matt newville c c see bevington pg 104 for details c implicit none integer max, max2m1, ndata, nterms, i, j, l, k, n, ntemp integer nfit1, nfit2, nmax, nofx double precision xdata(ndata), ydata(ndata), aout(nterms) double precision zero, one, xi, yi, xterm, yterm, xfit1, xfit2 parameter (max= 5, max2m1 = 2*max-1, zero = 0.d0,one=1.d0) double precision sumx(max2m1), sumy(max) double precision array(max,max), ain(max), delta, determ external determ, nofx c c initialize internal arrays nmax = 2 * nterms - 1 do 100 i=1, nmax sumx(i) = zero 100 continue do 120 i = 1, nterms ain(i) = zero sumy(i) = zero do 110 j = 1, nterms array(i,j) = zero 110 continue 120 continue c c find points closest to endpoints of fitting range nfit1 = nofx(xfit1,xdata,ndata) nfit2 = nofx(xfit2,xdata,ndata) if (nfit1.gt.nfit2) then ntemp = nfit1 nfit1 = nfit2 nfit2 = ntemp end if if(nfit1.eq.nfit2) go to 300 c c collect sums of data, sum of squares of data, etc. do 200 i = nfit1, nfit2 xi = xdata(i) yi = ydata(i) xterm = one do 180 n=1, nmax sumx(n) = sumx(n) + xterm xterm = xterm * xi 180 continue yterm = yi do 190 n=1,nterms sumy(n) = sumy(n) + yterm yterm = yterm * xi 190 continue 200 continue c c construct matrices and evaluate coefficients do 220 j=1,nterms do 210 k=1,nterms array(j,k) = sumx(j + k - 1) 210 continue 220 continue c c take determinant, get coefficients delta = determ(array,nterms,max) if (delta.ne.zero) then do 260 l=1,nterms do 250 j=1,nterms do 240 k=1,nterms array(j,k) = sumx(j+k-1) 240 continue array(j,l) = sumy(j) 250 continue ain(l) = determ(array,nterms,max)/delta 260 continue end if c c convert coefficients to single precision, leave 300 continue do 400 i = 1, nterms aout(i) = ain(i) 400 continue return c end subroutine polyft end subroutine gaussj(a, n, ma, ierr) c c gauss-jordan elimination to invert a matrix. c arguments: c a matrix to invert / solution on output [in/out] c n number of elements in a to use [in] c (i.e. that aren't zero) c ma dimension of a [in] c ierr 0 on success / 1 on error c notes: c if matrix cannot be inverted, a contains garbage c c copyright (c) 1998 matt newville c implicit none c include 'consts.h' c{consts.h -*-fortran-*- c include 'maxpts.h' c{maxpts.h -*-fortran-*- integer maxpts, maxsize_array parameter(maxsize_array = 8192) parameter(maxpts = maxsize_array) c} c integer maxarr, maxdoc, maxtxt integer korder, maxnot, mtknot integer mconst, micode, maxsca, mffpts integer mwfft , maxplt, maxfft, mdata integer mpthpr, mlocal, mppars, mpaths integer mdpths, mvarys, mfffil, mffttl integer maxleg, mckeys, macmax, mcline integer mmcarg, mcdeep, mfiles, mkeys integer maxnumb_array, maxheap_array integer max_restraint parameter ( mckeys = 64 ) parameter ( macmax = 512 ) parameter ( mcline = 4096 ) parameter ( mcdeep = 32 ) parameter ( mfiles = 16 ) parameter ( max_restraint = 10) parameter ( mkeys = 64 ) parameter ( maxnumb_array = 2048) parameter ( maxheap_array = maxpts*256) parameter ( maxarr = maxnumb_array) ! # of array variables parameter ( maxsca = 2048 ) ! # of scalar variables parameter ( maxtxt = 4096 ) ! # of text variables parameter ( mconst = 8192 ) ! # of numerical constants parameter ( maxplt = 64 ) ! # of plots parameter ( maxdoc = 20 ) ! # of docs from data file parameter ( micode = 64 ) ! # of elements in math icode array parameter ( mffpts = 128 ) ! # of points in feff arrays parameter ( mfffil = 256 ) ! # of feff arrays parameter ( mffttl = 10 ) ! # of feff titles parameter ( maxleg = 7 ) ! # of legs in feff path parameter ( mpthpr = 16 ) ! # of path parameters parameter ( mlocal = 8 ) ! # of local parameters parameter ( maxnot = 32 ) ! # of knots in background spline parameter ( korder = 4 ) parameter ( mtknot = maxnot+korder) parameter ( mdata = 16 ) ! # of data sets parameter ( mvarys = 75 ) ! # of fitting variables parameter ( mdpths = 100 ) ! # of paths for a data set parameter ( mpaths = 100 ) ! # of paths, total parameter ( mppars = 16 ) ! # of path parameters parameter ( mmcarg = 9 ) ! # of macro arguments c c common constants double precision zero, one, etok, pi, qgrid, rgrid parameter ( zero = 0.d0) parameter ( one = 1.d0) parameter ( etok = 0.2624682917d0) parameter ( pi = 3.141592653589793d0) character undef*8,undef_array*10, blank*1 parameter (undef= '%undef%', blank = ' ') parameter (undef_array= '%_undef._%') c c fft constants parameter ( maxfft = 2048 ) ! points for fft arrays parameter ( mwfft = 4*maxfft+15) parameter ( qgrid = 0.050d0) parameter ( rgrid = pi/(qgrid * maxfft)) c} integer n, ma, i, j,k,l,m, irow, icol, ierr integer ipiv(mvarys), indrow(mvarys), indcol(mvarys) double precision a(ma,ma), abig, tmp, piv c ierr = 1 irow = 0 icol = 0 c initialize pivot array do 30 i = 1, n ipiv(i) = 0 30 continue c c main loop over the columns to be reduced do 300 i = 1, n abig = zero c linear 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. abig) then abig = abs(a(j,k)) irow = j icol = k endif 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 tmp = a(irow, l) a(irow, l) = a(icol, l) a(icol, l) = tmp 160 continue endif c divide the pivot row by the pivot element indrow(i) = irow indcol(i) = icol if (a(icol, icol).eq.zero) return piv = one / a(icol, icol) a(icol,icol) = one do 200 l = 1, n a(icol, l) = a(icol, l) * piv 200 continue c reduce non-pviot rows do 250 m = 1, n if (m.ne.icol) then tmp = a(m, icol) a(m,icol) = zero do 220 l = 1, n a(m,l) = a(m,l) - a(icol,l) * tmp 220 continue endif 250 continue 300 continue c c unravel the solution: interchange column pairs c in the reverse order of the permutation ierr = 0 do 400 i = n, 1, -1 if (indrow(i) .ne. indcol(i)) then do 350 j = 1, n tmp = a(j,indrow(i)) a(j,indrow(i)) = a(j,indcol(i)) a(j,indcol(i)) = tmp 350 continue endif 400 continue c return c end subroutine gaussj end double precision function rfact(xdata, 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 input: c xdata (real,imag) pairs for data over fit range c theory (real,imag) pairs for theory over fit range c ndata number of data points to use c output: c c sum{ [re(xdata) - re(theory)]^2 + [im(xdata) - im(theory)]^2 } c rfact = ------------------------------------------------------------ c sum{ [re(xdata)]^2 + [im(xdata)]^2 } c c copyright 1999 matt newville c double precision xdata(*), theory(*), ampl, small integer ndata, i parameter(small = 1.d-08) c initialize ampl = 0 rfact = 0 c construct sums of squares do 100 i = 1, ndata ampl = ampl + xdata(i)**2 rfact = rfact + (xdata(i) - theory(i))**2 100 continue rfact = rfact / max(small, ampl) return c end function rfact end subroutine kev2ev(e, ne) c 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////////////////////////////////////////////////////////////////////// c c test and (if needed) convert an energy array in KeV to eV implicit none integer ne, i double precision e(ne), de if ((e(1).le.50).and.(e(ne).le.50)) then de = e(2) - e(1) do 300 i = 2, ne de = min(de, (e(i) - e(i-1))) 300 continue if (de .le. 0.01) then do 310 i = 1, ne e(i) = e(i) * 1000 310 continue endif endif return 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 echo(messg) if (abortf) then call echo('* 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 echo('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 echo('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 echo('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 window(swin, dx1, dx2, xmin, xmax, xgrid, mpts, wa) c 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////////////////////////////////////////////////////////////////////// c c purpose: create a window array for ffts c (used to smooth out data and maintain peak separation). c arguments: c swin: window type (see notes below) [in] c mpts: dimension of wa [in] c dx1: window parameters (see notes below) [in] c dx2: window parameters (see notes below) [in] 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: 9 window functions are supported. many windows rise from c 0 at x1 to 1 at x2, stay at 1 until x3 and drop to 0 at x4. c x1,...,x4 depend on window _type_ (iwin) and parameters c (dx1,dx2,xmin,xmax). the gaussian window extends over the whole c input range and never equal 0. the array is on an even grid c beginning at zero: wa(i) = wa(x=(i-1)*xgrid). c c windows types are ( if swin = " ", iwin will be set to 0). c iwin (swin) c 0 (han): hanning window sills (default): c x1 = xmin - dx1/2 , x2 = xmin + dx1/2 c x3 = xmax - dx2/2 , x4 = xmax + dx2/2 c the hanning function goes as cos^2 and sin^2. c 1 (fha): hanning window fraction: c x1 = xmin , x2 = xmin + dx1*(xmax-xmin)/2 c x4 = xmax, x3 = xmax - dx1*(xmax-xmin)/2 c the function goes as cos^2 and sin^2. dx1 is the c hanning fraction: the fraction of the x range over c which the windop is not 1. (dx1 = 1 will c give a full hanning fraction, with x2 = x3) c 2 (gau): gaussian window c window(x) = exp( -dx1*(x - dx2)**2 ) c 3 (kai): 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 (par): parzen window: c x1 = xmin - dx1/2 , x2 = xmin + dx1/2 c x3 = xmax - dx2/2 , x4 = xmax + dx2/2 c the window is linear between x1 and x2 and x3 and x4 c 5 (wel): welch window: c x1 = xmin - dx1/2 , x2 = xmin + dx1/2 c x3 = xmax - dx2/2 , x4 = xmax + dx2/2 c the window is parabolic between x1 and x2 and x3 and x4. c 6 (sin): sine window: c x1 = xmin - dx1 , x4 = xmin + dx1 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 c for more information, see documentation for ifeffit c implicit none integer mpts, iw, i, istrln character*(*) swin, s*32 double precision wa(mpts), halfpi, zero, one, half, eps double precision x, x1, x2, x3, x4, xmin,xmax, xgrid, dx1, dx2 double precision del1, del2, del12, del22 double precision bessi0, bki0, bkav, bkde, bkde2, bkx, bkxx, bkom external bessi0, istrln parameter (halfpi= 1.570796326795d0, eps= 1.4d-5) parameter ( zero=0.d0, one=1.d0, half= 0.5d0) c determine window type s = swin call triml(s) call lower(s) i = istrln(s) iw = 0 if (s(1:3) .eq. 'fha') then iw = 1 elseif (s(1:3) .eq. 'gau') then iw = 2 elseif (s(1:3) .eq. 'kai') then iw = 3 elseif (s(1:3) .eq. 'par') then iw = 4 elseif (s(1:3) .eq. 'wel') then iw = 5 elseif (s(1:3) .eq. 'sin') then iw = 6 endif c del1 = dx1 del12= dx1 * half del2 = dx2 del22= dx1 * half x1 = xmin x2 = 0 x3 = 0 x4 = xmax c set x1..x4 based on window type c hanning sills, parzen, and welch: x1 = xmin - del12 x2 = xmin + del12 + (eps * xgrid) x3 = xmax - del22 - (eps * xgrid) x4 = xmax + del22 cc print*, 'U: iw, x1,x2,x3,x4', iw, x1,x2,x3,x4 c hanning fraction if (iw.eq.1) then cc print*, 'U: iw, x1,x2,x3,x4', iw, x1,x2,x3,x4 if (del12.lt.zero) del12 = zero if (del12.gt.half) del12 = half x2 = x1 + eps * xgrid + del12*(xmax-xmin) x3 = x4 - eps * xgrid - del12*(xmax-xmin) cc print*, 'E: del12, del22, xgrid,eps=',del12, del12, xgrid, eps cc print*, 'E: x1, x2, x3, x4 = ', x1, x2, x3, x4 c gaussian: elseif (iw.eq.2) then del1 = max(del1, eps) c sine elseif (iw.eq.6) then x1 = xmin - del1 x4 = xmax + del2 end if c 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 ((x.ge.x1).and.(x.le.x2)) then wa(i) = sin(halfpi*(x-x1) / (x2-x1)) ** 2 elseif ((x.ge.x3).and.(x.le.x4)) then wa(i) = cos(halfpi*(x-x3) / (x4-x3)) ** 2 elseif ((x.lt.x3).and.(x.gt.x2)) then wa(i) = one else wa(i) = zero endif 10 continue c gaussian else if (iw.eq.2) then do 20 i = 1, mpts wa(i) = exp( -(del1 * ((i-1)*xgrid - del2)**2 )) 20 continue c Kaiser-Bessel window elseif (iw.eq.3) then bki0 = bessi0(del1) bkav = (x4+x1) * half bkde = (x4-x1) * half bkde2 = bkde * bkde bkom = del1 / bkde do 30 i = 1, mpts wa(i) = zero x = (i-1)*xgrid bkx = x - bkav bkxx = bkde2 - bkx*bkx 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 ((x.ge.x1).and.(x.le.x2)) then wa(i) = (x-x1) / (x2 - x1) elseif ((x.ge.x3).and.(x.le.x4)) then wa(i) = one - (x-x3) / (x4-x3) elseif ((x.lt.x3).and.(x.gt.x2)) then wa(i) = one else wa(i) = zero endif 40 continue c welch elseif (iw.eq.5) then do 50 i=1, mpts x = (i-1)*xgrid if ((x.ge.x1).and.(x.le.x2)) then wa(i) = one - ((x-x2) / (x2-x1)) ** 2 elseif ((x.ge.x3).and.(x.le.x4)) then wa(i) = one - ((x-x3) / (x4-x3)) ** 2 elseif ((x.lt.x3).and.(x.gt.x2)) then wa(i) = one else wa(i) = zero endif 50 continue c sine elseif (iw.eq.6) then do 60 i = 1, mpts x = (i-1)*xgrid if ((x.ge.x1).and.(x.le.x4)) $ wa(i) = sin( 2* halfpi*(x4-x) / (x4-x1)) 60 continue c gaussian#2 elseif (iw.eq.7) then do 70 i = 1, mpts x = (i-1)*xgrid wa(i) = exp( -(del1 * (x - del2)**2 )) 70 continue end if return c end subroutine window end subroutine cfftb (n,c,wsave) double precision c(*), wsave(*) if (n .eq. 1) return iw1 = n+n+1 iw2 = iw1+n+n call dcftb1 (n,c,wsave,wsave(iw1),wsave(iw2)) return end subroutine dcftb1 (n,c,ch,wa,wifac) double precision c(*), ch(*), wa(*), wifac(*) c nf = int(wifac(2)) na = 0 l1 = 1 iw = 1 do 116 k1=1,nf ip = int(wifac(k1+2)) l2 = ip*l1 ido = n/l2 idot = ido+ido idl1 = idot*l1 if (ip .eq. 4) then ix2 = iw+idot ix3 = ix2+idot if (na .eq. 0) then call dpssb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) else call dpssb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) end if na = 1-na elseif (ip .eq. 2) then if (na .eq. 0) then call dpssb2 (idot,l1,c,ch,wa(iw)) else call dpssb2 (idot,l1,ch,c,wa(iw)) end if na = 1-na elseif (ip .eq. 3) then ix2 = iw+idot if (na .eq. 0) then call dpssb3 (idot,l1,c,ch,wa(iw),wa(ix2)) else call dpssb3 (idot,l1,ch,c,wa(iw),wa(ix2)) end if na = 1-na elseif (ip .eq. 5) then ix2 = iw+idot ix3 = ix2+idot ix4 = ix3+idot if (na .eq. 0) then call dpssb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) else call dpssb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) end if na = 1-na else if (na .eq. 0) then call dpssb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) else call dpssb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) end if if (nac .ne. 0) na = 1-na end if l1 = l2 iw = iw+(ip-1)*idot 116 continue if (na .eq. 0) return c n2 = n+n do 117 i=1,n2 c(i) = ch(i) 117 continue c return end subroutine dpssb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) double precision cc(ido,ip,l1), c1(ido,l1,ip), c2(idl1,ip), 1 ch(ido,l1,ip), ch2(idl1,ip), wa(*), wai, war c idot = ido/2 ipp2 = ip+2 ipph = (ip+1)/2 idp = ip*ido c if (ido .ge. l1) then 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 c do 105 k=1,l1 do 104 i=1,ido ch(i,k,1) = cc(i,1,k) 104 continue 105 continue else 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 c do 111 i=1,ido do 110 k=1,l1 ch(i,k,1) = cc(i,1,k) 110 continue 111 continue c end if 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 c do 118 j=2,ipph do 117 ik=1,idl1 ch2(ik,1) = ch2(ik,1)+ch2(ik,j) 117 continue 118 continue c 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 c nac = 1 if (ido .eq. 2) return nac = 0 c do 121 ik=1,idl1 c2(ik,1) = ch2(ik,1) 121 continue c 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 c if (idot .le. l1) then 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 else c 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 c end if return end subroutine dpssb2 (ido,l1,cc,ch,wa1) double precision cc(ido,2,l1), ch(ido,l1,2), wa1(*), ti2, tr2 c 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 c 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 c return end subroutine dpssb3 (ido,l1,cc,ch,wa1,wa2) double precision cc(ido,3,l1), ch(ido,l1,3), wa1(*), wa2(*), 1 ci2, ci3, cr2, cr3, di2, di3, dr2, dr3, taui, taur, ti2, tr2 data taur / -0.5 d0 / data taui / 0.8660254037 8443864676 3723170752 93618d0/ c c one half sqrt(3) = .866025..... . c 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 c 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 c return end subroutine dpssb4 (ido,l1,cc,ch,wa1,wa2,wa3) double precision cc(ido,4,l1), ch(ido,l1,4), wa1(*), wa2(*), 1 wa3(*), ci2, ci3, ci4, cr2, cr3, cr4, ti1, ti2, ti3, ti4, tr1, 2 tr2, tr3, tr4 c 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 c 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 c return end subroutine dpssb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) double precision cc(ido,5,l1), ch(ido,l1,5), wa1(*), wa2(*), 1 wa3(*), wa4(*), ci2, ci3, ci4, ci5, cr2, cr3, cr4, cr5, 2 di2, di3, di4, di5, dr2, dr3, dr4, dr5, ti11, ti12, ti2, ti3, 3 ti4, ti5, tr11, tr12, tr2, tr3, tr4, tr5 data tr11 / 0.3090169943 7494742410 2293417182 81906d0/ data ti11 / 0.9510565162 9515357211 6439333379 38214d0/ data tr12 / -0.8090169943 7494742410 2293417182 81906d0/ data ti12 / 0.5877852522 9247312916 8705954639 07277d0/ c c sin(pi/10) = .30901699.... . c cos(pi/10) = .95105651.... . c sin(pi/5 ) = .58778525.... . c cos(pi/5 ) = .80901699.... . c 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 c 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 c return end subroutine cfftf (n,c,wsave) double precision c(*), wsave(*) c if (n .eq. 1) return c iw1 = n+n+1 iw2 = iw1+n+n call dcftf1 (n,c,wsave,wsave(iw1),wsave(iw2)) c return end subroutine dcftf1 (n,c,ch,wa,wifac) double precision c(*), ch(*), wa(*), wifac(*) c nf = int(wifac(2)) na = 0 l1 = 1 iw = 1 do 116 k1=1,nf ip = int(wifac(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 dpssf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3)) go to 102 101 call dpssf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3)) 102 na = 1-na go to 115 c 103 if (ip .ne. 2) go to 106 if (na .ne. 0) go to 104 call dpssf2 (idot,l1,c,ch,wa(iw)) go to 105 104 call dpssf2 (idot,l1,ch,c,wa(iw)) 105 na = 1-na go to 115 c 106 if (ip .ne. 3) go to 109 ix2 = iw+idot if (na .ne. 0) go to 107 call dpssf3 (idot,l1,c,ch,wa(iw),wa(ix2)) go to 108 107 call dpssf3 (idot,l1,ch,c,wa(iw),wa(ix2)) 108 na = 1-na go to 115 c 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 dpssf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4)) go to 111 110 call dpssf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4)) 111 na = 1-na go to 115 c 112 if (na .ne. 0) go to 113 call dpssf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw)) go to 114 113 call dpssf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw)) 114 if (nac .ne. 0) na = 1-na c 115 l1 = l2 iw = iw+(ip-1)*idot 116 continue if (na .eq. 0) return c n2 = n+n do 117 i=1,n2 c(i) = ch(i) 117 continue c return end subroutine dpssf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa) double precision cc(ido,ip,l1), c1(ido,l1,ip), c2(idl1,ip), 1 ch(ido,l1,ip), ch2(idl1,ip), wa(*), wai, war c idot = ido/2 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 c 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 c 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 c do 111 i=1,ido do 110 k=1,l1 ch(i,k,1) = cc(i,1,k) 110 continue 111 continue c 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 c do 118 j=2,ipph do 117 ik=1,idl1 ch2(ik,1) = ch2(ik,1)+ch2(ik,j) 117 continue 118 continue c 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 c nac = 1 if (ido .eq. 2) return nac = 0 c do 121 ik=1,idl1 c2(ik,1) = ch2(ik,1) 121 continue c 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 c 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 c 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 c return end subroutine dpssf2 (ido,l1,cc,ch,wa1) double precision cc(ido,2,l1), ch(ido,l1,2), wa1(*), ti2, tr2 c 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 c 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 c return end subroutine dpssf3 (ido,l1,cc,ch,wa1,wa2) double precision cc(ido,3,l1), ch(ido,l1,3), wa1(*), wa2(*), 1 ci2, ci3, cr2, cr3, di2, di3, dr2, dr3, taui, taur, ti2, tr2 data taur / -0.5 d0 / data taui / -0.8660254037 8443864676 3723170752 93618d0/ c 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 c 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 c return end subroutine dpssf4 (ido,l1,cc,ch,wa1,wa2,wa3) double precision cc(ido,4,l1), ch(ido,l1,4), wa1(*), wa2(*), 1 wa3(*), ci2, ci3, ci4, cr2, cr3, cr4, ti1, ti2, ti3, ti4, 2 tr1, tr2, tr3, tr4 c 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 c 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 c return end subroutine dpssf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4) double precision cc(ido,5,l1), ch(ido,l1,5), wa1(*), wa2(*), 1 wa3(*), wa4(*), ci2, ci3, ci4, ci5, cr2, cr3, cr4, cr5, di2, 2 di3, di4, di5, dr2, dr3, dr4, dr5, ti11, ti12, ti2, ti3, ti4, 3 ti5, tr11, tr12, tr2, tr3, tr4, tr5 data tr11 / 0.3090169943 7494742410 2293417182 81906d0/ data ti11 / -0.9510565162 9515357211 6439333379 38214d0/ data tr12 / -0.8090169943 7494742410 2293417182 81906d0/ data ti12 / -0.5877852522 9247312916 8705954639 07277d0/ c if (ido .eq. 2) then 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 else 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 end if return end subroutine cffti (n,wsave) double precision wsave(*) c if (n .eq. 1) return c iw1 = n+n+1 iw2 = iw1+n+n call dcfti1 (n,wsave(iw1),wsave(iw2)) c return end subroutine dcfti1 (n,wa,wifac) double precision wa(*), arg, argh, argld, fi, tpi, wifac(*) integer ntryh(4) data ntryh(1), ntryh(2), ntryh(3), ntryh(4) /3, 4, 2, 5/ data tpi / 6.2831853071 7958647692 5286766559 00577d0/ c nl = n nf = 0 j = 0 c 101 j = j+1 if (j.le.4) ntry = ntryh(j) if (j.gt.4) ntry = ntry + 2 104 nq = nl/ntry nr = nl-ntry*nq if (nr.ne.0) go to 101 c 105 nf = nf+1 wifac(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 wifac(ib+2) = wifac(ib+1) 106 continue wifac(3) = 2 c 107 if (nl .ne. 1) go to 104 c wifac(1) = n wifac(2) = nf c argh = tpi/n i = 2 l1 = 1 do 110 k1=1,nf ip = int(wifac(k1+2)) ld = 0 l2 = l1*ip ido = n/l2 idot = ido+ido+2 ipm = ip-1 c do 109 j=1,ipm i1 = i wa(i-1) = 1.d0 wa(i) = 0.d0 ld = ld+l1 fi = 0.d0 argld = ld*argh do 108 ii=4,idot,2 i = i+2 fi = fi+1.d0 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 c l1 = l2 110 continue c 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 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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 from encod! integer jconst, io2n(maxval) integer iv, id, i, j, ip, jv, ilcl, inpath, jpar integer idata, inpth0, idpath, ipar, nvar 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 double precision xval(maxval), zero character*(*) vnames(maxval) parameter (mxval = 2048, mcode = 256, zero = 0.d0) 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 integer jdebye, jeins, jeins2 parameter(jdebye=-120, jeins =-121, jeins2=-122) double precision xnew(mxval), xxtmp 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 print*, ' new variable order: ', ntotal, nconst, nvar c do i = 1, ntotal c print*, i, ' ',vnew(i)(1:20) c enddo 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 double precision 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 double precision 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 double precision 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 double precision 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 double precision f1mth, f2mth, zero, cordby, einsdw, einval integer jconst, icode(ni) parameter(mstack= 32, jconst = 8192, zero = 0.) double precision 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 double precision 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 double precision 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.d0, one = 1.d0, expmax = 50.d0) 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 (dabs(x).le.one) then f1mth = asin(x) else error = .true. end if elseif (iop.eq.iacos) then if (dabs(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 double precision 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. double precision 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.d0, one = 1.d0, fifty = 50.d0) 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) double precision 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.d0 120 continue return c end subroutine stack end double precision 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, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} double precision temp, thetad, tk, theta, sig2 double precision 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 double precision 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- double precision small parameter (small = 1.d-4) c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} double precision 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 double precision 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) double precision small, big, two, factor double precision t, theta, rmass, x, t1, th1, rm1 parameter (two = 2.d0, small = 1.d-3, big = 1.d8 ) parameter (factor = 24.25423371d0) cc parameter (hbarc = 1973.270533d0, boltz = 8.617385d-5) cc parameter (amu2ev = 9.3149432d8 ) 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. implicit none integer i, j, nlegx, nleg double precision tk, theta, zero, two, rs, dist double precision rij, rimjm, rijm, rimj, riim, rjjm double precision ridotj, cimj, cosijm, cij, cimjm double precision sig2,sig2ij, cijm parameter (nlegx = 7, zero = 0., two = 2.) double precision rat(3,0:nlegx) integer 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) = 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 implicit none double precision rij, theta, tk, rs, cij double precision pi,one,athird,bohr,con,x,temper double precision ami,amj,xkd,xinteg,eps,atwts integer iz1,iz2,nx parameter (pi = 3.14159 26535 89793 23846 26433d0) parameter (one = 1.d0, athird = 0.333333333333333d0) parameter (bohr = 0.529 177 249d0) parameter (con = 48.559d0) common /xtemp/ x, temper external atwts c c theta in degrees k, t temperature in degrees k ami = atwts(iz1) amj = atwts(iz2) temper = theta / tk xkd = (9*pi/2.d0)**(athird) / (rs * bohr) x = xkd * rij c call numerical integration call bingrt (xinteg, eps, nx) cij = (3.d0/2.d0) * xinteg * con / (theta* sqrt(ami*amj)) return c end subroutine corrfn end double precision 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) implicit none double precision wmin, argmax,x ,temper, w, emwt double precision argu parameter (wmin = 1.d-20, argmax = 50.d0) 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 implicit none double precision debfun, zero,one,two,three,four,tol double precision b, eps, zi,del, sum, bn, bo,bnp1 integer n, itn,i, nmax parameter(nmax = 10, tol = 1.d-5) parameter(zero=0.d0, one=1.d0, two=2.d0) parameter(three=3.d0, four=4.d0) 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 = dabs( (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 double precision function atwts (iz) c c returns atomic weight from atom number (iz) c double precision 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 double precision function dist (r0, r1) c find distance between cartesian points r0 and r1 double precision 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 fefinp(mpts, mfil, mtitle, mleg, $ title, feffil, iffrec, degflg, degpth, $ refpth, rwgpth, ratpth, theamp, $ thepha, qfeff, cphase, sphase, $ 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 implicit none integer mxmpts, ipos integer mpts, mfil, mtitle, mleg, mdocx double precision degpth(mfil), refpth(mfil), rwgpth(mfil) double precision ratpth(3, 0:mleg, mfil), qfeff(mpts, mfil) double precision theamp(mpts, mfil), thepha(mpts, mfil) double precision cphase(mpts, mfil), sphase(mpts, mfil), q double precision 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, j, nleg, itmp, nepts,i integer nwords,l0,ndoc,npot, ilen, ipth, istrln integer nunit, iex, npts, ierr, ntitle, iunit 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), npack complex*16 phc(mptsx), ck(mptsx), coni, cchi double precision xk(mptsx), achi(mptsx), phchi(mptsx) double precision beta(mlegx), rf2b, rnrmav double precision eps, phff, phffo, xlam, reff, bohr, zero parameter (zero = 0.d0, eps = 1.d-12, bohr = 0.529 177 249d0) parameter (coni = (0.d0,1.d0)) parameter (stat = 'old') external istrln npack = 8 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)) cc print*, ' call rdffdt ' 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), cphase(1,ipth), sphase(1,ipth), $ xlamb(1,ipth), realp(1,ipth)) cc print*, ' ', refpth(ipth), degpth(ipth), ipth cc print*, 'FEFINP q ', qfeff(1,ipth), qfeff(2,ipth), cc $ qfeff(3,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 str2dp(words(3), degpth(ipth), ierr) call str2in(words(4), nepts, ierr) call str2dp(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 rdpadd(iunit,npack,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 rdpadd(iunit,npack,beta,nleg) call rdpadd(iunit,npack,beta,nleg) call rdpadd(iunit,npack,beta,nleg) c but we really want these arrays (amplitude and phase) call rdpadd(iunit,npack,achi,nepts) call rdpadd(iunit,npack,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(dimag(ck(i))) .gt. eps) then xlam= 1/dimag(ck(i)) else xlam = 1.d10 end if if (abs(cchi).ge.eps) then phff = atan2 (dimag(cchi), dble(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) = dble ( 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(ffname,mtitle,mleg,mpts, ntitle, nleg, npts, $ title, reff, rwignr, degen, xyz, ipot, iz, $ qf,amplit,phase,cphase,sphase,xlamb,realp) c 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////////////////////////////////////////////////////////////////////// c c read a feffnnnn.dat file implicit none integer i, ier1, ier2, ier3, ier4, ix, ileg, nwords integer mtitle, mleg, mpts, ntitle, nleg, npts character*(*) ffname, title(mtitle), filnam*128 integer ipot(0:mleg), iz(0:mleg) double precision reff, rwignr, degen, xyz(3,0:mleg) double precision qf(*), amplit(*), phase(*) double precision cphase(*), sphase(*) double precision xlamb(*), realp(*), zero, xlmin character*40 stat*5, line*90, words(6), messg*80 integer iunit, iex, ierr parameter (zero = 0, xlmin = 1.d-8) double precision cdel, afeff,phfeff, redfac, xk, xlmda, preal data stat /'old'/ iunit = 0 xk = zero filnam = ffname call openfl(iunit, filnam , stat, iex, ierr) if ((iex.lt.0).or.(ierr.lt.0)) $ call echo(' error reading file: '//filnam) 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) then write(messg,'(2x,a,i2)') $ 'too many legs in path. current limit is', mleg call echo(messg) call echo(' '//filnam) end if call str2dp(words(2), degen, ier2) call str2dp(words(3), reff, ier3) call str2dp(words(4), rwignr, ier4) if ( (ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0).or. $ (ier4.ne.0) ) then call echo(' bad data in feffnnnn.dat file: '//filnam) end if 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 str2dp( 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) then call echo(' not enough memory for fefff file: '//filnam) write(messg,'(2x,a,i3,a)') 'results above k = ', $ int(xk), ' will not be reliable' call echo(messg) end if qf(i) = xk amplit(i) = afeff * redfac cphase(i) = cdel sphase(i) = phfeff xlamb(i) = max(xlmin, xlmda) realp(i) = preal 500 continue 505 continue npts = i - 1 close(iunit) c c make sure no 2pi jumps in phase phase(1) = cphase(1) + sphase(1) do 800 i = 2, npts call pijump ( cphase(i), cphase(i-1)) call pijump ( sphase(i), sphase(i-1)) phase(i) = cphase(i) + sphase(i) 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 cphase(i) = zero sphase(i) = zero phase(i) = zero realp(i) = zero xlamb(i) = 1.d10 end if 850 continue c done return 999 format(a) c end subroutine rdffdt end subroutine rdfb1(ffname,iunit,mtitle,mleg,mpts, $ ntitle,npot,npts,rnrmav,l0,title,izpot,phc,ck,xk) c c read top of feff.bin implicit none integer npot, npts, mtitle, mleg, mpts, iunit, ivers character*(*) ffname, filnam*128, title(mtitle), baddat*256 integer izpot(0:mleg), l0, ntext,i, ntitle,ier1, ier2, ier3 integer mptsx parameter(mptsx= 128) complex*16 phc(*), ck(*) double precision xk(*), ere(mptsx), rnrmav integer mwords, ierr, nwords, npack character*128 str parameter (mwords = 20 ) character*30 words(mwords) npack = 8 filnam = ffname baddat = ' bad data in feff.bin file: '//filnam 10 format(a) c first line identifies file (only) read(iunit,10) str call sclean(str) if ((str(1:10).ne.'#_feff.bin')) call echo(baddat) 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 sclean(str) if ((str(1:2).ne.'#_')) call echo(baddat) nwords = 3 call bwords(str(3:),nwords,words) if (nwords.ne.3) call echo(baddat) 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 echo(baddat) c title lines ntitle = min(ntext,mtitle) do 20 i = 1, ntext read(iunit,10) str call sclean(str) if (str(1:2).ne.'#"') call echo(baddat) 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 sclean(str) if (str(1:2).ne.'#&') call echo(baddat) nwords = 8 call bwords(str(3:),nwords,words) if (ivers.eq.1) then if (nwords.ne.8) call echo(baddat) call str2dp(words(3), rnrmav, ier1) call str2in(words(8), l0, ier2) if ((ier1.ne.0).or.(ier2.ne.0)) call echo(baddat) elseif (ivers.eq.2) then if (nwords.ne.5) call echo(baddat) call str2dp(words(2), rnrmav, ierr) call str2in(words(5), l0, ier2) if ((ier1.ne.0).or.(ier2.ne.0)) call echo(baddat) end if c read pot labels and atomic numbers read(iunit,10) str call sclean(str) if (str(1:2).ne.'#@') call echo(baddat) nwords = min(mwords, 2 * npot + 2 ) call bwords(str(3:), nwords, words) if (nwords.ne.(2 + 2*npot)) call echo(baddat) do 30 i = 0, npot call str2in(words(2+npot+i),izpot(i),ier1) if (ier1.ne.0) call echo(baddat) 30 continue c c read packed arrays call rdpadx(iunit,npack,phc, npts) call rdpadd(iunit,npack,ere, npts) call rdpadx(iunit,npack,ck, npts) call rdpadd(iunit,npack,xk, npts) c done return end c c PAD library: Packed Ascii Data c these routines contain code for handling packed-ascii-data c (pad) arrays for writing printable character strings that c represent real or complex scalars and arrays to a file. c c routines included in padlib are (dp==double precision): c wrpadd write a dp array as pad character strings c wrpadx write a dp complex array as pad character strings c rdpadr read a pad character array as a real array c rdpadd read a pad character array as a dp array c rdpadc read a pad character array as a complex array c rdpadx read a pad character array as a dp complex array c pad internal routine to convert dp number to pad string c unpad internal routine to pad string to dp number c c routines not included, but required by padlib: c triml, istrln, echo, iread, sclean c c////////////////////////////////////////////////////////////////////// c Copyright (c) 1997--2001 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////////////////////////////////////////////////////////////////////// c subroutine wrpadd(iout,npack,array,npts) c c write a dp array to a file in packed-ascii-data format c c inputs: [ no outputs / no side effects ] c iout unit to write to (assumed open) c npack number of characters to use (determines precision) c array real array c npts number of array elements to read c notes: c real number converted to packed-ascii-data string using pad c include 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iout, npack, npts, mxl, js, i character str*128 double precision array(*), xr js = 0 str = ' ' mxl = maxlen - npack + 1 do 20 i = 1, npts js = js+npack xr = array(i) call pad(xr, npack, str(js-npack+1:js)) if ((js.ge.mxl).or.(i.eq.npts)) then write(iout,100) cpadr, str(1:js) js = 0 end if 20 continue return 100 format(a1,a) end c --padlib-- subroutine wrpadx(iout,npack,array,npts) c write complex*16 array as pad string c include 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iout, npack, npts, mxl, js, i complex*16 array(*) character str*128 double precision xr, xi js = 0 str = ' ' mxl = maxlen - 2 * npack + 1 do 20 i = 1, npts js = js + 2 * npack xr = dble(array(i)) xi = dimag(array(i)) call pad(xr, npack, str(js-2*npack+1:js-npack)) call pad(xi, npack, str(js-npack+1:js)) if ((js.ge.mxl).or.(i.eq.npts)) then write(iout,100) cpadc, str(1:js) js = 0 end if 20 continue return 100 format(a1,a) end c --padlib-- subroutine wrpadr(iout,npack,array,npts) c c write a real array to a file in packed-ascii-data format c c inputs: [ no outputs / no side effects ] c iout unit to write to (assumed open) c npack number of characters to use (determines precision) c array real array c npts number of array elements to read c notes: c real number converted to packed-ascii-data string using pad c include 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iout, npack, npts, mxl, js, i character str*128 real array(*) double precision xr js = 0 str = ' ' mxl = maxlen - npack + 1 do 20 i = 1, npts js = js+npack xr = dble(array(i)) call pad(xr, npack, str(js-npack+1:js)) if ((js.ge.mxl).or.(i.eq.npts)) then write(iout,100) cpadr, str(1:js) js = 0 end if 20 continue return 100 format(a1,a) end c --padlib-- subroutine wrpadc(iout,npack,array,npts) c write complex (*8) array as pad string c include 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iout, npack, npts, mxl, js, i complex array(*) character str*128 double precision xr, xi js = 0 str = ' ' mxl = maxlen - 2 * npack + 1 do 20 i = 1, npts js = js + 2 * npack xr = dble(array(i)) xi = aimag(array(i)) call pad(xr, npack, str(js-2*npack+1:js-npack)) call pad(xi, npack, str(js-npack+1:js)) if ((js.ge.mxl).or.(i.eq.npts)) then write(iout,100) cpadc, str(1:js) js = 0 end if 20 continue return 100 format(a1,a) end c --padlib-- subroutine rdpadd(iou,npack,array,npts) c read dparray from packed-ascii-data file c arguments: c iou unit to read from (assumed open) (in) c npack number of characters to use (determines precision) (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 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iou, npack, npts, ndline, i, istrln, ipts, iread double precision array(*), unpad , tmp character ctest, ccomp character str*128 external unpad, istrln, iread ccomp = cpadr ipts = 0 10 continue i = iread(iou, str) if (i.lt.0) go to 50 call triml(str) ctest = str(1:1) str = str(2:) ndline = i/npack if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200 do 30 i = 1, ndline ipts = ipts + 1 tmp = unpad(str(1-npack+i*npack:i*npack),npack) array(ipts) = tmp if (ipts.ge.npts) go to 50 30 continue go to 10 50 continue return 200 continue call echo (' -- Read_PAD error: bad data at line:') i = istrln(str) call echo (str(:i)) stop ' -- fatal error in reading PAD data file -- ' end c --padlib-- subroutine rdpadr(iou,npack,array,npts) c read real array from packed-ascii-data file c arguments: c iou unit to read from (assumed open) (in) c npack number of characters to use (determines precision) (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 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iou, npack, npts, ndline, i, istrln, ipts, iread real array(*) double precision unpad , tmp character ctest, ccomp character str*128 external unpad, istrln, iread ccomp = cpadr ipts = 0 10 continue i = iread(iou, str) if (i.lt.0) go to 50 call triml(str) ctest = str(1:1) str = str(2:) ndline = i/npack if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200 do 30 i = 1, ndline ipts = ipts + 1 tmp = unpad(str(1-npack+i*npack:i*npack),npack) array(ipts) = real(tmp) if (ipts.ge.npts) go to 50 30 continue go to 10 50 continue return 200 continue call echo (' -- Read_PAD error: bad data at line:') i = istrln(str) call echo (str(:i)) stop ' -- fatal error in reading PAD data file -- ' end c --padlib-- subroutine rdpadc(iou,npack,array,npts) c read complex array from packed-ascii-data file c arguments: c iou unit to read from (assumed open) (in) c npack number of characters to use (determines precision)(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 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iou, npack,npts, ndline, i, istrln, ipts, np, iread double precision unpad, tmpr, tmpi complex array(*) character ctest, ccomp character str*128 external unpad, istrln, iread ccomp = cpadc ipts = 0 np = 2 * npack 10 continue i = iread(iou, str) if (i.lt.0) go to 50 call triml(str) ctest = str(1:1) str = str(2:) ndline = i / 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),npack) tmpi = unpad(str(1-npack+i*np:i*np),npack) array(ipts) = cmplx(tmpr, tmpi) if (ipts.ge.npts) go to 50 30 continue go to 10 50 continue return 200 continue call echo (' -- Read_PAD error: bad data at line:') i = istrln(str) call echo (str(:i)) stop ' -- fatal error in reading PAD data file -- ' end subroutine rdpadx(iou,npack,array,npts) c read complex*16 array from packed-ascii-data file c arguments: c iou unit to read from (assumed open) (in) c npack number of characters to use (determines precision)(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 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iou, npack,npts, ndline, i, istrln, ipts, np, iread double precision unpad, tmpr, tmpi complex*16 array(*) character ctest, ccomp character str*128 external unpad, istrln, iread ccomp = cpadc ipts = 0 np = 2 * npack 10 continue i = iread(iou, str) if (i.lt.0) go to 50 call triml(str) ctest = str(1:1) str = str(2:) ndline = i / 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),npack) tmpi = unpad(str(1-npack+i*np:i*np),npack) array(ipts) = cmplx(tmpr, tmpi) if (ipts.ge.npts) go to 50 30 continue go to 10 50 continue return 200 continue call echo (' -- Read_PAD error: bad data at line:') i = istrln(str) call echo (str(:i)) stop ' -- fatal error in reading PAD data file -- ' end c --padlib-- subroutine pad(xreal,npack,str) c convert dp number *xreal* to packed-ascii-data string *str* c include 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c integer iexp, itmp, isgn, i, npack, iok, j double precision xreal, xwork, xsave double precision tenth, tenmm, half, small parameter (tenth = 0.1d0, tenmm = 0.099999999994d0) parameter (half = 0.5d0, small = 1.d-10 ) character str*(*) c str = ' ' xsave = min(huge, max(-huge, xreal)) isgn = 1 if (xsave.le.0) isgn = 0 c xwork = dabs( xsave ) iexp = 0 if ((xwork.lt.huge).and.(xwork.gt.tiny)) then iexp = 1 + int(log(xwork) / tenlog ) else if (xwork.ge.huge) then iexp = ihuge xwork = one else if (xwork.le.tiny) then xwork = zero end if c force xwork between ~0.1 and ~1 c note: this causes a loss of precision, but c allows backward compatibility xwork = xwork / (ten ** iexp) 20 continue if (xwork.ge.one) then xwork = xwork * tenth iexp = iexp + 1 else if (xwork.le.tenmm) then xwork = xwork * ten iexp = iexp - 1 endif if (xwork.ge.one) go to 20 itmp = int ( ibas2 * xwork ) str(1:1) = char(iexp + ioff + ibas2 ) str(2:2) = char( 2 * itmp + isgn + ioff) xwork = xwork * ibas2 - itmp if (npack.gt.2) then do 100 i = 3, npack itmp = int( base * xwork + small) str(i:i) = char(itmp + ioff) xwork = xwork * base - itmp 100 continue end if if (xwork.ge.half) then i = itmp + ioff + 1 if (i.lt.(ibase+ioff)) then str(npack:npack)= char(i) else j = ichar(str(npack-1:npack-1)) if (j.lt.(ibase+ioff-1)) then str(npack-1:npack-1) = char(j+1) str(npack:npack) = char(ioff) endif endif endif return end c --padlib-- double precision function unpad(str,npack) c c convert packed-ascii-data string *str* to dp number *unpad* c include 'padlib.h' c padlib.h -*-fortran-*- c header of parameters for packed-ascii-data (pad) routines implicit none character cpadr, cpadi, cpadc integer maxlen, ibase, ioff, ihuge, ibas2 double precision ten, tenlog, huge, tiny, one, zero,base parameter(cpadr = '!', cpadc = '$', cpadi = '%') parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82) parameter(ibas2 = ibase/2, zero=0.d0, one=1.d0, ten = 10.d0) parameter(tenlog= 2.302585092994045684d0) parameter(huge = 1.d38, tiny = 1.d-38,base = ibase*one) c double precision sum integer iexp, itmp, isgn, i, npack character str*(*) unpad = zero if (npack.le.2) return iexp = (ichar(str(1:1)) - ioff ) - ibas2 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 = npack, 3, -1 sum = sum + dble(ichar(str(i:i)) - ioff) / base**i 100 continue unpad = 2 * isgn * ibase * sum * (ten ** iexp) cc print*, sum, iexp,unpad return end c --padlib-- c end of pad library c ---------- 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 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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} double precision par, pmax(mpthpr), small, decod parameter (small = 1.d-3) character*20 setchr integer nstart, id, ipath, i, il, inpath, jfeff, juser external decod c these are the magnitudes of the upper limits for "reasonable" c initial values -- they're pretty darn big pmax(jps02) = 1.d6 pmax(jpe0) = 2.d1 pmax(jpdelr) = 5.d-1 pmax(jpsig2) = 3.d-1 pmax(jpei) = 2.d1 pmax(jpdpha) = 1.d2 pmax(jp3rd) = 2.d-1 pmax(jp4th) = 1.d-1 pmax(9) = 1.d0 pmax(10) = 1.d0 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) cc print*, ' JFEFF = ', jfeff, inpath, ipath, id if (jfeff.le.0) then print*, ' jfeff < 0 ' 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 print*, ' parnam: ', i, parnam(i), par 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-------------------------------------------------------------------- c include 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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} integer lenwrk, lenfvc, istrln, im, ier, ierr, ilen, ione integer lminfo, iflag, nfirst, nr1, nr2, mfit, nsigd, ix integer nrwght, irun, iex, id, i, istop, nrmin,nrmax, ind 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 double precision work(lenwrk), fvect(lenfvc), ftemp(lenfvc) double precision xvarys(mvarys), fjac(lenfvc, mvarys) double precision alpha(mvarys, mvarys), toler, tolfac double precision chirhi(maxpts), sumsqr double precision rsmall, stmp, wtmp, xolow, xohigh external fitfun, sumsqr, istrln datafl = .false. tolfac = 1.d-05 lminfo = 0 rsmall = rgrid * 0.01d0 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 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, 60,3 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) = dabs( sigdtk(id)) sigdtr(id) = dabs( 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) = dabs( 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.d-5) 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: cc print*, ' FITNLS ndata = ', ndata, ', nvarys= ', numvar 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 cc print*, 'fitnls: iprint = ', iprint c estimate the uncertainties in parameters call fiterr(fitfun, mfit, numvar, lenfvc, mvarys, fvect, $ ftemp, fjac, alpha, iprint, 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 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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 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) double precision reff, degen, xolow, xohigh double precision tchiqi(maxpts), tchiqr(maxpts) double precision thifit(maxpts) double precision xvar(mvarys), fvec(lenfvc), par(mpthpr) double precision rfact, bvalue, decod external rfact, bvalue, decod 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 cc print*, ' vars: ', xvar(1), xvar(2), xvar(3), nvar 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 cc print*, 'FITFUN B ', id, xolow, xohigh, nfit 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 cc print*, ' FITFUN: path ', idpath, jfeff, reff, 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 cc print*, ' id e0 ', id, par(jpe0) 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) write(ifxvar,*) 'tchiqr(8),tchiqi(8)' write(ifxvar,*) tchiqr(8),tchiqi(8) 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 double precision 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 implicit none integer kmax parameter (kmax = 50) integer jderiv,k,n, i,ilo,imk,j,jc,jcmin,jcmax,jj,kmj,km1,mflag integer nmi,jdrvp1 double precision bcoef(n),t(*),x double precision 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.d0 if (jderiv .ge. k) return 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) return c *** if k = 1 (and jderiv = 0), bvalue = bcoef(i). km1 = k - 1 if (km1 .le. 0) then bvalue = bcoef(i) return end if 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 .lt. 0) then jcmin = 1 - imk do 5 j=1,i dl(j) = x - t(i+1-j) 5 continue do 6 j=i,km1 aj(k-j) = 0.d0 dl(j) = dl(i) 6 continue else do 9 j=1,km1 dl(j) = x - t(i+1-j) 9 continue end if c jcmax = k nmi = n - i if (nmi .ge. 0) then do 19 j=1,km1 dr(j) = t(i+j) - x 19 continue else jcmax = k + nmi do 15 j=1,jcmax dr(j) = t(i+j) - x 15 continue do 16 j=jcmax,km1 aj(j+1) = 0.d0 dr(j) = dr(jcmax) 16 continue end if c do 21 jc=jcmin,jcmax aj(jc) = bcoef(imk + jc) 21 continue c c *** difference the coefficients jderiv times. if (jderiv .ne. 0) then do 24 j=1,jderiv kmj = k-j fkmj = kmj ilo = kmj do 23 jj=1,kmj aj(jj) = ((aj(jj+1) - aj(jj))/(dl(ilo) + dr(jj)))*fkmj ilo = ilo - 1 23 continue 24 continue end if 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). if (jderiv .ne. km1) then jdrvp1 = jderiv + 1 do 34 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)) ilo = ilo - 1 33 continue 34 continue end if bvalue = aj(1) c 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 implicit none integer left,lxt,mflag, ihi,ilo,istep,middle double precision x,xt(lxt) save ilo data ilo /1/ c ihi = ilo + 1 if (ihi .ge. lxt) then if (x .ge. xt(lxt)) go to 110 if (lxt .le. 1) go to 90 ilo = lxt - 1 ihi = lxt c end if 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*16 coni, cp, cp2, cphshf, cdwf, cargu, cchi, ciei double precision chiqr(mchiq), chiqi(mchiq) double precision e0eff, s02r2n, degen, reff, sigma2, third double precision s02, e0shft, e0imag, delpha, deltar double precision first, fourth, r2m2, qgrid, energy, q, tranq double precision expmax, expmin, small, etok, one double precision rep, xlam, cxlam, pha, amp, car double precision ampfef(nffpts), phafef(nffpts) double precision 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* dimag(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, dble(cargu))) cchi = (amp * s02r2n / abs(q)) * $ exp(cmplx(car, dimag(cargu))) c save real and imag chi for this value of q chiqi(i) = dimag(cchi) chiqr(i) = -dble(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, qpc, phapc, mpc, nout, chifit) c 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////////////////////////////////////////////////////////////////////// c c calculate a fft of a function to be minimized in either r or c backtransformed k-space to use as a fitting function, as in c ifeffit. calls routine xafsft which uses the routine cfftf. c c ** cffti must be called prior to this routine ** 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 c implicit none integer mpts, mfft, mpc, ifft, nout, mxmpts, nfft, i, ipos double precision pi, zero, xlow, xhigh parameter (mxmpts = 4096, zero=0.d0, pi = 3.141592653589793d0) double precision chiq(mpts), chifit(mpts),qwin(mpts),rwin(mpts) double precision qweigh, rweigh, qgrid, rgrid, q, pha double precision qpc(mpc), phapc(mpc), wfftc(*) complex*16 cchir(mxmpts), cchiq(mxmpts), coni parameter (coni=(0d0,1d0)) logical pcflg c check that ifft is valid if ((ifft.lt.0).or.(ifft.ge.3)) then call echo('fitfft: ifft out of range.') stop endif cc if (mxmpts.ne.mfft) then cc call echo('fitfft warning: weird number of points') cc print*, mxmpts, mfft cc 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(qpc, phapc, mpc, q, ipos, pha) cchiq(i) = dcmplx(chiq(i), zero) * exp(-coni * pha) 110 continue else do 130 i = 1, nfft cchiq(i) = dcmplx(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 fftout(mpts, xdat, dx, 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*16 xdat(mpts) double precision xout(npts), dx, dxi, xlo, xhi, small, tiny parameter (tiny = 1.d-8, small = 1.d-2) c dxi = 1 / max(tiny, dx) 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) = dble (xdat( nmin + i )) xout(2*i ) = dimag(xdat( nmin + i )) 50 continue return c end subroutine fftout 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 double precision wfftc(*), wa(*), xwgh, dx, xgrid double precision sqrtpi, eps7, eps4 complex*16 chip(*), chiq(*), cnorm parameter(sqrtpi = 0.5641895835d0, eps7=1.d-7, eps4=1.d-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.d0,0.d0) if (jfft.lt.0) cnorm = 2 * cnorm if (jfft.eq.0) cnorm = (1.d0,0.d0) 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 lm_err(info,toler) c c write out lm_info message after fit with lmdif1 c m newville: relies on external istrln and echo routines character*128 messg double precision toler integer info, im, istrln external istrln if (info.eq.0) then call echo(' '// $ 'fit gave an impossible error message.') elseif ( (info.ge.4).and.(info.le.7)) then call echo(' fit gave a warning message:') if (info.eq.4) then call echo(' one or more '// $ 'variables may not affect the fit.') elseif (info.eq.5) then call echo(' too many fit '// $ 'iterations. try again with better ') call echo(' guesses or '// $ 'a simpler problem.') elseif ((info.eq.6).or.(info.eq.7)) then call echo(' "toler" can probably be '// $ 'increased without a loss of') write(messg, '(a,e13.5)' ) ' fit quality. '// $ 'current value is: toler = ', toler im = istrln(messg) call echo(messg(:im)) endif end if return 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) double precision tol double precision 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 double precision 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 double precision epsfcn,factor,ftol,gtol,xtol,zero data factor,zero /1.0d2,0.0d0/ 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) double precision ftol,xtol,gtol,epsfcn,factor double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n) double precision 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 double precision 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,max,min,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 double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm double precision one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio double precision sum,temp,temp1,temp2,xnorm,zero double precision spmpar,enorm c#mn{ double precision xiter c#mn} external spmpar, enorm data one,p1,p5,p25,p75,p0001,zero * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ 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#mn{ c print message to let user know that routine is running xiter = iter call setsca('&fit_iteration', xiter) if (mod(iter,25).eq.0) call echo(' fitting ...') c#mn} 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 = max(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) = max(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 = min(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*min(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 subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, * wa2) integer n,ldr integer ipvt(n) double precision delta,par,wa1(n),wa2(n) double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(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,max,min,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 double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001 double precision spmpar,enorm,sum,temp,zero data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ 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/min(delta,p1) c c if the input par lies outside of the interval (parl,paru), c set par to the closer endpoint. c par = max(par,parl) par = min(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 = max(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 = max(parl,par) if (fp .lt. zero) paru = min(paru,par) c c compute an improved estimate for par. c par = max(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 double precision 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 ... max,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 double precision ajnorm,epsmch,one,p05,sum,temp,zero double precision spmpar,enorm data one,p05,zero /1.0d0,5.0d-2,0.0d0/ 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(max(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) double precision 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 double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ 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 subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) integer m,n,ldfjac,iflag double precision epsfcn double precision 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 double precision 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,max,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 double precision eps,epsmch,h,temp,zero double precision spmpar data zero /0.0d0/ c c epsmch is the machine precision. c epsmch = spmpar(1) c eps = sqrt(max(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 double precision function enorm(n,x) integer n double precision 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 double precision 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 double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs double precision x1max,x3max, zero data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ 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 double precision function spmpar(i) integer i double precision rmach(3) c ********** c c function spmpar c c*************************************************************** cc rewritten to eliminate machine dependence of precision 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 double precision 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 ********** data rmach(1), rmach(2), rmach(3) /1.d-07,1.d-20,1.d+20/ spmpar = rmach(i) return c c last card of function spmpar. c c end function spmpar end subroutine fiterr(fcn,nfit,nvar,mfit,mvar,fbest,ftemp,fjac, $ alpha,jprint,istep,x,delta,correl,ierror,iflag) c 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////////////////////////////////////////////////////////////////////// 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 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 jprint integer print flag 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 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-------------------------------------------------------------------- implicit none integer mfit,mvar,nfit,nvar,i,k,j,iloop,istep, istepx integer iflag(mvar), ierror, jprint, ier double precision fbest(mfit), ftemp(mfit), fjac(mfit,mvar) double precision x(mvar), correl(mvar,mvar), alpha(mvar,mvar) double precision delta(mvar), delx, sum, tempx double precision eps, epsdef, tiny, zero character messg*64 parameter (zero = 0.d0, epsdef = 1.d-2, tiny= 1.d-10) external fcn, gaussj c if (jprint.ge.1) call echo( '>>>> fiterr start') istepx= min(5,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) / max(tiny, abs(tempx)) if (iloop .eq. 1) eps = epsdef delx = max( tiny, eps * abs(tempx) ) x(j) = tempx + delx if (jprint.ge.1) then write(messg,'(1x,a,2g14.7)') ' >> ',tempx,delx call echo (messg) end if if (jprint.ge.1) call echo ( '>>>> call fcn' ) call fcn(nfit, nvar, x, ftemp, ier) if (ier .lt. 0) then if (jprint.ge.1) call echo ( '>>>> fcn died') go to 65 end if 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 (jprint.ge.2) then call echo ( ' curvature matrix: 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 (jprint.ge.2) then write(messg,'(8xx,2i3,g14.7)') j , k , alpha(j,k) call echo (messg) end if 160 continue 180 continue c c in case alpha cannot 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. do 250 i = 1, nvar iflag(i) = 0 if (abs(alpha(i,i)).le. tiny) iflag(i) = 1 250 continue c invert curvature (alpha) to give covariance matrix. gaussj does c gauss-jordan elimination in-place, and dies with garbage in alpha c if the matrix is singular. if (jprint.ge.1) call echo(' fiterr-> call gaussj') call gaussj(alpha,nvar,mvar,ier) if (jprint.ge.1) call echo(' fiterr-> gaussj returned') if (ier.ne.0) then ierror = 1 if (jprint.ge.1) then call echo (' FITERR: cannot invert curvature matrix!') end if 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 (jprint.ge.1) then call echo (' fiterr done with loop: j , delta(j)' ) end if do 360 i = 1, nvar delta(i) = max(tiny, sqrt( abs( alpha(i,i)) )) if (jprint.ge.1) then write (messg,'(1x,i3,g15.7)') i, delta(i) call echo( messg) end if 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 (jprint.ge.1) call echo ( '>>>> fiterr done') return c end routine fiterr 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 -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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} character*40 logfil, stat*7, outstr*128 double precision par(mdpths, mpthpr), rfmin, rfave double precision redchi, sqrchi, order, small, ten double precision tmp1(mvarys**2), tmp2(mvarys**2) double precision decod, reff,corr, xnu integer ilog, i, istrln, nstart,id,ilo,inpath integer idpath,im,ipath,juser,jfeff,ind, nvr1, nvr2 integer jlen, ntmp, n, nv, ilen, iex, ierr, idot parameter ( rfmin =0.05d0, small = 1.d-5, ten = 10.d0) external decod, istrln c---------------------------------------------------------------------- c winstr(1) = 'hanning window sills' c winstr(2) = 'hanning window fraction' c winstr(3) = 'gaussian window' c winstr(4) = 'lorentzian window' c winstr(5) = 'parzen window ' c winstr(6) = 'welch window ' c winstr(7) = 'sine window ' c winstr(8) = 'gaussian window (2nd form)' stat = 'unknown' 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##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= '//sqwin(id) 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= '//srwin(id) endif write(ilog,9055) 'number of points in fft for fitting = ',mftfit write(ilog,9055) 'number of points in fft for outputs = ',mftfit 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 = dabs(log(dabs( 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 sort2(n, ra, rb) c heap sort real array ra of length n to ascending order, c and make the corresponding rearrangement to rb. implicit none integer n, l, ir, i, j double precision ra(*), rb(*), xa, xb 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 integer function sort_xy(e, x, n, delta) c c check and sort a pair of energy/xmu data to c ensure that energy is monotonically increasing c c returns 0 for data that needs no sort or rearrangement c 1 if sorting or rearrangement were needed implicit none double precision e(*), x(*), de, delta, dm integer n, i, k, j logical sort, near sort = .false. near = .false. cc print*, ' in sort_xy ' c first, look for problems do 10 i = 1, n-1 de = e(i+1)-e(i) if (de.lt.0) sort = .true. if (abs(de).lt.delta) near = .true. 10 continue c cc print*, ' in sort_xy ', sort, near c if needed, sort if (sort) call sort2(n, e, x) c if needed, remove (by averaging) coincident points if (near) then cc print*, ' sort_xy near!! ', n, delta k = 0 i = 1 dm = delta*100 50 continue de = e(i+1)-e(i) cc print*, ' i, de = ', i, n, de, dm if (abs(de).lt.delta) then k = k + 1 e(i) = (e(i) + e(i+1)) / 2 x(i) = (x(i) + x(i+1)) / 2 do 80 j = i+1, n-1 e(j) = e(j+1) x(j) = x(j+1) 80 continue e(n) = e(n-1) + 1. x(n) = x(n-1) + 1. else i = i + 1 endif if (i.lt.n) go to 50 n = n - k end if cc print*, ' sort_xy: ', n sort_xy = 0 if (sort.or.near) sort_xy = 1 return 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 'fitcom.h' c{fitcom.h -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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} integer i, j, k, idp, iex, ierr, ilen, istrln integer nstart, id, idpath, inpath, jfeff, juser,n character outstr*128, fil*128, stat*10 double precision tiny, scale, oldval, two, decod, eval double precision dvdx(maxval,mvarys), dpdx(mpthpr,mvarys) double precision par(mpthpr), dpar(mpthpr), rfave, reff double precision redchi, sum, dx, pold, thous, xnu, degen parameter (tiny = 1.0d-10, two = 2.d0) parameter (thous = 0.001d0) 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(dabs(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## " name = x1 % +/- % x2 " c ifmt=1 -> " name i1 x1 % +/- % x2 " character name*(*) double precision x1, x2, ten, order, tiny parameter (ten = 10.d0, tiny = 1.d-8) integer ilen, istrln, iout, ifmt, mlen, i1 external istrln ilen = max(mlen, istrln(name)) order = dabs(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 -*-fortran-*- c common blocks for feffit implicit none c include 'const.h' c{const.h: constants & parameters for feffit -*-fortran-*- integer maxpts, mpaths, mdpths, mftfit 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) parameter(mftfit = 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: double precision etok, zero, one, qgrid, pi, rgrid parameter(zero=0.d0,one=1.d0, qgrid =0.05d0) parameter(etok =0.2624682917d0, pi = 3.141592653589793d0) parameter(rgrid = 20 * pi /mftfit) 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 double precision degpth(mfffil), refpth(mfffil) double precision qfeff(mffpts, mfffil) double precision theamp(mffpts, mfffil), thepha(mffpts, mfffil) double precision cphase(mffpts, mfffil), sphase(mffpts, mfffil) double precision realp( mffpts, mfffil), xlamb( mffpts, mfffil) double precision rwgpth(mfffil), ratpth(3, 0:maxleg, mfffil) common /ffidat/ ixpath, nlgpth, izpth, iptpth, iffrec common /ffddat/ rwgpth, degpth, refpth, ratpth, theamp, $ thepha, qfeff, realp, xlamb c fefdat.h} c include 'chars.h' c{chars.h: -*-fortran-*- c 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: -*-fortran-*- c numbers and integer codes for math expressions in feffit double precision defalt(mpthpr), consts(mconst) double precision 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 /math_i/ icdpar, icdval, icdloc, jdtpth, jdtusr, jpthff common /math_d/ defalt, consts, values, delval c math.h} c include 'varys.h' c{varys.h -*-fortran-*- c values for variables of fit and error analysis in feffit c (nmathx = number of user defined math expressions) double precision xguess(mvarys), xfinal(mvarys), delta(mvarys) double precision 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: -*-fortran-*- c parameters for fourier transforms in feffit double precision wfftc(4*maxpts + 15) double precision qwin1(mdata), qwin2(mdata) double precision rwin1(mdata), rwin2(mdata), rweigh(mdata) double precision qweigh(mdata), qmin(mdata), qmax(mdata) double precision rmin(mdata), rmax(mdata) integer nqfit(mdata), nqpts(mdata), nrpts(mdata) integer iqwin(mdata), irwin(mdata), ifft(mdata) integer jffphs(mdata) character*32 sqwin(mdata), srwin(mdata) common /fft/ nqpts, iqwin, qmin, qmax, qwin1, qwin2, qweigh, $ nrpts, irwin, rmin, rmax, rwin1, rwin2, rweigh, $ nqfit, ifft, jffphs, wfftc common /ffts/ sqwin, srwin c fft.h} c include 'data.h' c{data.h -*-fortran-*- c data and fitting numbers in feffit double precision chiq(maxpts,mdata) double precision thiq(maxpts,mdata),thiqr(maxpts,mdata) double precision qwindo(maxpts,mdata), rwindo(maxpts,mdata) double precision q1st(mdata), qlast(mdata) double precision chifit(maxpts, mdata), xnidp double precision sigdtr(mdata),sigdtk(mdata),sigdtq(mdata) double precision xinfo(mdata),chi2dt(mdata),rfactr(mdata) double precision sigwgt(mdata),weight(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 -*-fortran-*- c background removal parameters in feffit... integer mtknot, korder, nbkg(mdata) parameter (mtknot = 30, korder = 4 ) logical bkgfit(mdata), bkgout, bkgdat(mdata) double precision qknot(mtknot,mdata) double precision rbkg(mdata), bkgq(maxpts,mdata) common /bkg_l/ bkgfit, bkgdat, bkgout, nbkg common /bkg_d/ qknot, rbkg, bkgq c bkg.h} c include 'inout.h' c{inout.h -*-fortran-*- c miscellaneous input/output stuff in feffit double precision 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} integer lenfvc, istrln, juser, j,labl, ntitle integer jofl, ipre, ilen, ixs, iexist, im, iend, mftsav integer i, mfit, id, ibscf, jtmp, idoc, j0, nqdata integer jfeff, jtitle, ix, inpath, idpath, ititle integer jdd, nstart, jlen double precision reff, degen, rsmall parameter(lenfvc = mdata*maxpts) character*128 outksp, outrsp, outenv, outpre character*10 skyk, skyr, skyq, sdelim character*100 outdoc(maxdoc) double precision xbest(mvarys), temp(lenfvc) double precision par(mpthpr), qhi, decod, bvalue integer imxpre external istrln, bvalue, decod parameter (qhi = 20.d0, j0 = 0) parameter ( 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 rsmall = rgrid * 0.01d0 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) 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(srwin(id), rwin1(id), $ rwin2(id), rmin(id), rmax(id), rgrid, $ maxpts, 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,mftfit,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)) cc print*, ' 3' c------------------------------------------------------------------ c output for full theory chi c c output documents call triml(titles(1,id)) outdoc(1) = 'feffit result: '//titles(1,id) if (sqwin(id).eq.'fha') then write(outdoc(2),9220) qmin(id), qmax(id), $ qweigh(id), qwin1(id) elseif (sqwin(id).eq.'han') 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), sqwin(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,mftfit,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,mftfit,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,mftfit,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,']; window=',a) 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 implicit none integer ipos, mxmpts integer maxpts, i, nqout, nqouth, nqoutl, nkyout, nrout,ndocx double precision qouthi, qoutlo, qsmall, qgrid double precision rsmall, rgrid, rlast integer nfft, iexist, ndoc, mfft, mfeff double precision zero, pi, q, pha parameter (maxpts = 2048, mxmpts=2048) parameter (zero = 0.d0, pi = 3.141592653589793d0) character*128 filchi, filrsp, filenv, cmt*2 character*100 doc(*) character*5 skychi, skyrsp, skyenv, format*10, type*10 double precision chiq(mfft), chiqr(mfft), wfftc(4*mfft+15) double precision rwind(mfft), qwind(mfft), rweigh, qweigh double precision xdata(maxpts), yreal(maxpts), yimag(maxpts) double precision yphas(maxpts), yampl(maxpts) double precision qfeff(mfeff), phafef(mfeff) complex*16 cchiq(mxmpts), cchir(mxmpts), coni parameter (coni = (0.d0,1.d0)) 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) = dble ( cchir(i)) yimag(i) = dimag( 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) = dble ( cchiq(i+nqoutl)) yimag(i) = dimag( 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 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