program autobk c c autobk version 2.93a 14-May-2001 c c author Matthew Newville, The University of Chicago c e-mail newville@cars.uchicago.edu 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 c further information on this code is available at c http://cars.uchicago.edu/~newville/autobk/ c c --- copyright 1998,1999 matt newville c --- copyright 1995 matt newville, university of washington c c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c c autobk removes the background of x-ray-absorption fine-structure c data. a spline function is used to approximate the background. c the spline is chosen so that the resulting chi is optimized at c low-r. the optimization minimizes the difference between the c data and a standard chi(r) at low-r. the standard is used to c estimate the leakage form the first shell into the low-r region, c and since this leakage is a small portion of the first shell, the c standard does not need to be an extremely accurate estimate of c the true first shell. the standard chi should be a chi for which c the background is trusted, and can be either a theoretical c calculation or an experimental standard. if no standard chi is c specified, the low-r components of chi(r) will be minimized. c c major revisions (for a complete revision record, contact matt) : c c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} c------------------------------------------------------------------ c local variables character system*10 logical first, domore, dorun integer iinpf, ilogf, ilen, istrln external istrln data first, domore, dorun /.true.,.true.,.true./ data iinpf, ilogf / 2, 4/ data system /'linux'/ c system options: 'unix','vax','dos','mac' call setsys(system,vaxflg,dosflg,macflg,lnxflg) c version & date call echo_init ilen = max(1,istrln(system)) versn = ' autobk: 2.93a 14-May-2001 ('//system(:ilen)//')' ilen = istrln(versn) call echo(versn(1:ilen)) c------------------------------------------------------------------ c loop for each different running of program 100 continue c initialize variables in common blocks, open files call autint c read input file call autinp(iinpf, ilogf, first, domore, dorun) if (dorun) then c read in data, subtract pre-edge, reset fitting ranges, etc call autdat c do nonlinear least-square fittings for background, and c possibily e0 and amplitude of theory. call autnls c write out results to log file call autlog(ilogf) c write out data results to data files call autout end if c continue on to next data set if (domore) go to 100 c---------------------------------------------------------------- c finished: close files, and give happy ending message close(iinpf) close(ilogf) call echo( ' autobk is finished.') call echo( ' have a nice day.') c end main program autobk end subroutine autdat c c this routine reads all input data files for the progam autobk. c the xmu data file is opened, the pre-edge is removed, and the c standard chi data (if used) is read. the routine inpdat is c used for all data files, allowing either uwexafs binary or c ascii column data to be used. c c copyright 1992 university of washington : matt newville c----------------------------------------------------------------------- c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} c local variables character ftype*5, frmthe*10 double precision qtemp (maxpts), chitmp(maxpts), small double precision q, rgrid, rsmall, rtemp double precision dummy1(maxpts), dummy2(maxpts) double precision dummy3(maxpts), xmuraw(maxpts) parameter (small = 1.d-10) integer ndocln, i, nxx, ipos, nemin, nemax, nofx c-------------------------------------------------- if (xmuf.eq. ' ') then call echo(' autobk error: no input xmu data'// $ ' file name given.') stop end if c c get xmu data, do pre-edge and normalization, and store the c modified xmu values in xmudat. ndocln = maxdoc nxmu = maxpts ftype = 'xmu' call inpdat( ftype, frminp, xmuf, vaxflg, skeyxm, $ nkeyxm, ndocln, xmudoc, nxmu, energy, $ xmuraw, dummy1, dummy2, dummy3) c c simple kludge to allow columnd 3,4,5 to be used as xmuraw: if ((imucol.ge.3).and.(imucol.le.5)) then if (imucol.eq.3) then do 22 i = 1, nxmu xmuraw(i) = dummy1(i) 22 continue elseif (imucol.eq.4) then do 23 i = 1, nxmu xmuraw(i) = dummy2(i) 23 continue elseif (imucol.eq.5) then do 24 i = 1, nxmu xmuraw(i) = dummy3(i) 24 continue endif endif c c remove pre-edge, get edge step nnorm = 2 call preedg(eefind, stfind, nxmu, energy, xmuraw, ee, $ predg1, predg2, enor1, enor2, nnorm, $ step, slopre, bpre,cnorm) step = max(step, small) if (funnrm) step = one c set background equal to xmu do 50 i = 1, nxmu xmudat(i) = xmuraw(i) - slopre * energy(i) - bpre spline(i) = xmudat(i) 50 continue c c get theory from a 'chi' file c if theory is not given thiq is filled with 0.0 ntheor = 1 qtemp(1) = zero if (theory) then ndocln = maxdoc ntheor = maxpts ftype = 'chi' c frmthe = frminp frmthe = ' ' call inpdat(ftype, frmthe, theorf, vaxflg, skeyth, $ nkeyth, ndocln, thedoc, ntheor, qtemp, $ chitmp, dummy1, dummy2, dummy3) end if nxx = min(maxpts, 10 + int (qtemp(ntheor) / qgrid)) ipos = 1 do 200 i = 1, nxx q = i*qgrid if ( (q.lt.qtemp(1)).or.(q.ge.qtemp(ntheor)) ) then thiq(i) = zero else call lintrp ( qtemp, chitmp, ntheor, q, ipos, thiq(i) ) end if 200 continue c----------------------------------------------------------------------- c move emin and emax to values on the energy grid emin = emin + ee emax = emax + ee if (emax.le.emin) emax = energy(nxmu) nemin = nofx(emin,energy,nxmu) nemax = nofx(emax,energy,nxmu) emin = energy(nemin) emax = energy(nemax) c----------------------------------------------------------------------- c put r values on rgrid, get npts numbers if (r1st.le.rbkg) r1st = rbkg + 2.0 rgrid = pi / (qgrid * mftfit) rsmall = rgrid / 100.0 rbkg = rgrid * int( (rbkg + rsmall) / rgrid ) r1st = rgrid * int( (r1st + rsmall) / rgrid ) if (rbkg.gt.r1st) then rtemp = rbkg rbkg = r1st r1st = rtemp end if nrbkg = 2 * int((rbkg + rsmall)/rgrid) + 2 nrpts = 2 * int((r1st + rsmall)/rgrid) + 2 nr1st = nrpts - nrbkg if (nxmu.le.4) then call echo(' autobk error: data file empty, or not'// $ ' enough data points') call echo(' the data file may need # signs for'// $ ' comment lines.') stop end if c done return c end subroutine autdat end subroutine autfun(mf,nx,xv,ffit,iend) c c evaluate a function for lmdif1, a non-linear least squares c levenburg-marquardt algorithm. c c evaluate the difference between the fft of the theory and the c post-background-subtraction chi data for changing b-spline c coefficients. c c xv(1) to xv(nsplin) are the b-spline coefficients c c also allow e0 shift of the data and modification of c theory by overall amplitude and s02. c c copyright 1992 university of washington : matt newville c c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} integer ifft, nx, mf, iend, nvtmp, i integer nqmin, nqmax, nmaxx, ipos double precision small, half, widmin, bvalue, sumsqr parameter (half = 0.5d0, small = 1.d-10, widmin = 0.5d0) parameter (ifft = 1) double precision xv(*), ffit(*), qtmp(maxpts), chie(maxpts) double precision chifit(maxpts), qtt, e0 external bvalue, sumsqr save c cc print*, '>> autfun ', mf, nx, mfit, nvarys cc nvarys = nx cc mfit = mf if (nx.ne.nvarys) iend = 1 if (mf.ne.mfit) iend = 2 nvtmp = nvarys c c unwrap list of possible variables: c the last on the list from autnls is the first off if (theory.and.eevary) then e0shft = xv(nvtmp) nvtmp = nvtmp - 1 end if if (nvtmp.ne.nsplin) iend = 3 c c do e0 shifting to temporary q-array for interpolation, c evaluate the spline and normalize to get chie c normalize e0 = ee + e0shft cc print*, ' e0 = ', e0, e0shft cc print*, ' -------------------' cc print*, ' nvarys = ', nx, nvarys, mf cc print*, ' varys = ', xv(1), xv(2), xv(3), xv(4), xv(5) do 200 i = 1, nxmu qtmp(i) = sqrt(etok * abs(energy(i)-e0) ) if (energy(i).lt.e0) qtmp(i) = - qtmp(i) if ( (energy(i).le.emax).and.(energy(i).ge.emin) ) then spline(i) = bvalue(eknot,xv,nsplin,korder,energy(i),0) chie(i) = ( xmudat(i) - spline(i) ) / step if (funnrm) $ chie(i) = ( xmudat(i) /max(spline(i), small)) - one else chie(i) = zero end if 200 continue c get qmax and qmin from the energy values nqmin = int( sqrt( etok* abs(emin - e0) ) / qgrid ) nqmax = int( sqrt( etok* abs(emax - e0) ) / qgrid ) if ((emin.lt.e0).or.(nqmin.lt.1)) nqmin = 1 c interpolate chiq to q grid, evaluate chiq, the data chi nmaxx = min(maxpts, nqmax + 20) ipos = 1 cc print*, ' autfun ', nqmax, nmaxx, nqmin, emin, emax, nterp do 300 i = 1, nmaxx if ( (i.lt.nqmin).or.(i.gt.nqmax) ) then chiq(i) = zero else qtt = (i-1) * qgrid if (final) then if (nterp.eq.1) then call lintrp(qtmp, chie, nxmu, qtt, ipos, chiq(i)) else call qintrp(qtmp, chie, nxmu, qtt, ipos, chiq(i)) end if else call qintrp(qtmp, chie, nxmu, qtt, ipos, chiq(i) ) end if end if 300 continue c get real and imaginary parts of the fft of data chiq cc print*, 'autfun qgrid = ', qgrid, r1st, ifft, nrbkg, theamp call fitfft(chiq, maxpts, mftfit, wfftc, qgrid, $ windo, qweigh, windo, one, ifft, zero, r1st, $ pcflg, qfeff, phafef, mfeff, nrpts, chifit) cc print*, ' mpts: = ', mftfit, maxpts, nrpts c c find amplitude scale for theory so that it matches the c data over the first shell. this sets theamp to the ratio c of the power-spectral-densities of the first shell xafs for c the theory and data chiq. if (.not.thefix) theamp = sumsqr(chifit(nrbkg),nr1st) / $ thessq c there are nrbkg points in the low-r region c there are nr1st points in the first shell region c there are nrpts points total c add r-weighting to bkg removal. c note that rwgt is converted to integer, and that the real and c imaginary portions are weighted equally by using integer arithmetic. cc print*, chifit(1), chifit(7), chifit(17), chifit(22) do 550 i = 1, nrbkg ffit(i) = chifit(i) - thifit(i) * theamp 550 continue cc print*, 'AUTFUN end: ', mf, nx return c end subroutine autfun end subroutine autinp(iinp, ilog, first, domore, dorun) c c read inputs for the autobk program. c the input parameters are read using keywords from the input c given by iounit. the xmu data file is opened, the pre-edge c is removed, and the standard chi data (if used) is read. the c routine inpdat is used for all data files, allowing either c uwexafs or ascii column data. c c notes c 1. the case as the word "case" at the top of the routine sets c the case of all character strings in this routine. be careful c when editing this file. c c copyright 1992 university of washington : matt newville c----------------------------------------------------------------------- c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} c----------------------------------------------------------------------- c local variables integer mfil, iinp, nline, ilen, istrln, nwords integer ilog, idot, maxwrd parameter (mfil = 10, maxwrd = 20) integer i, iwrds, i2, ix, i3, jinit integer ierr, ier, iw, is, iii, ii, iargc character*128 str, string, strdat, messg, logfil, stat*10 character*128 keywrd, words(maxwrd), wrdsor(maxwrd), key*3 logical domore, dorun, errskp, first, exist external istrln, iargc c--------------------------------------------------------------------- c initialize local variables domore = .false. dorun = .false. jinit = 1 nline = 1 c c if first time through, find a version of the input file c and open it: check upper and lower case if (first) then jinit = -1 exist = .false. ier = 0 stat = 'old' string = 'autobk.inp' c#linux if (lnxflg) then if (iargc().ge.1) then call getarg(1,str) call triml(str) if (istrln(str).ge.1) string = str end if end if c#linux c#mac cc if (macflg) then c# the following code can be used with the LS Fortran Compiler c# thanks to boyan boyanov for this code cc open(unit=iinp,file=*,status='old',iostat=ier) cc if (ier.ne.0) then cc call AlertBox('File selection was canceled!') cc go to 1010 cc end if cc call f_setvolume(jvrefnum(iinp)) cc call f_creator('ttxt') cccc this resets fname to the name of the opened file. this may be useful cccc for computing output file names, etc. cc inquire(unit=iinp,name=string,iostat=ier) cc if (ier.ne.0) string='autobk.inp' c#mac cc end if c now open log file stat = 'unknown' logfil = 'autobk.log' if (string.ne.'autobk.inp') then call triml(string) idot = max(1,istrln(string)) if (index(string(1:idot),'.').ne.0) then 15 continue if (index(string(idot:idot),'.').eq.0) then idot = idot - 1 go to 15 end if end if logfil = string(1:idot) //'log' end if open(unit=ilog, file=logfil, status=stat, err=1020) write(ilog,'(2x,2a)') ' ----------------------- automatic', $ ' background removal-----------------------' ilen = max(1, istrln(versn)) write(ilog,'(2x,a)') versn(1:ilen) c initialize wfftc array if this the first time through. c this array will remain unchanged throughout the running c of the program. note that mftfit = 1024 implies that c k cannot be larger than 51.2 A^-1, and that the spacing c between points in r-space will be 0.061A c cc mftfit = 1024 mftfit = 2048 call cffti(mftfit, wfftc) first = .false. end if c c c----------------------------------------------------------------------- c read inputs from command file with keywords c----------------------------------------------------------------------- c autobk.inp has already been opened as unit #1 180 format(a) 200 continue errskp = .false. str = ' ' keywrd = ' ' key = ' ' call getcom(jinit,string) call fixstr(string,str,ilen,words,wrdsor,maxwrd,nwords) if (ilen.lt.2) go to 200 nline = nline + 1 c c if line of minus signs is read, suspend reading of input file c until next data set if ((str.eq.'getcom_end').or.(str(2:5).eq.'----')) go to 500 if (str.eq.'getcom_nofile') go to 1000 if (str.eq.'getcom_error') go to 1030 c c interpret current words 300 continue if (nwords.le.0) go to 200 keywrd = words(1) key = keywrd(1:3) iwrds = 2 c c----read keywrd and get the right value if ( (key.eq.'tit').or.(key.eq.'com') ) then call triml(wrdsor(2)) if (wrdsor(2).ne.' ') then i2 = max(1, istrln(wrdsor(2))) ix = index( string,wrdsor(2)(:i2) ) commnt = string(ix:) end if go to 200 elseif ( (keywrd.eq.'data').or.(keywrd.eq.'xmu') ) then i2 = max(1, istrln(wrdsor(2))) errskp = .true. if (nwords.ge.3) then i3 = max(1, istrln(wrdsor(3))) strdat = wrdsor(2)(:i2+2)//wrdsor(3)(:i3) call filrec(strdat, xmuf, skeyxm, nkeyxm) else xmuf = wrdsor(2) nkeyxm = 0 skeyxm = ' ' end if dorun = .true. elseif( (keywrd(1:4).eq.'theo') $ .or.(keywrd(1:4).eq.'stan') ) then i2 = max(1, istrln(wrdsor(2))) errskp = .true. theory = .true. if (nwords.ge.3) then i3 = max(1, istrln(wrdsor(3))) strdat = wrdsor(2)(:i2+2)//wrdsor(3)(:i3) call filrec(strdat, theorf, skeyth, nkeyth) else theorf = wrdsor(2) nkeyth = 0 skeyth = ' ' end if elseif ((key.eq.'out').or.(keywrd.eq.'chi')) then chif = words(2) elseif ((keywrd.eq.'form').or.(keywrd(1:5).eq.'forma')) then frminp = words(2) frmout = frminp elseif (keywrd.eq.'formin') then frminp = words(2) elseif (keywrd.eq.'formout') then frmout = words(2) c --energy values elseif((key.eq.'ee').or.(key.eq.'e0')) then call str2dp(words(2), ee, ierr) eefind = .false. elseif ((key.eq.'eef').or.(key.eq.'e0f')) then call str2dp(words(2), ee, ierr) eevary = .false. eefind = .false. elseif (keywrd.eq.'fixe0') then call str2lg(words(2), eevary, ier) eevary = .not.eevary elseif ((keywrd.eq.'thefix').or.(keywrd.eq.'fixthe')) then call str2lg(words(2), thefix, ier) elseif (keywrd.eq.'fixamp') then call str2lg(words(2), thefix, ier) elseif ((keywrd.eq.'predg1').or.(keywrd.eq.'pre1')) then call str2dp(words(2), predg1, ierr) elseif ((keywrd.eq.'predg2').or.(keywrd.eq.'pre2')) then call str2dp(words(2), predg2, ierr) elseif (keywrd.eq.'nterp') then call str2in(words(2), nterp, ierr) elseif (keywrd.eq.'nnorm') then call str2in(words(2), nnorm, ierr) elseif (keywrd.eq.'nor1') then call str2dp(words(2), enor1, ierr) elseif (keywrd.eq.'nor2') then call str2dp(words(2), enor2, ierr) elseif ((key.eq.'ste').or.(key.eq.'edg')) then call str2dp(words(2), step, ierr) stfind = .false. elseif (keywrd(1:4).eq.'emin') then call str2dp(words(2), emin, ierr) elseif (keywrd(1:4).eq.'emax') then call str2dp(words(2), emax, ierr) elseif ((key.eq.'kmi').or.(key.eq.'qmi')) then call str2dp(words(2), qmin, ierr) emin = qmin**2 / etok elseif ((key.eq.'kma').or.(key.eq.'qma')) then call str2dp(words(2), qmax, ierr) emax = qmax**2 / etok elseif (keywrd(1:5).eq.'mucol') then call str2in(words(2), imucol, ierr) c c-fourier transform elseif ((key(1:2).eq.'kw').or.(key(1:2).eq.'qw') $ .or.(key.eq.'w')) then call str2dp(words(2), qweigh, ierr) elseif ((key.eq.'dk1').or.(key.eq.'dq1') ) then call str2dp(words(2), windo1, ierr) elseif ((key.eq.'dk2').or.(key.eq.'dq2') ) then call str2dp(words(2), windo2, ierr) elseif ((key.eq.'dk').or.(key.eq.'dq') ) then call str2dp(words(2), windo1, ierr) windo2 = windo1 elseif (key.eq.'han') then call str2dp(words(2), windo1, ierr) iwindo = 1 winstr = 'hanning' elseif (key.eq.'win') then if (words(2)(1:3).eq.'han') then winstr = 'hanning' iwindo = 1 elseif (words(2)(1:3).eq.'gau') then winstr = 'gaussian' iwindo = 2 elseif (words(2)(1:3).eq.'kai') then winstr = 'kaiser' iwindo = 3 elseif (words(2)(1:3).eq.'par') then winstr = 'parzen' iwindo = 4 elseif (words(2)(1:3).eq.'wel') then winstr = 'welch' iwindo = 5 end if elseif (keywrd(1:4).eq.'iwin') then call str2in(words(2), iwindo, ierr) elseif ( (key.eq.'rma').or.(key.eq.'rbk') ) then call str2dp(words(2), rbkg, ierr) elseif (key(1:2).eq.'r1') then call str2dp(words(2), r1st, ierr) c - -fourier transform, c - -fit, normalization flags elseif (keywrd.eq.'nknots') then call str2in(words(2), nsplin, ierr) gvknot = .true. elseif ((keywrd.eq.'norm').or. $ (keywrd(1:4).eq.'nor ')) then if (words(2)(1:3).eq.'fun') funnrm = .true. if (words(2)(1:3).eq.'bkg') funnrm = .true. if (words(2)(1:3).eq.'ste') funnrm = .false. if (words(2)(1:3).eq.'edg') funnrm = .false. if (words(2)(1:3).eq.'num') funnrm = .false. iwrds = 3 c - -output flags elseif (keywrd.eq.'toler') then call str2dp(words(2), usrtol, ierr) elseif ((keywrd.eq.'stiff').or.(keywrd.eq.'spstep')) then call str2dp(words(2), spstep, ierr) elseif (keywrd.eq.'iprint') then call str2in(words(2), iprint, ierr) elseif ((keywrd.eq.'preedge_out').or. $ (keywrd.eq.'preout')) then call str2lg(words(2), preout, ier) nrmout = preout elseif ((keywrd.eq.'norm_out').or. $ (keywrd.eq.'nrmout')) then call str2lg(words(2), nrmout, ier) elseif ((keywrd.eq.'eshift_out').or. $ (keywrd.eq.'eshout')) then call str2lg(words(2), eshout, ier) elseif ((keywrd.eq.'bkgout').or.(keywrd.eq.'bkgxmu')) then call str2lg(words(2), bkgxmu, ier) elseif ((keywrd.eq.'bkgksp').or.(keywrd.eq.'bkgchi')) then call str2lg(words(2), bkgchi, ier) elseif (keywrd.eq.'bkgrsp') then call str2lg(words(2), bkgrsp, ier) elseif ((keywrd.eq.'theksp').or.(keywrd.eq.'thechi')) then call str2lg(words(2), thechi, ier) elseif (keywrd.eq.'thersp') then call str2lg(words(2), thersp, ier) elseif((keywrd.eq.'chirsp').or.(keywrd.eq.'datrsp')) then call str2lg(words(2), chirsp, ier) elseif (key.eq.'all') then call str2lg(words(2), chirsp, ier) bkgxmu = chirsp bkgchi = chirsp thechi = chirsp thersp = chirsp c comment char for ascii column data files elseif ((keywrd.eq.'comment_char').or. $ (keywrd.eq.'asccmt')) then asccmt = words(2)(1:2) c hardwire number of doc lines for ascii column data files elseif ((keywrd.eq.'doc_lines').or. $ (keywrd.eq.'mdocxx')) then call str2in(words(2), mdocxx, ierr ) c-- if the word wasn't recognized as a keyword, skip it and go on elseif (.not.errskp) then iw = max( 1, istrln(keywrd) ) is = max( 1, istrln(string) ) write(messg,'(3a)') 'warning: unknown keyword < ', $ keywrd(1:iw),' > ' iii = max(1, istrln(messg)) call echo( ' '//messg(1:iii)) messg = ' " '//string(1:is)//' "' iii = max(1, istrln(messg)) call echo(messg(:iii)) iwrds = 1 end if if (nwords.gt.iwrds) then do 450 i = 1, nwords words(i) = words(i+iwrds) 450 continue nwords = nwords - iwrds go to 300 end if go to 200 c----------------------------------------------------------------------- c done reading the input file: c if we got to this line without setting domore to true, then c we read no input file name, so we'll return and stop the run 500 continue domore = (str.ne.'getcom_end') c if (dorun) then string = 'autobk: '//xmuf ii = max(1, istrln(string)) call echo(' '//string(1:ii) ) string = ' '// commnt ii = max(1, istrln(string)) call echo(' '//string(1:ii) ) c output file names: find last '.', and c save position 1 before '.' in iodot if (chif.eq.' ') chif = xmuf call triml(chif) iodot = max(1,istrln(chif)) if (index(chif(1:iodot),'.').ne.0) then 623 continue iodot = iodot - 1 if (index(chif(iodot+1:iodot+1),'.').eq.0) go to 623 end if chif = chif(1:iodot)//'.chi' end if c normal exit return c----------------------------------------------------------------------- c end subroutine autinp 1000 continue call echo(' autobk error: could not find autobk.inp') stop 1010 continue call echo(' autobk error: error opening autobk.inp') stop 1020 continue call echo(' autobk error: error opening autobk.log') stop 1030 continue call echo(' autobk: error reading autobk.inp') stop end subroutine autint c c initialize arrays in common blocks for autobk c----------------------------------------------------------------------- c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} integer i c common block char c note : versn initialized in main program (easier maintainence) xmuf = ' ' skeyxm = ' ' theorf = ' ' skeyth = ' ' chif = ' ' commnt = ' ' asccmt = '# ' if (vaxflg) asccmt = '##' frminp = ' ' frmout = ' ' do 40 i = 1, maxdoc xmudoc(i) = ' ' thedoc(i) = ' ' 40 continue c c common block data nxmu = maxpts imucol = 2 mdocxx = 0 iodot = 1 ntheor = maxpts nsplin = 0 nkeyxm = 0 nkeyth = 0 do 100 i = 1, maxpts energy(i) = zero xmudat(i) = zero spline(i) = zero chiq(i) = zero thiq(i) = zero windo(i) = zero 100 continue do 120 i = 1, mtknot eknot(i) = zero 120 continue c c common block edge eefind = .true. stfind = .true. ee = zero predg1 = -50. predg2 = -200. slopre = zero bpre = zero enor1 = 100. enor2 = 300. step = zero nnorm = 3 nterp = 1 c c common block fft winstr = 'hanning' iwindo = 0 nqpts = 0 nrpts = 0 qweigh = one qmin = zero qmax = zero windo1 = zero windo2 = zero rbkg = one r1st = rbkg + 2 * one c c common block ino c note : vaxflg initialized in main program (easier maintainence) preout = .false. nrmout = .true. eshout = .false. bkgxmu = .true. bkgchi = .false. bkgrsp = .false. thechi = .false. thersp = .false. chirsp = .false. gvknot = .false. iprint = 0 do 255 i = 1, mtknot eknot(i) = zero 255 continue do 267 i = 1, maxpts spline(i) = zero thiq(i) = zero chiq(i) = zero thifit(i) = zero 267 continue c c common block fit theory = .false. thefix = .false. eevary = .false. funnrm = .false. final = .false. nrbkg = 0 nr1st = 0 emin = zero emax = zero e0shft = zero theamp = one thessq = one usrtol = one spstep = one c c common block feff pcflg = .false. do 357 i = 1, mfeff phafef(i) = zero qfeff(i) = zero 357 continue return c end subroutine autint end subroutine autlog(iofl) c c a bunch of write statements to the log file (unit=iofl) c this should fully account what went on in the background removal. c please feel free to alter it in any way. c c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} integer iofl, ilen, ix, icom, istrln double precision e0 external istrln c c if first time through, open log file c begin writing results write(iofl,425) icom = max(1, istrln(commnt)) if (icom.ne.0) then write(iofl,400) ' '//commnt(:icom) write(iofl,426) end if ilen = max(1, istrln(xmuf)) write(iofl,410) ' input xmu data file name and skey: ', $ xmuf(:ilen + 2),skeyxm write(iofl,405) ' first document line: ', $ xmudoc(1)(:50) if (theory) then write(iofl,426) ilen = max(1, istrln(theorf)) write(iofl,410) ' input theory chi file name and skey: ', $ theorf(:ilen + 2),skeyth write(iofl,405) ' first document line: ', $ thedoc(1)(:50) end if write(iofl,426) ix = min(55, max(1, istrln(chif)) ) write(iofl,405) ' output chi file : ',chif(1:ix) write(iofl,426) write(iofl,400) ' --------fitting parameters---------' e0 = ee + e0shft if (theory.and.eevary) then write(iofl,460) ' initial value of e0 = ',ee write(iofl,460) ' final value of e0 = ',e0 else write(iofl,460) ' e0 fixed at = ',ee end if write(iofl,470) ' pre-edge range = ', $ predg1,predg2 write(iofl,490) ' pre-edge line = ', slopre , $ ' * Energy + ', bpre write(iofl,460) ' edge step = ',step write(iofl,493) ' post-edge curve for edge_step = ', $ cnorm(1), ' + ', cnorm(2), ' * Energy ' write(iofl,494) ' + ', cnorm(2) , $ ' * Energy^2' if (funnrm) then write(iofl,405) ' note: chi(k) was normalized by the', $ ' background function : ' write(iofl,400) ' chi(k) = ( xmu(e) / bkg(e) ) - 1' end if write(iofl,470) ' energy range = ', $ emin,emax qmax = qgrid*int( sqrt((emax - e0) * etok) / qgrid ) if (emin.gt.e0) then qmin = qgrid*int( sqrt((emin - e0) * etok) / qgrid ) else qmin = zero end if write(iofl,470) ' k range = ',qmin,qmax write(iofl,460) ' k weight = ',qweigh write(iofl,400) ' fourier transform window: ' if (iwindo.eq.1) then write(iofl,460) ' hanning fraction = ',windo1 elseif (iwindo.eq.2) then write(iofl,460) ' gaussian: dk = ',windo1 elseif (iwindo.eq.3) then write(iofl,460) ' lorentzian: dk = ',windo1 elseif (iwindo.eq.4) then write(iofl,470) ' parzen: dk1, dk2 = ', $ windo1,windo2 elseif (iwindo.eq.5) then write(iofl,470) ' welch: dk1, dk2 = ', $ windo1,windo2 else write(iofl,470) ' sills: dk1, dk2 = ', $ windo1,windo2 endif write(iofl,480) ' # of knots in spline = ',nsplin write(iofl,470) ' background r range = ',zero,rbkg if (theory) then write(iofl,460) ' the theory was scaled by = ',theamp write(iofl,470) ' 1st shell r range = ',rbkg,r1st end if write(iofl,425) 400 format(2x,a) 405 format(2x,2a) 410 format(2x,3a) 422 format(9x,'(1/2) + Amp * atan( (Energy - Emid) / Ewid )') 425 format(3x,70('-')) 426 format(3x,35('-')) 460 format(2x,a,f15.6) 470 format(2x,a,f15.6,1x,f15.6) 480 format(2x,a,i4) 490 format(2x,a,e13.6,a,e13.6) 493 format(2x,a,e13.6,a,e13.6,a) 494 format(2x,a,e13.6,a) return c end subroutine autlog end subroutine autnls c c this prepares for and calls the canned subroutine lmdif1 c which will solve the unconstrained non-linear least squares c fitting problem. lmdif1 uses a levenberg-marquardt algorithm, c and requires an external subprogram to evaluate the function c to minimize. the subroutine autfun is used to evaluate this c function. c the function allows the ordinates of the breakpoints of c the spline to vary such that when the optimal b-spline (as c discussed in de boor) is put through these breakpoints, and c the chi(r) is found using this spline as the background is c optimized at low-r. c c copyright 1992 university of washington : matt newville c------------------------------------------------------------------ c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} c------------------------------------------------------------------ integer lenwrk, loop, lminfo, isplin, iup, ilo integer iwork(mtknot), ifft, nemin, nemax, nofx, ne0 integer i, nr, ndoc, iend, im, istrln, ntest parameter(lenwrk = 2*maxpts*mtknot + 20*mtknot + 2*maxpts ) character*128 messg , doc(maxdoc), type*10, file*40 double precision work(lenwrk), fvect(2*maxpts), varys(mtknot) double precision esplin(mtknot), bscoef(mtknot) double precision etmp(maxpts), small, anorm(3), toler, tolfac double precision sumsqr double precision e0, delq, efromq, qmn, qmx, qknot double precision e0tst, qmntst, qmxtst, edfmin parameter (small = 1.d-10, tolfac = 1.d-4, edfmin= 100.d0) external autfun, nofx, istrln, sumsqr c----------------------------------------------------------------------- c----initialization for fitting: c -the starting value for the fitting tolerance (1e-5) is empirical. c the user will be allowed to change it, if necessary, with usertl. c (right now usertl is set to 1). c -the fitting is done in single precision. round off is a worry, but c i have not been able to get the variables to change enough with the c double precision version of lmdif1. this should still be explored. c----------------------------------------------------------------------- toler = usrtol * tolfac e0 = ee + e0shft ifft = 1 loop = 0 100 continue lminfo = 0 loop = loop + 1 if (loop.gt.5) then call echo(' autobk warning: completed 5'// $ ' fitting loops without a stable result.') call echo(' something may be wrong'// $ ' with the fitting,') call echo(' and the background may'// $ ' not be reliable.') go to 800 end if c----start fitting: do 120 i = 1, nxmu spline(i) = xmudat(i) 120 continue e0 = ee + e0shft c move emin and emax if e0-shifted emin = emin + e0shft emax = emax + e0shft if (emax.le.emin) emax = energy(nxmu) nemin = nofx(emin,energy,nxmu) nemax = nofx(emax,energy,nxmu) emin = energy(nemin) emax = energy(nemax) c evaluate energies for the spline variables: c - emin and emax are not relative to the edge c - energy contains the input energy values, not relative to the edge. qmin = sqrt(etok* abs(emin - e0 ) ) if (e0.le.emin) qmin = zero qmax = sqrt(etok* (emax - e0 ) ) c c drpair is the spacing between pairs of independent points in r-space if (.not.gvknot) $ nsplin = 2 * int ( rbkg * ( qmax - qmin ) / pi ) + 1 nsplin = min(mtknot-5, max(5,nsplin)) c c initialize energy values through which the first guess for the c spline must go (evenly spaced in q), and get the initial value c for the spline value at this point. we'll also get the initial c guesses for the variables (the b-spline coefficients) from this c initial spline. c delq = (qmax-qmin)/(nsplin - 1) do 300 i = 1, nsplin efromq = e0 + ( qmin + (i-1) * delq) **2 / etok isplin = nofx(efromq,energy,nxmu) esplin(i) = energy(isplin) iup = min(nxmu, isplin + 5) ilo = max(1, isplin - 5) bscoef(i) = (2*spline(isplin) + spline(iup) + spline(ilo))/4 300 continue esplin(nsplin) = one + esplin(nsplin) c the first and last korder knots in the b-spline are nearly degenerate at c the endpoints. spstep sets the spacing between these points. the c default is one -- this may help eliminate "spikes" at the endpoints. c since each knot represents a place where a derivative can break, c having all four of these at one place allows a complete break from c at this point. by moving a few of the knots just off the ends, the c spline is a little bit stiffer at the endpoints. do 310 i = 1, korder eknot(i) = esplin(1) - spstep * (korder-i-1) eknot(nsplin+i) = esplin(nsplin) + spstep * i 310 continue qmn = sqrt( etok* abs(esplin(1) - e0) ) if (e0.lt.esplin(1)) qmn = zero qmx = sqrt( etok* (esplin(nsplin) - e0) ) do 320 i = korder+1, nsplin qknot = (i-korder)*(qmx - qmn)/(nsplin-korder+1) eknot(i) = esplin(1) + qknot**2/etok 320 continue c c determine the knots for the spline: c knots are points at which the spline has extra freedom. cc ntknot = nsplin + korder if ( (korder.lt.3).or.(nsplin.lt.korder) ) then call echo(' autobk error: not enough'// $ ' freedom to create spline.') call echo(' change fitting range, or'// $ ' order of spline') stop end if c the b-spline coefficients will be the variables in the fit, c the above estimates for the elements of bscoef are good enough c especially when the spline values are smoothed for the initial c guesses in the fit, as below. varys(1) = (3*bscoef(1) + bscoef(2))/ 4 varys(nsplin) = (3*bscoef(nsplin) + bscoef(nsplin-1))/ 4 do 380 i = 2, nsplin-1 varys(i) = (bscoef(i-1) + 2*bscoef(i) + bscoef(i+1) )/4 380 continue nvarys = nsplin c set up window function call window(winstr,windo1,windo2,qmin,qmax,qgrid,maxpts,windo) c if a theory file is used, do its fft now c and add another variable if e0 is to be shifted if (theory) then if (eevary) then nvarys = nvarys + 1 varys(nvarys) = e0shft end if nr = nrpts cc print*, ' theory : ', mftfit call fitfft(thiq, maxpts, mftfit, wfftc, qgrid, $ windo, qweigh, spline, one, ifft, zero, r1st, $ pcflg, qfeff, phafef, mfeff, nrpts, thifit) thessq = max(small, sumsqr(thifit(nrbkg),nr1st)) if (nr.ne.nrpts) then call echo(' autnls error: fitfft is broken' ) write(messg,'(a,2i5)') 'nr, nrpts = ', nr, nrpts call echo(' '//messg(:40)) call echo(' call matt!! these numbers should be equal!') stop end if end if c c initialize fvect and work arrays for lmdif1 mfit = nrbkg do 400 i =1, mfit fvect(i) = zero 400 continue do 410 i =1, lenwrk work(i) = zero 410 continue do 420 i =1, mtknot iwork(i) = 0 420 continue c c lmdif1 to do levenberg-marquardt nonlinear least squares if (theory.and.eevary) then call echo(' autobk: fitting background and e0'// $ ' over the low-r range') else call echo(' autobk: fitting background'// $ ' over the low-r range') end if if (iprint.ge.2) then iend = 0 cc print*, ' call autfun: ', mfit, nvarys, iend cc print*, varys(1), fvect(1), varys(3), fvect(3) call autfun(mfit, nvarys, varys, fvect, iend) cc print*, ' ok ' type = 'xmu' file = 'spline0.dat' doc(1) = ' autobk: initial spline v. e : before fitting' 500 format (1x,a,i4) 501 format (1x,a) 502 format (1x,i5.2,e14.6,e14.6,1x,i5.2,e14.6,e14.6) 503 format (1x,i5.2,e14.6,e14.6) 504 format (1x,a,f14.6) write (doc(2), 500) ' number of variables = ', nsplin write (doc(3), 504) ' spline_step (spstep)= ', spstep write (doc(4), 501) ' index, esplin, ysplin, '// $ ' index, esplin, ysplin ' ndoc = 4 do 550 i = 1, nsplin, 2 if (i.lt.maxdoc) ndoc = ndoc + 1 if ((i.le.maxdoc).and.(i.eq.nsplin)) then write (doc(ndoc), 503) i , esplin(i) , varys(i) elseif (i.le.maxdoc) then write (doc(ndoc), 502) i , esplin(i) , varys(i) , $ i+1, esplin(i+1), varys(i+1) end if 550 continue call outcol(type, file, asccmt, ndoc, mdocxx, doc, nxmu, $ energy, spline, xmudat, chiq, thiq) end if c c the real fit! cc print*, 'AUTNLS nvarys = ',nvarys, mfit, e0shft call lmdif1 (autfun, mfit, nvarys, varys, fvect, $ toler, lminfo, iwork, work, lenwrk) call autfun(mfit, nvarys, varys, fvect, iend) if ( (lminfo.ge.1).and.(lminfo.le.3) ) then messg = 'fitting is finished.' im = max(1, istrln(messg)) call echo (' '//messg(:im) ) else messg = 'lmdif finished with an error ! ' im = max(1, istrln(messg)) call echo (' '//messg(:im) ) write(messg, '( a, i5)' ) 'error code lminfo = ',lminfo im = max(1, istrln(messg)) call echo (' '//messg(:im) ) call echo (' call matt') end if c if (iprint.ge.2) then file = 'spline.dat' doc(1) = ' autobk: final spline v. e : before fitting' ndoc = 4 do 580 i = 1, nsplin, 2 if (i.lt.maxdoc) ndoc = ndoc + 1 if ((i.le.maxdoc).and.(i.eq.nsplin)) then write (doc(ndoc), 503) i , esplin(i) , varys(i) elseif (i.le.maxdoc) then write (doc(ndoc), 502) i , esplin(i) , varys(i) , $ i+1, esplin(i+1), varys(i+1) end if 580 continue call outcol(type, file, asccmt, ndoc, mdocxx, doc, nxmu, $ energy, spline, xmudat, chiq, thiq) end if c even though the fit was good, if an energy shift was done, the c q values used to determine the number and location of the spline c points were wrong, and so the fit must be re-done. this will be c repeated up to 5 times, or until e0 is stable to within 0.5 ev. e0tst = ee + e0shft qmntst = sqrt(etok* abs(emin - e0tst ) ) qmxtst = sqrt(etok* abs(emax - e0tst ) ) if (e0tst.le.emin) qmntst = zero ntest = 2 * int ( rbkg * abs(qmxtst - qmntst) / pi) + 1 if (gvknot) ntest = nsplin ntest = min(mtknot-5, max(5,ntest)) if (eevary.and.(ntest.ne.nsplin) ) then call echo(' autobk warning: because the'// $ ' energy origin was shifted in ') call echo(' in the fit, kmin'// $ ' and kmax have been redefined') call echo(' so that the number'// $ ' of knots in the spline has') call echo(' changed. the fit '// $ ' will be done again.') go to 100 end if c------------------------------------------------------------------ c finished with fit 800 continue c c now that we have the spline as good as we can get it, let's get an c improved estimate of the edge-step. we should have it pretty close c to one, but now we do a parabolic extrapolation of the background c spline to the edge energy value. this should cover up most c difficulties in getting the edge step from a linear extrapolation c of the absorption data itself. if (stfind.and.(.not.funnrm)) then enor1 = e0 + enor1 enor2 = e0 + enor2 if (enor2.gt.energy(nxmu)) enor2 = energy(nxmu) if (enor1.gt.energy(nxmu)) enor1 = enor2 /2 nnorm = 3 if (abs(enor2 - enor1).le.edfmin) nnorm = 2 call polyft(enor1, enor2, energy, spline,nxmu,nnorm,cnorm) ne0 = nofx(e0, energy, nxmu) step = cnorm(1) + cnorm(2)*energy(ne0) if (nnorm.eq.3) step = step + cnorm(3)*energy(ne0)**2 cnorm(1) = cnorm(1) + bpre cnorm(2) = cnorm(2) + slopre end if c c now redo function evaluation with the final values for everything. do 930 i = 1, nxmu spline(i) = xmudat(i) 930 continue do 940 i = 1, maxpts chiq(i) = zero 940 continue final = .true. call autfun(mfit, nvarys, varys, fvect, iend) c return c end subroutine autnls end subroutine autout c c matt: add preout to write pre-edge subtracted xmu and bkg c data outputs for autobk: c uses the routine outdat to write to uwexafs c or column files, as given by frmout. c c copyright 1992 university of washington : matt newville c-------------------------------------------------------------------- c include 'autobk.h' c{autcom.f -*-fortran-*- implicit none c parameters: integer maxpts, maxdoc, korder, maxnot, mtknot, mdmfft double precision zero, one, pi, qgrid, etok parameter(maxpts = 2048, maxdoc = 20, korder = 4 ) parameter(maxnot = 50, mtknot = maxnot + korder ) parameter(mdmfft = 4*maxpts + 15, zero = 0.d0, one = 1.d0) parameter(pi = 3.14159 26535 89793d0) parameter(qgrid = 0.05d0 , etok = 0.26246 82917d0) c character strings: character*128 xmudoc(maxdoc), thedoc(maxdoc) character*128 xmuf, theorf, chif, commnt, versn, winstr character*10 skeyth, skeyxm, frminp, frmout, asccmt*2 common /char/ xmuf, skeyxm, theorf, skeyth, chif, commnt, $ frminp, frmout, versn, xmudoc, thedoc, asccmt, $ winstr c data/background spline: integer nxmu, imucol, ntheor, nsplin, nkeyxm, nkeyth double precision energy(maxpts), xmudat(maxpts), windo(maxpts) double precision spline(maxpts), eknot(mtknot) double precision chiq(maxpts), thiq(maxpts), thifit(maxpts) common /data/ nkeyxm, nkeyth, nxmu, ntheor, nsplin, imucol, $ energy, xmudat, spline, eknot, chiq, thiq, thifit, windo c c pre-edge information: logical eefind, stfind double precision ee, predg1, predg2, slopre double precision bpre, enor1, enor2, step, cnorm(3) integer nnorm, nterp common /edge/ eefind, stfind, nnorm, nterp, ee, predg1, predg2, $ slopre, bpre, enor1, enor2, step, cnorm c c fast-fourier transform: double precision wfftc(mdmfft), qweigh double precision windo1, windo2, rbkg, r1st, qmin, qmax integer iwindo, mftfit, nqpts, nrpts common /fft/ iwindo, mftfit, nqpts, nrpts, qweigh, $ qmin, qmax, windo1, windo2, rbkg, r1st, wfftc c c input/output: integer iprint, mdocxx, iodot logical bkgxmu, bkgchi, bkgrsp, thechi, preout, eshout logical thersp, chirsp, gvknot, nrmout logical vaxflg, macflg, dosflg, lnxflg common /ino/ mdocxx, iprint, iodot, preout, nrmout, eshout, $ bkgxmu, bkgchi, bkgrsp, thechi, thersp, chirsp, gvknot, $ vaxflg, macflg, dosflg, lnxflg c c flags: logical theory, thefix, eevary, funnrm, final, pcflg double precision usrtol, emin, emax, e0shft double precision spstep, spfac, theamp, thessq integer nrbkg, nr1st, nvarys, mfit common /flags/ theory, thefix, eevary, funnrm, final, pcflg common /fit/ nrbkg, nr1st, emin, emax, e0shft, theamp, $ thessq, usrtol, nvarys,mfit, spstep, spfac c dummy arrays for "phase corrected ft" integer mfeff parameter (mfeff = 4) double precision phafef(mfeff), qfeff(mfeff) common /feff/ phafef, qfeff save c# autcom.f} c-------------------------------------------------------------------- c local variables integer istrln, ix, i, it, ixf integer iskxm, iskth, ndoc, jnew, nkyout, ipos, iexist double precision e0, qlast, q1st double precision rmin, energ, q, rlast, outstp double precision tmp1(maxpts), tmp2(maxpts), tmp3(maxpts) double precision enout(maxpts), tmp4(maxpts) character*128 outdoc(maxdoc) character*128 outksp, outrsp, outbkg, outpre character*10 skyksp, skyrsp, skybkg, skypre, ftype logical chiksp data chiksp , iexist , rmin/.true., 1 , zero / c-------------------------------------------------------------------- c-c print*,'entered autout' c get some preliminary stuff it = 1 rlast = 10.d0 e0 = ee + e0shft qlast = qgrid * (int(sqrt((emax - e0)*etok) / qgrid ) - 1 ) nqpts = int ( qlast / qgrid ) q1st = min(qgrid,qmin) mftfit = 2048 call cffti(mftfit, wfftc) c c determine output format if (frmout.eq.' ') then if (frminp.eq.' ') frminp = 'ascii' frmout = frminp end if call smcase(frmout, 'a') c----output file names: iodot was found in autinp if (frmout(1:2).eq.'uw') then outksp = chif(1:iodot)//'.chi' outbkg = chif(1:iodot)//'.bkg' outrsp = chif(1:iodot)//'.rsp' outpre = chif(1:iodot)//'.xmu' else outpre = chif(1:iodot)//'e.xmu' outbkg = chif(1:iodot)//'e.bkg' outksp = chif(1:iodot)//'k.chi' outrsp = chif(1:iodot)//'r.chi' end if ix = max(1, istrln(outksp)) do 80 i = 1, maxpts tmp1(i) = zero tmp2(i) = zero tmp3(i) = zero tmp4(i) = zero 80 continue if (eshout) then do 90 i = 1, maxpts enout(i) = energy(i) - e0 90 continue else do 95 i = 1, maxpts enout(i) = energy(i) 95 continue end if c write documentaion for data and background write(outdoc(1), 9000) 'data : ', commnt(1:65) iskxm = max(1, istrln(skeyxm)) iskth = max(1, istrln(skeyth)) ixf = min(74, max(1, istrln(xmuf))) write(outdoc(2), 9005) skeyxm(1:iskxm), xmuf(1:ixf) if (theory) then it = min(74, max(1, istrln(theorf))) write(outdoc(3), 9010) skeyth(1:iskth), theorf(1:it) else outdoc(3) = ' using simple minimization ' end if c pre-edge info write(outdoc(4), 9020) e0, predg1, predg2, step c fourier window type if (iwindo.eq.1) then write(outdoc(5), 9030) qmin, qmax, qweigh, $ '; hanning fraction =', windo1 elseif (iwindo.eq.2) then write(outdoc(5), 9030) qmin, qmax, qweigh, $ '; gaussian dk =', windo1 elseif (iwindo.eq.3) then write(outdoc(5), 9030) qmin, qmax, qweigh, $ '; lorentzian dk =', windo1 elseif (iwindo.eq.4) then write(outdoc(5), 9035) qmin, qmax, qweigh, $ '; parzen dk1, dk2 =', windo1, windo2 elseif (iwindo.eq.5) then write(outdoc(5), 9035) qmin, qmax, qweigh, $ '; welch dk1, dk2 =', windo1, windo2 else write(outdoc(5), 9035) qmin, qmax, qweigh, $ '; sills dk1, dk2 =', windo1, windo2 end if c if (theory) then write(outdoc(6), 9040) rmin,rbkg,rbkg,r1st,nsplin else write(outdoc(6), 9045) rmin,rbkg,nsplin end if c--add previous document at end ndoc = 6 jnew = 0 150 continue jnew = jnew + 1 if (jnew.gt.maxdoc) go to 155 call triml(xmudoc(jnew)) if ( (ndoc.lt.19).and.(xmudoc(jnew).ne.' ') ) then ndoc = ndoc + 1 outdoc(ndoc) = xmudoc(jnew) go to 150 end if 155 continue c print*,' outdoc(5)(1:20)=',outdoc(5)(1:20) c----write out pre-edge subtracted xmu(e) (if preout = t) outstp = one if (preout) then if (nrmout) outstp = step outdoc(2)(1:3) = 'xmu' ftype = 'xmu' do 300 i = 1, nxmu tmp1(i) = xmudat(i) / outstp 300 continue call outdat( ftype, frmout, outpre, vaxflg, asccmt, skypre, $ nkyout, ndoc, mdocxx, outdoc, nxmu , enout, $ tmp1, tmp2, tmp3, tmp4, iexist) if (skypre.ne.' ') then call echo(' pre-edge subtracted xmu(e)'// $ ' written to: '// outpre(1:ix) ) else call echo(' pre-edge subtracted xmu(e)'// $ ' already in: '// outpre(1:ix) ) end if outdoc(2)(1:3) = 'chi' end if c----write out chi(k) and chi(r) for data : skyrsp = ' ' skyksp = ' ' call chiout(chiq, outksp, outrsp, frmout, vaxflg, $ chiksp, chirsp, ndoc, outdoc, q1st, $ qlast, qgrid, qweigh, windo, wfftc, mftfit, $ rlast, asccmt, mdocxx, iexist, skyksp, skyrsp) if (skyksp.ne.' ') then call echo(' chi(k) for data written to: '// $ outksp(1:ix) ) else call echo(' chi(k) for data already in: '// $ outksp(1:ix) ) end if if (skyrsp.ne.' ') then call echo(' chi(R) for data written to: '// $ outrsp(1:ix) ) elseif (chirsp) then call echo(' chi(R) for data already in: '// $ outrsp(1:ix) ) end if c----write out background(e) if (bkgxmu) then write(outdoc(1), 9000) 'bckgrd: ', commnt(1:65) outdoc(2)(1:3) = 'bkg' ftype = 'xmu' c c decide if pre-edge should be undone or not if (preout) then do 400 i = 1, nxmu tmp1(i) = spline(i) / outstp 400 continue else do 405 i = 1, nxmu tmp1(i) = spline(i) + bpre + slopre*energy(i) 405 continue endif call outdat( ftype, frmout, outbkg, vaxflg, asccmt, skybkg, $ nkyout, ndoc, mdocxx, outdoc, nxmu , enout, $ tmp1, tmp2, tmp3, tmp4, iexist) if (skybkg.ne.' ') then call echo(' background(e) written to: '// $ outbkg(1:ix) ) else call echo(' background(e) already in: '// $ outbkg(1:ix) ) end if end if c----write out background(k) if (bkgchi) then write(outdoc(1), 9000) 'bckgrd: ', commnt(1:65) do 480 i = 1, nxmu energ = energy(i) - e0 if (energ.lt.0) then tmp3(i) = - sqrt( - etok*energ) else tmp3(i) = sqrt( etok*energ) end if 480 continue c write background(k) to temporary file, write it out ipos = 1 do 500 i = 1, nqpts+10 q = (i-1)*qgrid if ((q.ge.q1st).and.(q.le.qlast)) then call lintrp(tmp3, spline, nxmu, q, ipos, tmp4(i) ) else tmp4(i) = zero end if 500 continue c file name if (frmout(1:2).ne.'uw') then outksp = chif(1:iodot)//'k.bkg' outrsp = chif(1:iodot)//'r.bkg' end if skyksp = ' ' call chiout(tmp4, outksp, outrsp, frmout, vaxflg, $ bkgchi, bkgrsp, ndoc, outdoc, q1st, $ qlast, qgrid, qweigh, windo, wfftc, mftfit, $ rlast, asccmt, mdocxx, iexist, skyksp, skyrsp) if (skyksp.ne.' ') then call echo(' background(k) written to: '// $ outksp(1:ix) ) else call echo(' background(k) already in: '// $ outksp(1:ix) ) end if end if c----documents for theoretical standard if ( theory.and.(thersp.or.thechi)) then write(outdoc(1), 9000) 'theory: ', commnt(1:65) write(outdoc(2), 9100) skeyxm(1:iskxm), xmuf(1:ixf) write(outdoc(3), 9110) skeyth(1:iskth), theorf(1:it) write(outdoc(4), 9120) rbkg, r1st, theamp c-- add previous document at end ndoc = 4 jnew = 0 610 continue jnew = jnew + 1 if (jnew.gt.maxdoc) go to 615 call triml(thedoc(jnew)) if ( (ndoc.lt.19).and.(thedoc(jnew).ne.' ') ) then ndoc = ndoc + 1 outdoc(ndoc) = thedoc(jnew) go to 610 end if 615 continue if (ndoc.le.19) then do 620 i = ndoc, 19 outdoc(i) = ' ' 620 continue end if c----evaluate chi(k) for theory do 700 i = 1, maxpts q = i*qgrid tmp3(i) = theamp*thiq(i) tmp4(i) = zero 700 continue c----write out chi(k) and chi(r) for theory c file name if (frmout(1:2).ne.'uw') then outksp = chif(1:iodot)//'k.stn' outrsp = chif(1:iodot)//'r.stn' end if skyksp = ' ' skyrsp = ' ' call chiout(tmp3, outksp, outrsp, frmout, vaxflg, $ thechi, thersp, ndoc, outdoc, q1st, $ qlast, qgrid, qweigh, windo, wfftc, mftfit, $ rlast, asccmt, mdocxx, iexist, skyksp, skyrsp) if (skyksp.ne.' ') then call echo(' chi(k) for theory written to: '// $ outksp(1:ix) ) else call echo(' chi(k) for theory already in: '// $ outksp(1:ix) ) end if if (skyrsp.ne.' ') then call echo(' chi(R) for theory written to: '// $ outrsp(1:ix) ) elseif (thersp) then call echo(' chi(R) for theory already in: '// $ outrsp(1:ix) ) end if end if c----all done call echo(' ----------------------------------'// $ '----------------------------------') return c format statements 9000 format(2a) 9005 format('chi: from skey ',a,' of ',a) 9010 format(' using skey ',a,' of ',a) 9020 format(' e0 =',f9.2,'; pre-edge range =[', 2f8.1, $ ']; edge step =', f7.3 ) 9030 format(' k range =[',2f6.2,']; k weight =',f6.2,a20,f5.3) 9035 format(' k range=[',2f6.2,']; k weight=',f6.2,a20,2f6.2) 9040 format(' bkg r =[',2f6.2,']; 1st shell r =[',2f6.2,']; ', $ i3, ' knots in spline') 9045 format(' bkg r =[',2f6.2,']; ',i3,' knots in spline') 9100 format('chi: from skey ',a,' of ',a) 9110 format(' using skey ',a,' of ',a) 9120 format('1st shell fit range=[',2f6.2,'] => amp-scale =',f8.5) c end subroutine autout 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 chiout(chiq, filksp, filrsp, format, vax, ksp, rsp, $ ndoc, doc, qlo, qhi, qgrid, qweigh, windo, $ wfftc, mfft, rlast, comm, mdocx, iexist, skychi, skyrsp) c c this will write out chi(k) and chi(r) to output files c c copyright 1993 university of washington matt newville c c inputs: c chiq array of chi(k) data, on with chiq(1) = chi(k=0.) c filksp name of output k-space file to write c filrsp name of output r-space file to write c format format of output files (uwexafs of ascii) c vax logical flag for writing binary data in vax format c ksp logical flag for writing data to k-space c rsp logical flag for writing data to r-space c ndoc number of document lines to write out c doc documents to write out c qlo lowest value in k-space to write out data c qhi highest value in 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 windo window array c windo2 window parameter #2 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 c skyrsp output skey of chi(r) file c c note mfft must be less than or equal to 2048 implicit none integer i, nfft, mdocx, maxpts, mfft double precision zero, pi parameter (maxpts = 2048) parameter (zero = 0.d0, pi = 3.14159 26535 89793d0 ) character*(*) filksp, filrsp, format, doc, skychi, skyrsp character*(*) type*10, comm double precision chiq(*), wfftc(*), windo(*) double precision xdata(maxpts), yreal(maxpts), yimag(maxpts) double precision yphas(maxpts), yampl(maxpts) double precision qweigh, qgrid, qlo, qhi, rlast, rgrid double precision qsmall, rsmall integer ndoc, nkyout, iexist, nrout, nqout, nqlo, nqhi complex*16 cchiq(maxpts), chir(maxpts) logical vax, ksp, rsp c c initialize, calculate assorted useful indices mdocx = 0 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) chir(i) = cmplx(zero, zero) 20 continue c check that mfft .le. maxpts nfft = mfft if (nfft.gt.maxpts) nfft = maxpts rgrid = pi / ( nfft * qgrid) rsmall = rgrid / 100.0 qsmall = qgrid / 100.0 nqlo = int( (qlo + qsmall) / qgrid ) if (nqlo.lt.0) nqlo = 0 nqhi = int( (qhi + qsmall) / qgrid ) nqout = nqhi - nqlo + 1 nrout = int( (rlast + rsmall) / rgrid ) c c construct chi(k) on q range [qlo, qhi] do 300 i = 1, nqout xdata(i) = qlo + (i-1)*qgrid yreal(i) = chiq(nqlo + i) yimag(i) = zero 300 continue c c k - space if (ksp) then type = 'chi' skychi = ' ' nkyout = 0 c write out chi(k) on q range [qlo, qhi] call outdat(type, format, filksp, vax, comm, skychi, nkyout, $ ndoc, mdocx, doc, nqout, xdata, $ yreal, yimag, yampl, yphas, iexist) end if c c r - space c if (rsp) then c construct complex chi(k) do 400 i = 1, nfft cchiq(i) = cmplx(chiq(i), zero) 400 continue c take fft of complex chi(k) to get chir call xafsft(nfft, cchiq, windo, qgrid, qweigh, $ wfftc, 1, chir) do 500 i = 1, nrout xdata(i) = (i-1)*rgrid yreal(i) = dble( chir(i) ) yimag(i) = dimag( chir(i) ) yampl(i) = zero yphas(i) = zero 500 continue type = 'rsp' skyrsp = ' ' nkyout = 0 c write out chi(r) on r range [0.,rlast] call outdat(type, format, filrsp, vax, comm, skyrsp, nkyout, $ ndoc, mdocx, doc, nrout, xdata, $ yreal, yimag, yampl, yphas, iexist) end if c return c end subroutine chiout end subroutine echo(str) 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 dump string to standard output implicit none c include 'echo.h' c{echo.h -*-fortran-*- c i_echo controls echo outputs: c 0 save to echo buffer in echo_str c 1 write to screen c 2 write to echo file c 3 write to both screen and echo file integer mxecho, n_echo, i_echo, lun_echo parameter(mxecho = 256) character*256 echo_str(mxecho),echo_file common /echo_s/ echo_str, echo_file common /echo_i/ n_echo, i_echo, lun_echo c} character*(*) str,form*8 parameter (form = '(1x)' ) call chrdmp(str) if (mod(i_echo,2).eq.1) write(*,form) return c end subroutine echo end subroutine chrdmp(str) c dump string to screen with "$" format implicit none c include 'echo.h' c{echo.h -*-fortran-*- c i_echo controls echo outputs: c 0 save to echo buffer in echo_str c 1 write to screen c 2 write to echo file c 3 write to both screen and echo file integer mxecho, n_echo, i_echo, lun_echo parameter(mxecho = 256) character*256 echo_str(mxecho),echo_file common /echo_s/ echo_str, echo_file common /echo_i/ n_echo, i_echo, lun_echo c} character*(*) str, out*256,frm*8,ffrm*8 parameter (frm= '(1x,a,$)', ffrm= '(1x,a)' ) integer istrln, n external istrln out = str n = max(1, istrln(out)) if (i_echo.eq.0) then call echo_push(out) else if (mod(i_echo,2).eq.1) write(*,frm) out(1:n) if ((i_echo.ge.2).and.(lun_echo.gt.0)) $ write(lun_echo, ffrm) out(1:n) endif return c end subroutine chrdmp end subroutine echo_init c initialize echo lines implicit none c include 'echo.h' c{echo.h -*-fortran-*- c i_echo controls echo outputs: c 0 save to echo buffer in echo_str c 1 write to screen c 2 write to echo file c 3 write to both screen and echo file integer mxecho, n_echo, i_echo, lun_echo parameter(mxecho = 256) character*256 echo_str(mxecho),echo_file common /echo_s/ echo_str, echo_file common /echo_i/ n_echo, i_echo, lun_echo c} integer i do 20 i = 1, mxecho echo_str(i) = ' ' 20 continue cc call setsca('&echo_lines', 0.d0) n_echo = 0 cc call setsca('&screen_echo', 1.d0) i_echo = 1 lun_echo = 0 echo_file = '' return end subroutine echo_push(string) c add echo string to internal list c copyright (c) 1999 matt newville implicit none character*(*) string, str*256 c include 'echo.h' c{echo.h -*-fortran-*- c i_echo controls echo outputs: c 0 save to echo buffer in echo_str c 1 write to screen c 2 write to echo file c 3 write to both screen and echo file integer mxecho, n_echo, i_echo, lun_echo parameter(mxecho = 256) character*256 echo_str(mxecho),echo_file common /echo_s/ echo_str, echo_file common /echo_i/ n_echo, i_echo, lun_echo c} integer istrln, ilen, i external istrln str = string call sclean(str) call triml(str) ilen = istrln(str) if (ilen.ge.1) then do 30 i = mxecho, 2, -1 echo_str(i) = echo_str(i-1) 30 continue echo_str(1) = str(1:ilen) cc print*, ' ECHO_PUSH: ', str(1:ilen) n_echo = n_echo + 1 endif cc call setsca('&echo_lines', n_echo * 1.d0) return c end subroutine echo_push end subroutine echo_pop(string) c add echo string to internal list c copyright (c) 1999 matt newville implicit none character*(*) string c include 'echo.h' c{echo.h -*-fortran-*- c i_echo controls echo outputs: c 0 save to echo buffer in echo_str c 1 write to screen c 2 write to echo file c 3 write to both screen and echo file integer mxecho, n_echo, i_echo, lun_echo parameter(mxecho = 256) character*256 echo_str(mxecho),echo_file common /echo_s/ echo_str, echo_file common /echo_i/ n_echo, i_echo, lun_echo c} string = ' ' if (n_echo .gt. 0) then string = echo_str(n_echo) cc print*, ' ECHO_POP: ', string(1:60) echo_str(n_echo) = ' ' end if n_echo = max(0, n_echo - 1) cc call setsca('&echo_lines', n_echo * 1.d0) return c end subroutine echo_pop 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 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 = 2048, 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 if (mxmpts.ne.mfft) then call echo('fitfft warning: weird number of points') print*, mxmpts, mfft 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 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*90 files(mfil), errmsg, words(mwords) integer iunit(mfil), istrln, nwords, ierr, iex logical iscomm external istrln, iscomm save files, iunit, nfil c if ((jinit.lt.0)) then jinit = 1 do 10 i = 1, mfil iunit(i) = 8 + i 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 = ' ' read(iunit(nfil),'(a)', err =1000, end = 500) line call sclean(line) c c check if command line is 'include filename'. c if so, open that file, and put it in the files stack call untab(line) 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 echo(' # getcom error: general read error') go to 4500 2000 continue call echo(' # getcom error: too many nested "include"s') write(errmsg, '(1x,a,i3)') ' # current limit is ', mfil ilen = istrln(errmsg) call echo(errmsg(1:ilen)) go to 4500 2400 continue call echo(' # getcom error: cannot determine "include" file') go to 4500 2600 continue call echo(' # getcom error: cannot find "include"d file') go to 4500 2800 continue call echo(' # getcom error: cannot open "include"d file') go to 4500 3000 continue call echo(' # 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 echo(errmsg(1:ilen) ) line = 'getcom_error' return c end subroutine getcom 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 irecl, ndocmx, ndatmx / 512 , 19, 4096/ c--------------------------------------------------------------------- c some initializations if (vax) irecl = 128 type = filtyp call triml(type) call upper(type) symkey = skey call triml(symkey) call upper(symkey) c c determine format of the input file formin = format call triml(formin) call smcase(formin, 'a') call testrf(filnam, irecl, form, ier) call smcase(form, 'a') if (ier.eq.-1) then call 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 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) 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 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 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(' better 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 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/ save 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-09,1.d-30,1.d+30 / spmpar = rmach(i) return c c last card of function spmpar. c c end function spmpar 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*100 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 echo('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 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 integer function nxtunt(iunit) c return next available unit number, greater than or equal to iunit. c will not return unit number less than 1, or equal to 5 or 6. integer iunit logical open nxtunt = max(1, iunit) 10 continue inquire (unit=nxtunt, opened=open) if (open) then nxtunt = nxtunt + 1 if ((nxtunt.eq.5).or.(nxtunt.eq.6)) nxtunt = 7 goto 10 endif return c end integer function nxtunt end 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 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*80 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 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 getfln(strin, filnam, ierr) c strip off the matched delimeters from string, as if getting c a filename from "filename", etc. implicit none integer idel, iend, istrln, ierr, ilen character*(*) strin, filnam, tmp*144, ope*8, clo*8 external istrln data ope, clo /'"{(<''[', '"})>'']'/ c ierr = 0 tmp = strin call triml(tmp) ilen = istrln(tmp) idel = index(ope,tmp(1:1)) if (idel.ne.0) then iend = index(tmp(2:), clo(idel:idel) ) if (iend.le.0) then ierr = -1 iend = ilen end if filnam = tmp(2:iend) else iend = index(tmp,' ') - 1 if (iend.le.0) iend = istrln(tmp) filnam = tmp(1:iend) end if return c end subroutine getfln end subroutine 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 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 ' dohunt = .true. jlo = min(npts-1,max(1,jlo)) if ((xin.ge.xar(jlo)) .and. (xin.le.xar(jlo+1))) then dohunt = .false. elseif (xin.lt.xar(1)) then jlo = 1 dohunt = .false. elseif (xin.gt.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 ', 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 integer maxpts, nx, ny, nxnew, i, ierr, ip, iterp parameter(maxpts = 2**14) 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 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 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 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-*- integer maxpts, 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 parameter ( mckeys = 64 ) parameter ( macmax = 256 ) parameter ( mcline = 2048 ) parameter ( mcdeep = 8 ) parameter ( mfiles = 16 ) parameter ( mkeys = 64 ) parameter ( mmcarg = 9 ) parameter ( maxpts = 2048 ) ! points in data arrays parameter ( maxfft = maxpts)! points for fft arrays parameter ( mwfft = 4*maxpts+15) parameter ( maxsca = 2048 ) ! # of scalar variables parameter ( maxtxt = 4096 ) ! # of text variables parameter ( mconst = 8192 ) ! # of numerical constants parameter ( maxarr = 511 ) ! # of array variables parameter ( maxplt = 72 ) ! # of plots parameter ( maxdoc = 20 ) ! # of docs from data file parameter ( micode = 64 ) ! # of elements in math encode parameter ( mffpts = 100 ) ! # of points in feff arrays parameter ( mfffil = 100 ) ! # 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 = 32 ) ! # of local parameters parameter ( maxnot = 50 ) ! # of knots in background spline parameter ( korder = 4 ) parameter ( mtknot = maxnot+korder) parameter ( mdata = 3 ) ! # of data sets parameter ( mvarys = 75 ) ! # of variables parameter ( mdpths = 100 ) ! max # of paths for a data set parameter ( mpaths = 100 ) ! max # of paths, total parameter ( mppars = 16 ) ! max # of path parameters c c 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) parameter ( qgrid = 0.05d0) parameter ( rgrid = 20 * pi / maxpts) character undef*8,blank*1 parameter ( undef = '%undef%', blank = ' ') 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 preedg(e0find, stfind, nxmu, energy, xmu, e0, $ predg1, predg2, enor1, enor2, nnorm, $ step, slopre, bpre, cnorm) 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 pre-edge subtraction and normalization of exafs data. c c arguments: c e0find flag for finding e0 [in] c stfind logical flag to finding edge step [in] c nxmu length of array energy and xmu [in] c energy array of energy points [in] c xmu array of raw absorption points [in] c e0 e0, energy origin of data [in/out] c predg1 region for picking pre-edge line [in/out] c predg2 region for picking pre-edge line [in/out] c enor1 region for picking normalization [in/out] c enor2 region for picking normalization [in/out] c nnorm polynomial order of norm. curve [in/out] c step edge step for normalization [in/out] c ( found if zero on input ) c slopre slope of pre-edge line [out] c bpre intercept of pre-edge line [out] c cnorm coefficients of normalization curve [out] c (dimension 3: quadratic polynomial) c uses subroutine polyft c implicit none integer nxmu, npstp, nxmin,npoly, ne0, nofx,nnorm logical e0find, stfind parameter (npoly=4, nxmin = 5) double precision energy(nxmu), xmu(nxmu), coef(npoly) double precision tiny, edfmin, slopre, bpre, xenlo, xenhi double precision e0, predg1, predg2, enor1, enor2, step double precision e1def, e2def, p1def, p2def, tmp, cnorm(*) parameter (tiny = 1.d-8, edfmin= 100.d0) parameter (e1def= 1d2, e2def= 4d2, p1def= -50d0, p2def= -2d2) external nofx c c if e0 was not specified, or is out of range, c it is found as the point of maximum deriv, with check that c it is at least the third positive deriv in a row if (nxmu.le.nxmin) return if ( e0find .or. e0.le.energy(1) .or. e0.ge.energy(nxmu) ) $ call findee(nxmu, energy, xmu, e0) c c linear fit to pre-edge if ((abs(predg1).le.tiny).and.(abs(predg2).le.tiny)) then predg1 = p1def predg2 = p2def end if if (predg1.gt.predg2) then tmp = predg1 predg1 = predg2 predg2 = tmp endif xenlo = e0 + predg1 xenhi = e0 + predg2 cc print*, ' pre-edge: ', predg1, predg2, e0 cc print*, ' pre-edge: ', xenlo , xenhi, energy(1) if (xenlo.lt.energy(1)) xenlo = energy(1) if (xenhi.lt.energy(1)) xenhi = (e0 + xenlo) /2 call polyft(xenlo, xenhi, energy, xmu, nxmu, 2, coef) bpre = coef(1) slopre = coef(2) c c normalization : make pre-edge 0.0 and post-edge 1.0 c if step size wasn't given, get it by extracting to e0 a c line that best fits the data on the range (e0+enor1,e0+enor2) if (stfind) then cnorm(1) = 0 cnorm(2) = 0 cnorm(3) = 0 step = 0 if ((abs(enor1).le.tiny).and.(abs(enor2).le.tiny)) then enor1 = e1def enor2 = e2def end if xenlo = e0 + enor1 xenhi = e0 + enor2 if (xenhi.gt.energy(nxmu)) xenhi = energy(nxmu) if (xenlo.gt.energy(nxmu)) xenlo = xenhi /2 npstp = nnorm if ((npstp.ge.3).and. $ (abs(xenhi - xenlo).le.edfmin)) npstp = 2 call polyft(xenlo, xenhi, energy, xmu, nxmu, npstp, cnorm) nnorm = npstp ne0 = nofx(e0, energy, nxmu) step = (cnorm(1) - bpre) + (cnorm(2) - slopre)*energy(ne0) if (npstp.eq.3) step = step + cnorm(3)*energy(ne0)**2 if (abs(step).lt.tiny) step = 1 end if return c end subroutine preedg end subroutine findee(nxmu, energy, xmu, ee) c c find ee of x-ray absorption data c (maximum deriv, with check that it is at least c the third positive deriv in a row) c inputs: c nxmu length of array energy, xmu, and xmuout c energy array of energy points c xmu array of raw absorption points c outputs: c ee energy origin of data integer nxmu, ninc, ntry, i, j parameter (ninc = 3) logical inc(ninc), incall double precision energy(nxmu), xmu(nxmu), ee, dxde, demx, deltae double precision zero, tiny, onepls parameter (zero = 0, tiny = 1.d-8, onepls = 1.00001d0) c ee = zero if (nxmu.le.8) return do 100 i = 1, ninc inc(i) = .false. 100 continue dxde = zero demx = zero ntry = max(2, int(nxmu/2)) + 3 do 150 i = 2, ntry deltae = energy(i) - energy(i-1) if (deltae.gt.tiny) then dxde = (xmu(i) - xmu(i-1))/deltae inc(1) = dxde.gt.zero incall = inc(3).and.inc(2).and.inc(1) if (incall. and. (dxde.gt.demx) ) then ee = energy(i) demx = dxde * onepls end if do 130 j = ninc, 2, -1 inc(j) = inc(j - 1) 130 continue end if 150 continue return end subroutine setsys(system,vaxflg,dosflg,macflg,lnxflg) 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,lnxflg vaxflg = .false. lnxflg = .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 elseif (sys.eq.'linux') then lnxflg = .true. system = sys else system = 'unix' endif return 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) 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, iprot character*(*) str, keys(mkeys), values(mkeys), tmp*64 character s, blank, comma, equal, semicl character copen*5, cclose*5, undef*8 logical lcomma, fndkey, seekey 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 seekey = .false. fndkey = .true. lcomma = .false. ibeg = 1 iprot = 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 do 250 i = 1, ilen s = str(i:i) c test for opening/closing delimiters c -- and keep track if the string is protected 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('** parsing confusion: iprot out of range') return end if c if string is protected, skip to next char cc print*, s, iprot, fndkey, seekey if (iprot.eq.0) then lcomma = (s.eq.comma).or.(s.eq.semicl) c looking for keyword: if (fndkey) then c we've seen the beginning of a keyword, and now we see the end: c keyword ends at "=",","," ", or the final positon if (seekey .and.((s.eq.equal).or. lcomma .or. $ (i.eq.ilen))) then nkeys = nkeys + 1 if (nkeys .ge. mkeys) go to 255 keys(nkeys) = str(ibeg:i-1) if ((i.eq.ilen).and.(.not.lcomma).and.(s.ne.equal)) $ keys(nkeys) = str(ibeg:i) ibeg = min(i + 1, ilen) fndkey = .false. seekey = .false. c a bare word counts as a key with value= undefined (as above) if ( lcomma .or.(i.eq.ilen) ) then fndkey = .true. call triml(keys(nkeys)) ij = istrln(keys(nkeys)) if (index(keys(nkeys)(1:ij),blank).ne.0) then tmp = keys(nkeys)(1:ij) cc call echo(' syntax error: '//tmp) keys(nkeys) = blank end if end if elseif (.not.seekey) then seekey = 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) fndkey = .true. end if end if end if 250 continue 255 continue c c finally, we may have ended with a one-letter keyword, in which case c seekey is true if (seekey) 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 cc print*, i,'|', keys(i),'|' 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 do 470 j = 1, 5 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 500 continue return c end subroutine bkeys 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 xafsft(mpts, chip, wa, xgrid, xwgh, wfftc,jfft,chiq) 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 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 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 * (1d0,0d0) if (jfft.lt.0) cnorm = 2 * cnorm if (jfft.eq.0) cnorm = (1d0,0d0) c make chiq as k-weighted and windowed chip c if xwgh is really an integer, do only the integer exponentiation ixwgh = int(xwgh) chiq(1) = (0d0,0d0) do 50 i = 2, mpts chiq(i) = cnorm * chip(i) * wa(i) $ * ((i-1) * xgrid)**ixwgh 50 continue c do fp exponentiation only if it will be noticeable dx = xwgh - ixwgh if (dx .gt. eps4) then do 60 i = 1, mpts chiq(i) = chiq(i) * ((i-1)*xgrid)**dx 60 continue end if cc print*, 'xafsft ' , mpts, jfft 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