c Copyright Notice: FEFF7 is copyright protected software and users must
c obtain a license from the University of Washington Office of
c Technology Transfer for its use; see section V of FEFF document.

c Main Authors of FEFF7: please contact us concerning problems.
c A. L. Ankudinov, alex@phys.washington.edu      (206) 543 3904
c S. I. Zabinsky, zabinsky@phys.washington.edu   (???) ??? ????
c J. J. Rehr,     jjr@phys.washington.edu        (206) 543 8593
c R. C. Albers,   rca@nidhug.lanl.gov            (505) 665 0417

c Citations: Please cite at least one of the following articles if
c FEFF is used in published work:
c    1) Multiple scattering
c       J.J. Rehr and R.C. Albers, Phys. Rev. B41, 8139 (1990).
c       J.J. Rehr, S.I. Zabinsky and R.C. Albers,
c          Phys. Rev. Let. 69, 3397 (1992).
c    2) General reference
c       S.I.  Zabinsky, J.J. Rehr, A. Ankudinov, R.C. Albers, and
c       M.J. Eller, Phys. Rev. B52, 2995 (1995).
c       J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky, and R.C. Albers,
c          J. Am. Chem. Soc. 113, 5135 (1991).
c    3) Technical reference
c       J. Mustre de Leon, J.J. Rehr, S.I.  Zabinsky, and R.C. Albers,
c          Phys. Rev. B44, 4146 (1991).

      program feff
      implicit double precision (a-h, o-z)

c     include 'vers.h'
      character*12 vfeff
      common /vers/ vfeff
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola

      parameter (ntitx = 10)
      character*71  title(ntitx)
      dimension ltit(ntitx)
      character*12 tmpstr
      character*30 fname
      logical lreal, nohole, wnstar

c     Following passed to pathfinder, which is single precision.
c     Be careful to always declare these!
      parameter (necrit=9, nbeta=40)
      real fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      real fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex)
      real xlamc(necrit)
      real xlam(nex)
      real rmax, critpw, pcritk, pcrith
      character*6  potlbl(0:npotx)

   10 format (1x, a)

c     open the log file, unit 11.  See subroutine wlog.
      open (unit=11, file='log.dat', iostat=ios)
      call chopen (ios, 'log.dat', 'feff')

      tmpstr = vfeff
      call triml (tmpstr)
      call wlog(' ' // tmpstr)
      call rdinp (mphase, mpath, mfeff, mchi, ms,
     1            ntitle, title, ltit,
     2            critcw,
     1            ipr2, ipr3, ipr4,
     1            s02, mbconv, tk, thetad, alphat, sig2g,
     1            nlegxx,
     1            rmax, critpw, pcritk, pcrith, nncrit,
     2            icsig, iorder, vrcorr, vicorr, xloss,
     1            rgrd, lreal, nohole, zzcrit, zzkmin, zzkmax,
     1            wnstar)

      do 20  i = 1, ntitle
         call wlog(' ' // title(i)(1:ltit(i)))
   20 continue

      if (mphase .eq. 1)  then
         call wlog(' Calculating potentials and phases...')
         call potph (rgrd, lreal, nohole)
         open (unit=1, file='potph.dat', status='old', iostat=ios)
         call chopen (ios, 'potph.dat', 'feff')
c        close (unit=1, status='delete')
c        keep potph.dat during testing
         close (unit=1)
      endif

      if (ms.eq.1  .and.  mpath.eq.1)  then

         call wlog(' Preparing plane wave scattering amplitudes...')
         call prcrit (ne, nncrit, ik0, cksp, fbeta, ckspc,
     1                fbetac, potlbl, xlam, xlamc)

c        Dump out fbetac for central atom and first pot
         if (ipr2 .ge. 3 .and. ipr2.ne.5)  then
            do 260  ipot = 0, 1
               do 250  ie = 1, nncrit
                  write(fname,200)  ie, ipot
  200             format ('fbeta', i1, 'p', i1, '.dat')
                  open (unit=1, file=fname)
                  write(1,210)  ipot, ie, ckspc(ie)
  210             format ('# ipot, ie, ckspc(ie) ', 2i5, 1pe20.6, /
     1                    '#  angle(degrees), fbeta/|p|,  fbeta')
                  do 240  ibeta = -nbeta, nbeta
                     cosb = .025 * ibeta
                     if (cosb .gt.  1)  cosb =  1
                     if (cosb .lt. -1)  cosb = -1
                     angle = acos (cosb)
                     write(1,230)  angle*raddeg,
     1                  fbetac(ibeta,ipot,ie)/ckspc(ie),
     2                  fbetac(ibeta,ipot,ie)
  230                format (f10.4, 1p, 2e15.6)
  240             continue
                  close (unit=1)
  250          continue
  260       continue
         endif

         call wlog(' Searching for paths...')
         call paths (ckspc, fbetac, xlamc, pcritk, pcrith, nncrit,
     1               rmax, nlegxx, ipotnn)

         call wlog(' Eliminating path degeneracies...')
         call pathsd (ckspc, fbetac, xlamc, ne, ik0, cksp,
     1                fbeta, xlam,
     1                critpw, ipotnn, ipr2,
     1                pcritk, pcrith, nncrit, potlbl)

         if (ipr2 .lt. 2)  then
            open (unit=1, file='geom.dat', status='old')
            call chopen (ios, 'geom.dat', 'feff')
            close (unit=1, status='delete')
         endif
      endif

      if (mfeff .eq. 1)  then
         call wlog(' Calculating EXAFS parameters...')
         call genfmt (ipr3, critcw, iorder, wnstar)
      endif

      if (mchi .eq. 1)  then
         call wlog(' Calculating chi...')
         call ff2chi (ipr4, critcw, s02, sig2g, tk, thetad, mbconv,
     1                   vrcorr, vicorr, xloss, zzcrit, zzkmin, zzkmax,
     1                   alphat)
      endif

      call wlog (' Feff done.  Have a nice day.')
      stop
      end
      block data feffbd

      implicit double precision (a-h, o-z)

      character*10 shole(0:29)
      character*8 sout(0:7)
      common /labels/ shole, sout

c     include 'vers.h'
      character*12 vfeff
      common /vers/ vfeff
c     character*12 vfeff
c     common /vers/ vfeff

      data shole /'no hole',   'K  shell',  'L1 shell',  'L2 shell',
     2            'L3 shell',  'M1 shell',  'M2 shell',  'M3 shell',
     3            'M4 shell',  'M5 shell',  'N1 shell',  'N2 shell',
     4            'N3 shell',  'N4 shell',  'N5 shell',  'N6 shell',
     5            'N7 shell',  'O1 shell',  'O2 shell',  'O3 shell',
     6            'O4 shell',  'O5 shell',  'O6 shell',  'O7 shell',
     7            'P1 shell',  'P2 shell',  'P3 shell',  'P4 shell',
     8            'P5 shell',  'R1 shell'/
      data sout /'H-L exch', 'D-H exch', 'Gd state', 'DH - HL ',
     1           'DH + HL ', 'val=s+d ', 'sigmd(r)', 'sigmd=c '/

c                   123456789012
c     5.05a is current working version
c     5.05j is jjr's version 6/93
c     6.00 Alexey's polarization and the XANES
c                   123456789012
      data vfeff  /'Feff  7.02  '/
c     XX is 1/22/96.  Change to Feff 7.00 before release

c     4.04 Major code reorganization.  Muffin tin finder modified -- now
c     uses average of all possible muffin tin radii instead of minimum.
c     26 March, 1991   Steven Zabinsky
c     4.05 Yet another improvement to muffin tin finder, now averages
c     based on volume of lense-shaped overlapping region, April, 1991
c     4.06 Bug fix in sumax, april 1991
c     4.07 Several minor changes involving non-standard F77 6/6/91, siz
c     4.08 ION card added 7/24/91, siz
c     4.08a, bug in header for ION card fixed 9/10/91, siz
c     4.09, quinn correction added to imhl, interstitial calculation
c           corrected, rmt modified to handle too few neighbors and
c           error msg in phase about hard test in fovrg modified,
c           folp card added
c     POTPH 4.1  Same as feff4.09, but version hacked to work with
c     module potph of feff5, Mar 1992, siz
c
c     new version common added, siz, Mar 1992
c     feff 5.03, first 'real' release, lots of little changes.
c                4 criteria added is the big change.  siz, April 1992
c     feffx 5.04, intermediate intermittent version of code with
c                 background, xsect, xmu, timereversal, lots
c                 of input cards, xanes, etc.  July 1992, siz
c     e REQUIRE card removed, Oct 92, siz
c     f, and paths 3.04, new crits, 9 points. Oct 92
c     g: major bug in xsect -  ixc not passed to xcpot, beginning with
c        5.04g, it's fixed.
c     h use gs for xsect (hard coded)
c     i fixed init and final state mixup in xsect
c     Feff 5.05, release version with all of the above in it.  XANES
c        is turned off in RDINP for the release -- turn it back on
c        there for development.
c     Feff 6 includes polarization (Alexey) and XANES (Steve)
c     Feff 6.01 is the first release version.
c     Feff 601a: changes in ff2chi.f are made.
c          Missed parentheses in (... * bohr)** 2 are fixed.
c          Imaginary part of the potential is fixed by the value at the
c          first point (only core hole life time gives Im part, neglect
c          Im part from photoelectron lifetime).  AA
c     Feff 6.10  lot's of small changes, some new features.  Path
c        finder crits use mean free path, NOHOLE option works right,
c        atan in xsect is correct, uses atom nearest to absorber for
c        unique pot model, variable rgrid added, log file added, real
c        phase shifts available, files only use 78 cols including
c        carriage control, a few minor bugs fixed, some headers, etc.,
c        are neater.  Variable rgrid for atom and phase, uses
c        feff.bin instead of feff.dat files.
c        Done by Steve Zabinsky, Fall 1994.
c     Feff 7.00
c        The LDA atomic code is replaced by Dirac-Fock code.
c        Code includes fully relativistic version of xsect.f, which
c        includes both dipole transitions (l-->l +/- 1).
c        For XANES calculation arctan approximation is replaced by
c        convolution with lorentzian.
c        New self energy models are available: a) broadened plasmon
c        model and b) partly nonlocal model (EXCHANGE 5) which
c        calculates for the photoelectron DF exchange term for core
c        electrons and LDA exchange-correlation for valence electrons.
c        Approximate models for S_0^2(E) and excitation spectrum are
c        available, but still experimental.
c     Feff 7.01 (to be done)
c        Test SPIN calculation is available. One have to run program
c        twice (SPIN 1(up), -1(down) ) with the same paths.dat
c        and subtract two xmu.dat files
c        ala 1.09.96.

      end
      subroutine bcoef(ipola, kinit, bmat)
      implicit double precision (a-h,o-z)

      dimension bmat(-1:1,-1:1)
      dimension t3j(-1:+1,0:1,-4:5), x3j(-1:1,-1:1,-4:5)
      dimension jkap(-1:1), lkap(-1:1)

      do 90 k=-1,1
         kp=kinit+k
         if (k.eq.0) kp=-kp
         jkap(k)=abs(kp)
         lkap(k)=kp
         if (kp.le.0) lkap(k)=abs(kp) -1
   90 continue

c     Put 3j factors in x3j and t3j. t3j are multiplied by
c     sqrt(2*j'+1) for  further convinience.
c     ilinit - max final momentum, initial momentum = linit.
      do 138 mp=-4,5
      do 138 ms=0,1
      do 138 k1=-1,1
  138 t3j(k1,ms,mp) = 0.0d0
      do 139 mp=-4,5
      do 139 ms=-1,1
      do 139 k1=-1,1
  139    x3j(k1,ms,mp) = 0.0d0
      do 140 k1 = -1,1
      do 140 mp = -jkap(k1)+1,jkap(k1)
         do 150 ms=0,1
            j1 = 2 * lkap(k1)
            j2 = 1
            j3 = 2 * jkap(k1) - 1
            m1 = 2*(mp-ms)
            m2 = 2*ms - 1
            t3j(k1,ms,mp)=sqrt(j3+1.0d0) * cwig3j(j1,j2,j3,m1,m2,2)

  150    continue
         do 160 i=-1,1
            j1 = 2 * abs(kinit) - 1
            j2 = 2
            j3 = 2 * jkap(k1) - 1
            m2 = 2*i
            m1 = -2*mp + 1 -m2
            x3j(k1,i,mp)= cwig3j(j1,j2,j3,m1,m2,2)
  160    continue
  140 continue

      do 70 k1=-1,1
      do 70 k2=-1,1
         bmat(k1,k2) = 0
         mf = min(jkap(k1),jkap(k2))
         mi = -mf +1
         if (lkap(k1).eq.lkap(k2)) then
            do 80 mp = mi,mf
              if (ipola.eq.2) dum = t3j(k2,1,mp) * t3j(k1,1,mp)
              if (ipola.eq.3) dum = t3j(k2,0,mp) * t3j(k1,0,mp)
              bmat(k1,k2) = bmat(k1,k2) + dum *
     1       (x3j(k2,-1,mp)* x3j(k1,-1,mp) - x3j(k2,1,mp)* x3j(k1,1,mp))
  80        continue
         endif
  70  continue

      return
      end
      subroutine besjn (x, jl, nl)

c-----------------------------------------------------------------------
c
c     purpose:  to calculate the spherical bessel functions jl and nl
c               for l = 0 to 30 (no offset)
c
c     arguments:
c       x = argument of jl and nl
c       jl = jl bessel function (abramowitz conventions)
c       nl = nl bessel function (abramowitz yl conventions)
c            Note that this array nl = abramowitz yl.
c       jl and nl must be dimensioned
c            complex*16 jl(ltot+2), nl(ltot+2), with ltot defined in
c            dim.h.
c
c     notes:  jl and nl should be calculated at least to 10 place
c             accuracy for the range 0<x<100 according to spot
c             checks with tables
c
c     error messages written with PRINT statement.
c
c     first coded by r. c. albers on 14 dec 82
c
c     version 3
c
c     last modified: 27 jan 83 by r. c. albers
c     dimension of jl,nl changed from 31 to 26  (10 aug 89) j. rehr
c     modified again, siz, June 1992
c
c-----------------------------------------------------------------------

      implicit double precision (a-h, o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      complex*16 x
      complex*16 jl(ltot+2), nl(ltot+2)
      complex*16 cjl(ltot+2), sjl(ltot+2), cnl(ltot+2), snl(ltot+2)

      complex*16 xjl,xnl,asx,acx
      complex*16 xi,xi2,xi3,xi4,xi5,xi6,xi7,xi8,xi9,xi10,xi11

      parameter (xcut = 1, xcut1 = 7.51, xcut2 = 5.01)

      if (dble(x) .le. 0)  stop 'Re(x) is .le. zero in besjn'

      lmaxp1 = ltot+2

      if (dble(x) .lt. xcut)  then
c        case Re(x) < 1, just use series expansion
         do 10 il = 1,lmaxp1
            l = il-1
            ifl = 0
            call bjnser (x,l,xjl,xnl,ifl)
            jl(il) = xjl
            nl(il) = xnl
   10    continue

      elseif (dble(x) .lt. xcut1)  then

c        case 1 <= Re(x) < 7.5

         call bjnser (x,lmaxp1-1,xjl,xnl,1)
         jl(lmaxp1) = xjl

         call bjnser (x,lmaxp1-2,xjl,xnl,1)
         jl(lmaxp1-1) = xjl

         if (dble(x) .lt. xcut2)  then
c           Re(x) < 5
            call bjnser (x,0,xjl,xnl,2)
            nl(1) = xnl
            call bjnser (x,1,xjl,xnl,2)
            nl(2) = xnl
         else
c           Re(x) >= 5
            asx = sin(x)
            acx = cos(x)
            xi = 1 / x
            xi2 = xi**2
            nl(1) = -acx*xi
            nl(2) = -acx*xi2 - asx*xi
         endif

c        Use recursion relation 10.1.19 to get nl and jl
         do 50 lp1 = 3, lmaxp1
            l = lp1 - 2
            tlxp1 = 2*l + 1
            nl(lp1) = tlxp1 * nl(lp1-1) / x  -  nl(lp1-2)
   50    continue

         do 60 lx = 3,lmaxp1
            lp1 = lmaxp1+1-lx
            l = lp1-1
            tlxp3 = 2*l + 3
            jl(lp1) = tlxp3 * jl(lp1+1) / x  -  jl(lp1+2)
   60    continue

      else
c        case Re(x) > 7.5
c        Use AS 10.1.8 and 10.1.9, sjl=P, qjl=Q, note that AS formulae
c        use cos (z - n*pi/2), etc., so cos and sin terms get a bit
c        scrambled (mod 4) here, since n is integer.  These are hard-
c        coded into the terms below.
         xi = 1 / x
         xi2  = xi*xi
         xi3  = xi*xi2
         xi4  = xi*xi3
         xi5  = xi*xi4
         xi6  = xi*xi5
         xi7  = xi*xi6
         xi8  = xi*xi7
         xi9  = xi*xi8
         xi10 = xi*xi9
         xi11 = xi*xi10

         sjl(1) = xi
         sjl(2) = xi2
         sjl(3) = 3.*xi3 - xi
         sjl(4) = 15.*xi4 - 6.*xi2
         sjl(5) = 105.*xi5 - 45.*xi3 + xi
         sjl(6) = 945.*xi6 - 420.*xi4 + 15.*xi2
         sjl(7) = 10395.*xi7 - 4725.*xi5 + 210.*xi3 - xi
         sjl(8) = 135135.*xi8 - 62370.*xi6 + 3150.*xi4 - 28.*xi2
         sjl(9) = 2027025.*xi9 - 945945.*xi7 + 51975.*xi5
     1            - 630.*xi3 + xi
         sjl(10) = 34459425.*xi10 - 16216200.*xi8 + 945945.*xi6
     1            - 13860.*xi4 + 45.*xi2
         sjl(11) = 654729075.*xi11 - 310134825.*xi9 + 18918900.*xi7
     1            - 315315.*xi5 + 1485.*xi3 - xi
         cjl(1) = 0
         cjl(2) = -xi
         cjl(3) = -3.*xi2
         cjl(4) = -15.*xi3 + xi
         cjl(5) = -105.*xi4 + 10.*xi2
         cjl(6) = -945.*xi5 + 105.*xi3 - xi
         cjl(7) = -10395.*xi6 + 1260.*xi4 - 21.*xi2
         cjl(8) = -135135.*xi7 + 17325.*xi5 - 378.*xi3 + xi
         cjl(9) = -2027025.*xi8 + 270270.*xi6 - 6930.*xi4 + 36.*xi2
         cjl(10) = -34459425.*xi9 + 4729725.*xi7 - 135135.*xi5
     1             + 990.*xi3 - xi
         cjl(11) = -654729075.*xi10 + 91891800.*xi8 - 2837835.*xi6
     1             + 25740.*xi4 - 55.*xi2
         do 80 ie = 1,11
            snl(ie) = cjl(ie)
            cnl(ie) = -sjl(ie)
   80    continue
         do 90 lp1 = 12,lmaxp1
            l = lp1-2
            tlxp1 = float(2*l+1)
            sjl(lp1) = tlxp1*xi*sjl(lp1-1)-sjl(lp1-2)
            cjl(lp1) = tlxp1*xi*cjl(lp1-1)-cjl(lp1-2)
            snl(lp1) = tlxp1*xi*snl(lp1-1)-snl(lp1-2)
            cnl(lp1) = tlxp1*xi*cnl(lp1-1)-cnl(lp1-2)
   90    continue
         asx = sin(x)
         acx = cos(x)
         do 110 lp1 = 1,lmaxp1
            jl(lp1) = asx*sjl(lp1)+acx*cjl(lp1)
            nl(lp1) = asx*snl(lp1)+acx*cnl(lp1)
  110    continue
      endif

      return
      end
      subroutine bjnser (x, l, jl, nl, ifl)

c-----------------------------------------------------------------------
c
c     subroutine: bjnser (x,l,jl,nl,ifl)
c
c     purpose:  to calculate the spherical bessel functions jl and nl
c
c     arguments:
c       x = argument of jl and nl
c       l = l value calculated (no offset)
c       jl = jl bessel function (abramowitz conventions)
c       nl = nl bessel function (abramowitz yl conventions)
c       ifl = 0 return both jl and nl
c             1 return jl only
c             2 return nl only
c
c     notes:  jl and nl are calculated by a series
c             expansion according to 10.1.2 and 10.1.3
c             in abramowitz and stegun (ninth printing),
c             page 437
c
c             error msgs written with PRINT statements.
c
c     first coded by r. c. albers on 26 jan 83
c
c     version 2
c
c     last modified: 27 jan 83 by r. c. albers
c
c-----------------------------------------------------------------------

      implicit double precision (a-h,o-z)

      complex*16 x,u,ux,del,pj,pn
      complex*16 jl,nl

      character*512 slog

      parameter (niter = 20, tol = 1.e-15)

      if (l .lt. 0) then
         call wlog(' l .lt. 0 in bjnser')
         stop 'bjnser 1'
      endif
   20 if (dble(x).lt. 0.) then
         write(slog,30) x
         call wlog(slog)
   30    format (' x = ', 1p, 2e14.6, ' is .le. 0 in bjnser')
         stop 'bjnser 2'
      endif

      lp1 = l+1
      u = x**2 / 2

c     make djl = 1 * 3 * 5 * ... * (2*l+1),
c          dnl = 1 * 3 * 5 * ... * (2*l-1)
      djl = 1
      fac = -1
      do 50 il = 1, lp1
         fac = fac + 2
         djl = fac * djl
   50 continue
      dnl = djl / (2*l+1)


      if (ifl .eq. 2)   goto 90
c     make jl
c     pj is term in { } in 10.1.2, del is last factor in the series
c     convergence test is (last factor)/(total term) <= tol
      pj = 1
      nf = 1
      nfac = 2*l + 3
      den = nfac
      sgn = -1
      ux = u
      do 60 il = 1, niter
         del = sgn*ux / den
         pj = pj + del
         trel = abs (del / pj)
         if (trel .le. tol)  goto 80
         sgn = -sgn
         ux = u*ux
         nf = nf+1
         nfac = nfac+2
         den = nf * nfac * den
   60 continue
      stop  'jl does not converge in bjnser'
   80 jl = pj * (x**l) / djl

   90 if (ifl.eq.1) return
c     make nl
c     pn is term in { } in 10.1.3, del is last factor in the series
c     convergence test is (last factor)/(total term) <= tol
      pn = 1
      nf = 1
      nfac = 1 - 2*l
      den = nfac
      sgn = -1
      ux = u
      do 100  il = 1, niter
         del = sgn * ux / den
         pn = pn + del
         trel = abs (del / pn)
         if (trel .le. tol) goto 120
         sgn = -sgn
         ux = u*ux
         nf = nf+1
         nfac = nfac+2
         den = nf * nfac * den
  100 continue
      stop  'nl does not converge in bjnser'
  120 nl = -pn * dnl / (x**lp1)

      return
      end
      subroutine ccrit (npat, ipat, ckspc,
     1    fbetac, xlamc, rmax, pcrith, pcritk, nncrit, ipotnn, ipot,
     2    rpath, lheap, lkeep, xcalcx)

c     lheap to add to heap, lkeep if keep path at output.
c     NB, if lheap is false, lkeep is not used (since path
c     won't be in the heap).

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      logical lheap, lkeep
      dimension ipat(npatx)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

c     local variables
      dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1)


c     mrb is efficient way to get only ri and beta
c     note that beta is cos(beta)
      call mrb (npat, ipat, ri, beta)

      rpath = 0
      do 300  i = 1, npat+1
         rpath = rpath + ri(i)
  300 continue

c     If we can decide only on rpath, do it here...
      if (rpath .gt. rmax)  then
         lheap = .false.
         lkeep = .false.
         return
      endif

c     If last atom central atom, do put in heap, don't use it
c     as an actual path at output
      if (ipat(npat).eq.0)  then
         lheap = .true.
         lkeep = .false.
         return
      endif

c     Make index into fbetac array (this is nearest cos(beta) grid
c     point, code is a bit cute [sorry!], see prcrit for grid).
      do 290  i = 1, npat+1
         tmp = abs(beta(i))
         n = tmp / 0.025
         del = tmp - n*0.025
         if (del .gt. 0.0125)  n = n+1
         if (beta(i) .lt. 0)  n = -n
         indbet(i) = n
  290 continue

c     Decide if we want the path added to the heap if necessary.
c     (Not necessary if no pcrith in use.)
      if (pcrith .gt. 0)  then

         call mcrith (npat, ipat, ri, indbet,
     1                ipot, nncrit, fbetac, ckspc, xheap)

c        xheap = -1 if not defined for this path (too few legs, etc.)
         if (xheap .ge. 0  .and.  xheap .lt. pcrith)  then
c           Do not want path in heap
            lheap = .false.
            lkeep = .false.
            return
         endif
      endif
c     Keep this path in the heap
      lheap = .true.

c     We may want path in heap so that other paths built from this
c     path will be considered, but do not want this path to be
c     written out for itself.  Decide that now and save the flag
c     in the heap, so we won't have to re-calculate the mpprm
c     path parameters later.

c     Skip calc if pcritk < 0
      if (pcritk .le. 0)  then
         lkeep = .true.
         return
      endif

c     Make xout, output inportance factor.
      call mcritk (npat, ipat, ri, beta, indbet,
     1             ipot, nncrit, fbetac, xlamc, ckspc, xout, xcalcx)

c     See if path wanted for output
c     Do not want it if last atom is central atom (xout = -1) or
c     if xout is too small
      lkeep = .false.
      if (xout .ge. pcritk)  lkeep = .true.

      return
      end
      subroutine chopen (ios, fname, mod)
c     Writes error msg and stops if error in ios flag from open
c     statement.  fname is filename, mod is module with failed open.
      character*(*) fname, mod
      character*512 slog

c     open successful
      if (ios .le. 0)  return

c     error opening file, tell user and die.
      i = istrln(fname)
      j = istrln(mod)
      write(slog,100)  fname(1:i), mod(1:j)
      call wlog(slog)

  100 format (' Error opening file, ', a,
     2        ' in module ', a)

      call wlog(' Fatal error')
      stop 'CHOPEN'
      end
      subroutine conv(omega,xsec,nxsec,omega0,efermi,xloss,xsec0)
c     multiply xsec by theta(omega-efermi) and
c     convolute xsec(omega) with  xloss/((omega-omega0)**2+xloss**2)/pi
c     the result is xsec0(omega0)

      implicit double precision (a-h, o-z)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      dimension  omega(nxsec), xsec(nxsec)

      xsec0 = 0.0d0
c     Add one more point to correct for the finite grid
c     at large energies. Use linear interpolation.
      dxlast = omega(nxsec) - omega(nxsec-1)
      dx = max(dxlast,10.0*xloss)
      xlast = omega(nxsec)+dx
      xsecdx = dx * (xsec(nxsec)-xsec(nxsec-1))/dxlast + xsec(nxsec)

c     use linear interpolation to calculate function at fermi energy.
      ifermi = locat(efermi,nxsec,omega)
      call terp(omega,xsec,nxsec,1, efermi,xsecf)

c     first interval
      xsec0 =
     1conv1( efermi,omega(ifermi+1),xsecf,xsec(ifermi+1),omega0,xloss)
      do 50  i = ifermi+1, nxsec-1
 50   xsec0 = xsec0 +
     1conv1(omega(i),omega(i+1),xsec(i),xsec(i+1),omega0,xloss)
c     last interval
      xsec0 = xsec0 +
     1conv1(omega(nxsec),xlast,xsec(nxsec),xsecdx,omega0,xloss)
      xsec0 =  xsec0 / pi

      return
      end

      double precision function conv1(x1,x2,y1,y2,x0,xloss)
c     convolution of real function with lorentzian is
c     Im part of convolution with 1/(omega-omega0-i*xloss)/pi
c     makes linear interpolation for function between x1,x2 and
c     takes advantage that the integral can be taken analytically.
      implicit double precision (a-h, o-z)
      complex*16   t, coni,dum
      parameter (coni = (0.0,1.0))

      d = (x2-x1)/2.0
      a = (y2-y1)/2.0
      b = (y2+y1)/2.0
      t = d/( (x1+x2)/2 - x0 - coni*xloss )
      if (abs(t) .ge. 0.1) then
         dum = 2.0*a + (b - a/t) * log((1+t)/(1-t))
      else
         dum = 2.0*b*(t+t**3 / 3.0) - 2.0/3.0 * a*t**2
      endif
      conv1 = dimag(dum)

      return
      end
      subroutine cpl0 (x, pl0, lmaxp1)
      implicit double precision (a-h, o-z)

c-----------------------------------------------------------------------
c
c     cpl0:  Calculate associated legendre polynomials p_l0(x)
c            by recursion.
c            Adapted from aslgndr.
c
c     first written: (25 june 86) by j. j. rehr
c
c     version 1 (25 june 86) (aslgndr)
c     version 2 (March, 1992) siz
c
c-----------------------------------------------------------------------

      dimension pl0 (lmaxp1)

      lmax = lmaxp1-1

c     calculate legendre polynomials p_l0(x) up to l=lmax
      pl0(1) = 1
      pl0(2) = x
      do 10  il = 2, lmax
         l = il-1
         pl0(il+1) = ( (2*l+1)*x*pl0(il) - l*pl0(l) ) / il
   10 continue

      return
      end
c Copyright Notice: FEFF7 is copyright protected software and users must
c obtain a license from the University of Washington Office of
c Technology Transfer for its use; see section V of FEFF document.

c Main Authors of FEFF7: please contact us concerning problems.
c A. L. Ankudinov, alex@phys.washington.edu      (206) 543 3904
c S. I. Zabinsky, zabinsky@phys.washington.edu   (???) ??? ????
c J. J. Rehr,     jjr@phys.washington.edu        (206) 543 8593
c R. C. Albers,   rca@nidhug.lanl.gov            (505) 665 0417

c Citations: Please cite at least one of the following articles if
c FEFF is used in published work:
c    1) Multiple scattering
c       J.J. Rehr and R.C. Albers, Phys. Rev. B41, 8139 (1990).
c       J.J. Rehr, S.I. Zabinsky and R.C. Albers,
c          Phys. Rev. Let. 69, 3397 (1992).
c    2) General reference
c       S.I.  Zabinsky, J.J. Rehr, A. Ankudinov, R.C. Albers, and
c       M.J. Eller, Phys. Rev. B52, 2995 (1995).
c       J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky, and R.C. Albers,
c          J. Am. Chem. Soc. 113, 5135 (1991).
c    3) Technical reference
c       J. Mustre de Leon, J.J. Rehr, S.I.  Zabinsky, and R.C. Albers,
c          Phys. Rev. B44, 4146 (1991).

      subroutine csomm (dr,dp,dq,dpas,da,m,np)
c Modified to use complex p and q.  SIZ 4/91
c integration by the method of simpson of (dp+dq)*dr**m from
c 0 to r=dr(np)
c dpas=exponential step;
c for r in the neighborhood of zero (dp+dq)=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      complex*16  dp(*),dq(*),da,dc
      mm=m+1
      d1=da+mm
      da=0.0
      db=0.0
      do 70 i=1,np
      dl=dr(i)**mm
      if (i.eq.1.or.i.eq.np) go to 10
      dl=dl+dl
      if ((i-2*(i/2)).eq.0) dl=dl+dl
   10 dc=dp(i)*dl
      da=da+dc
      dc=dq(i)*dl
      da=da+dc
   70 continue
      da=dpas*da/3
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dd=(dr(1)**mm)*(1.0+1.0/(dd*(d1+1.0)))/d1
      da=da+dd*(dp(1)+dq(1))-db*(dp(2)+dq(2))
      return
      end
      subroutine cubic (xk0, wp, alph, rad, qplus, qminus)

c     input:  xk0, wp, alph
c     output: rad, qplus, qminus

      implicit double precision (a-h, o-z)
      complex*16 s1,s13
      parameter (three = 3)
      parameter (third = 1/three)

c     this subroutine finds the roots of the equation
c     4xk0 * q^3  +  (alph-4xk0^2) * q^2  +  wp^2 = 0
c     see abramowitz and stegun pg 17 for formulae.

      a2 = (alph / (4*xk0**2)  -  1) * xk0
      a0 = wp**2 / (4*xk0)
      a1 = 0
      q = a1/3 - a2**2/9
      r = (a1*a2 - 3*a0)/6  -  a2**3/27
      rad = q**3 + r**2
      if (rad .gt. 0) then
         qplus = 0
         qminus = 0
         return
      endif

      s13 = dcmplx (r, sqrt(-rad))
      s1 = s13 ** third
      qz1 = 2*s1 - a2/3
      qz2 = -(s1 + sqrt(three)*dimag(s1) + a2/3)
      qz3 = -(s1 - sqrt(three)*dimag(s1) + a2/3)
      qplus = qz1
      qminus = qz3

      return
      end
      subroutine diff (v, dr, kap, cl, dx, n, vm)
c     calculate  vm(i)=(dV/dx)*r(i)*(kap+1)/cl
c     needed for c3 term to calculate j-average phase shift
c     ref. koelling,harmon j.phys.c,3107(1977). eq.14
      implicit double precision (a-h,o-z)
c      include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      complex*16 v(n), vm(n), vt(nrptx)
      dimension dr(n)
      do 5 i = 1,n
 5    vt(i) = v(i) * dr(i)**2

      vm(1)=((6.0*vt(2)+6.66666666667*vt(4)+1.2*vt(6))-(2.45*vt(1)+7.
     1 5*vt(3)+3.75*vt(5)+.166666666667*vt(7)))/dx
      vm(2)=((6.0*vt(3)+6.66666666667*vt(5)+1.2*vt(7))-(2.45*vt(2)+7.
     1 5*vt(4)+3.75*vt(6)+.166666666667*vt(8)))/dx
      nm2=n-2
      do 10 i=3,nm2
   10 vm(i)=((vt(i-2)+8.0*vt(i+1))-(8.0*vt(i-1)+vt(i+2)))/12.0/dx
      vm(n-1)=(vt(n)-vt(n-2))/(2.0*dx)
      vm(n)=(vt(n-2)*.5-2.0*vt(n-1)+1.5*vt(n))/dx

      do 20 i = 1,n
 20   vm(i) = (vm(i)-2*vt(i))/dr(i) *(kap+1.0)/cl
      return
      end
      double precision function dist (r0, r1)
c     find distance between cartesian points r0 and r1
      implicit double precision (a-h, o-z)
      dimension r0(3), r1(3)
      dist = 0
      do 10  i = 1, 3
         dist = dist + (r0(i) - r1(i))**2
   10 continue
      dist = sqrt (dist)
      return
      end
c***********************************************************************
c
c     this subroutine calculates the ' energy dependent
c     exchange-correlation potential' (or 'dirac- hara potential')
c     ref.: paper by s.h.chou, j.j.rehr, e.a.stern, e.r.davidson (1986)
c
c     inputs:    rs in a.u.
c                xk momentum in a.u.
c                vi0 constant imaginary part in rydbergs
c     outputs:   vr --- dirac potential (Hartrees)
c                vi --- constant imag part of the potential (Hartrees)
c     written by j. mustre 8/31/87
c**********************************************************************

      subroutine edp (rs, xk, vi0, vr, vi)
      implicit double precision (a-h, o-z)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

      vr = 0.0d0
      if (rs .gt. 100.0) goto 999
      xf = fa / rs

c     p = sqrt (k^2 + kf^2) is the local momentum, and x = p / kf
c     Reference formula 23 in Role of Inelastic effects in EXAFS
c     by Rehr and Chou. EXAFS1 conference editted by Bianconi.
c     x is local momentum in units of fermi momentum

      x = xk / xf
      x = x + 1.0e-5
c     set to fermi level if below fermi level
      if (x .lt. 1.00001) x = 1.00001
      c = abs( (1+x) / (1-x) )
      c = log(c)
      vr = - (xf/pi) * (1 + c * (1-x**2) / (2*x))

c     Note vi=vi0/2 to have both real and imaginary part in hartrees
c     to be consistent with  other subroutines.
 999  vi = vi0 / 2
      return
      end
      subroutine exconv (omega, nk, efermi, s02, erelax, wp, xmu)
      parameter (nfinex = 601)
c     convolution of xmu(e) with excitation spectrum, which is modeled
c     by: f(e) = s02*delta(e) + theta(e)*exp(-e/ed)*x1 + fp(e)
c     plasmon contribution modeled by fp(e) = theta(e-wp)*exp(-e/wp)*x2
c     normalization factors x1, x2 and distribution parameter ed are
c     found from conditions: 1) integral d(e)*f(e) = 1
c     2) integral d(e)*fp(e) = wwp  0<=wwp<1  s02+wwp<=1
c     3) integral d(e)*e*f(e) = erelax
c     Input:
c       omega - enrgy grid (e)
c       nk    - number of points in energy grid
c       efermi- fermi level
c       s02   - overlap with fully relaxed orbitals
c       erelax- relaxation energy
c       wp    - plasmon frequency
c       xmu   - original absorption coefficient
c     Output
c       xmu  - result of convolution, rewritten at the end.
c     This subroutine uses the fact, that if convolution is made for
c     e(i), then for e(i+1), the convolution integral with exp(-e/ed)
c     for e<e(i) is simply scaled by exp((e(i)-e(i+1)) / ed). This makes
c     this convolution fast.
c     written by ala. december 1995
c
      implicit double precision (a-h,o-z)
      dimension  omega(nk), xmu(nk)
c     work space
      dimension  slope(nfinex), dmu(nfinex), xmup(nfinex)

      if (s02 .ge. 0.999) return
      if (wp .le. 0.0) wp = 0.00001
      if (nk .gt. nfinex) then
         stop 'check nfinex in subroutine exconv'
      endif
c     change weight for plasmon excitation here
      wwp = 0.00
c     sm1 - weight for shake up (off) processes
      sm1 = 1.0 - s02 - wwp
      edp = wp
      ed = (erelax - wwp * (wp + edp)) / sm1
      i0 = locat (efermi, nk, omega)
      do 10 i = 1, i0
         slope(i) = 0.0
         dmu(i) = 0.0
 10   continue
      do 20 i = i0, nk - 1
 20     slope(i) = ed * (xmu(i+1) - xmu(i)) / (omega(i+1) - omega(i))
      call terp (omega, xmu, nk, 1, efermi, xmuf)

c     start induction
      xmult = exp ((efermi - omega(i0+1)) / ed)
      dmu(i0+1) = xmu(i0+1) - slope(i0) - xmult * (xmuf - slope(i0))
      do 50 i = i0 + 1, nk - 1
         xmult = exp ((omega(i) - omega(i+1)) / ed)
         dmu(i+1) = xmu(i+1) - slope(i) + xmult*(dmu(i)-xmu(i)+slope(i))
 50   continue
      do 55 i = 1, nk
 55   xmup(i) = s02 * xmu(i) + sm1 * dmu(i)

c     do convolution with plasmon pole
      do 60 i = i0, nk - 1
 60     slope(i) = slope(i) / ed * edp
      xmult = exp ((efermi - omega(i0+1)) / edp)
      dmu(i0+1) = xmu(i0+1) - slope(i0) - xmult * (xmuf - slope(i0))
      do 70 i = i0 + 1, nk - 1
         xmult = exp ((omega(i) - omega(i+1)) / edp)
         dmu(i+1) = xmu(i+1) - slope(i) + xmult*(dmu(i)-xmu(i)+slope(i))
 70   continue

      do 90 i = 1, nk
        en = omega(i) - wp
        j0 = locat(en, nk, omega)
        if (en .gt. efermi) then
           xmult = exp ((omega(j0) - en) / edp)
           dif = xmu(j0) - slope(j0)
           xmup(i) = xmup(i) + wwp * (xmult * (dmu(j0) - dif) + dif +
     1                            slope(j0) * (en - omega(j0)) / edp)
        endif
 90   continue

      do 200 i = 1, nk
 200  xmu(i) = xmup(i)

      return
      end
      subroutine exjlnl (z, l, jl, nl)

c     purpose:  to calculate the spherical bessel functions jl and nl
c               for l = 0, 1, 2 or 3 using exact analytic expression
c
c     arguments:
c       z = argument of jl and nl
c       l = integer order of spherical bessel function
c       jl = jl bessel function (abramowitz conventions)
c       nl = nl bessel function (abramowitz yl conventions)
c            Note that this nl = abramowitz yl.
c
c       analytic expressions from abramowitz 10.1.11 and 10.1.12
c       recurrence relation to get analytic j4,n4  eqns 10.1.19-22 ala

      implicit double precision (a-h, o-z)

      complex*16 z, jl, nl

      complex*16 cosz, sinz

c     Exact formulae unstable for very small z, so use series
c     expansion there.  Limit of .3 chosen for 9 digit agreement.
      if (abs(z) .lt. 0.3)  then
         call bjnser (z, l, jl, nl, 0)
      else
c        use analytic formulae
         cosz = cos(z)
         sinz = sin(z)

         if (l .eq. 0)  then
            jl =  sinz / z
            nl = -cosz / z

         elseif (l .eq. 1)  then
            jl =  sinz/z**2 - cosz/z
            nl = -cosz/z**2 - sinz/z

         elseif (l .eq. 2)  then
            jl = ( 3/z**3 - 1/z)*sinz - 3*cosz/z**2
            nl = (-3/z**3 + 1/z)*cosz - 3*sinz/z**2

         elseif (l .eq. 3)  then
            jl = ( 15/z**4 - 6/z**2)*sinz + (-15/z**3 + 1/z)*cosz
            nl = (-15/z**4 + 6/z**2)*cosz + (-15/z**3 + 1/z)*sinz

         elseif (l .eq. 4)  then
            jl = ( 105/z**5 - 45/z**3 + 1/z )*sinz +
     1                ( -105/z**4 + 10/z**2 )*cosz
            nl = (-105/z**5 + 45/z**3 - 1/z )*cosz +
     1                ( -105/z**4 + 10/z**2 )*sinz

         elseif (l .eq. 5)  then
            jl = ( 945/z**6 - 420/z**4 + 15/z**2 )*sinz +
     1              ( -945/z**5 + 105/z**3 - 1/z )*cosz
            nl = (-945/z**6 + 420/z**4 - 15/z**2 )*cosz +
     1              ( -945/z**5 + 105/z**3 - 1/z )*sinz

         else
            stop 'exjlnl, l out of range'
         endif
      endif

      return
      end
      subroutine fermi (rhoint, vint, xmu, rs, xf)

      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

c     calculate fermi level of the system (mu) according to formula
c     mu=vcoulomb(interstitial)+vxc(interstitial)+kf(interstitial)^2
c     formula  2.13 in lee and beni, phys. rev. b15,2862(1977)

c     note that vint includes both coulomb and ground state
c     exchange-correlation potentials

c     den is the interstitial density
c     rs is the density parameter
c     xf is the interstital fermi momentum
c     xmu is the fermi level in rydbergs

      den = rhoint / (4*pi)
      rs = (3 / (4*pi*den)) ** third
      xf = fa / rs
      xmu = vint + xf**2

      return
      end
      subroutine ff2chi (ipr4, critcw, s02, sig2g,tk, thetad, mbconv,
     1                   vrcorr, vicorr, xloss, zzcrit, zzkmin, zzkmax,
     1                   alphat)
      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      parameter (eps4 = 1.0e-4)

c     header from list.dat
      parameter (nheadx = 30)
      character*80  head(nheadx)
      dimension lhead(nheadx)
c     header from xsect.bin
      character*80 hdxs(nheadx)
      dimension lhdxs(nheadx)

      parameter (npx = 1000)
c     indices of paths to do, read from list.dat
      dimension ip(npx)
      real sig2u(npx)

      parameter (nfinex = 601)
      complex*16 cchi(nfinex), ccpath(nfinex), ccc, ckp
      complex*16 dw, dw1, dw3
      dimension xkp(nfinex), xk0(nfinex), rchimu(nfinex)
      dimension acpath(nfinex)

      logical wxmu, dwcorr
      dimension rattmp(3,0:legtot)
      dimension iztmp(0:legtot)
      character*512 slog
      character*12 fname

c     Stuff from feff.bin, note that floating point numbers are
c     single precision.  Be careful throughout this routine, especially
c     when passing things to subroutines or intrinsic functions.
      character*78 string
      real rnrmav, xmu, edge
      dimension ltext(nheadx)
      character*80 text(nheadx)
      character*6  potlbl(0:npotx)
      dimension iz(0:npotx)
c     central atom phase shift at l0
      complex phc(nex)
      real erefim(nex)
      complex ck(nex)
      real xk(nex)
      dimension index(npx)
      dimension nleg(npx)
      real deg(npx), reff(npx), crit(npx)
      dimension ipot(legtot,npx)
      real rat(3,legtot,npx)
      real beta(legtot,npx)
      real eta(legtot,npx)
      real ri(legtot,npx)
      real achi(nex,npx), phchi(nex,npx)

c     stuff from xsect.bin
      dimension emxs(nex),omega(nex), xkxs(nex), xsec(nex), xsnorm(nex)
      dimension omegax(nfinex)


c     open list.dat and read list of paths we want
      open (unit=1, file='list.dat', status='old', iostat=ios)
      call chopen (ios, 'list.dat', 'ff2chi')
      nhead = nheadx
      call rdhead (1, nhead, head, lhead)
c     skip a label line
      read(1,*)
      ntotal = 0
c     ip is index of path, sig2u is debye-waller from user
      do 100  i = 1, npx
         read(1,*,end=110)  ip(i), sig2u(i)
         ntotal = i
  100 continue
  110 continue
      close (unit=1)


c     Use single precision for all fp numbers in feff.bin
      open (unit=3, file='feff.bin', status='old',
     1      access='sequential', form='unformatted', iostat=ios)
      read(3) string
      read(3) ntext
      do 120  itext = 1, ntext
c        text(itext) does not have carriage control
         read(3) ltext(itext)
         read(3) text(itext)
  120 continue
      read(3) ne, npot, ihole, methfs, rnrmav, xmu, edge, ik0, iorder,l0
      read(3) (potlbl(i),i=0,npot)
      read(3) (iz(i),i=0,npot)
      read(3) (phc(ie),ie=1,ne)
      read(3) (erefim(ie),ie=1,ne)
      read(3) (ck(ie),ie=1,ne)
      read(3) (xk(ie),ie=1,ne)
      nptot = 0
      do 140  i = 1, npx
         read(3,end=150) itmp
         nptot = nptot + 1
         index(i) = itmp
         read(3) nleg(i), deg(i), nsc, reff(i), crit(i)
         read(3) (ipot(j,i),j=1,nleg(i))
         read(3) ( (rat(k,j,i),k=1,3), j=1,nleg(i) )
         read(3) (beta(j,i),j=1,nleg(i))
         read(3) (eta(j,i),j=1,nleg(i))
         read(3) (ri(j,i),j=1,nleg(i))
         do 130  ie = 1, ne
            read(3) achi(ie,i), phchi(ie,i)
  130    continue
  140 continue
  150 continue
      close (unit=3)
      erefre = dble(ck(1)**2) - xk(1)*abs(xk(1))

c     write feffnnnn.dat
      if (methfs.eq.0 .and. ipr4.ge.3) call feffdt (ntotal, ip)
      if (methfs.eq.2) call wlog
     1('WARNING:no chi.dat, chipNNNN.dat, feffNNNN.dat with XANES card')

c     If there is a vicorr, will need a mean free path factor xlam0.
c     Use it as  chi(ie) * exp (2 * reff * xlam0)
c     ckp is ck' = ck prime.
      if (abs(vicorr) .ge. eps4 .and. (methfs.eq.0.or.methfs.eq.3)) then
         do 180  ie = 1, ne
            ckp = sqrt (ck(ie)**2 + coni*vicorr)
            xlam0 = aimag(ck(ie)) - dimag(ckp)
            do 170  ipath = 1, nptot
               achi(ie,ipath) = achi(ie,ipath) *
     1               exp (2 * reff(ipath) * xlam0)
  170       continue
  180    continue
      endif

c     Decide on fine grid.  We need two, k' evenly spaced by
c     delk (0.05 invA) and k0 being the place in the original k
c     grid corresponding to each k'.  k0 will not in general be on
c     an original grid point.  Define k' by k'**2 = k**2 + vr.
c     If there is no real correction (vrcorr = 0), these two grids
c     will be the same.

c     vrcorr shifts the edge and the k grid
      if (abs(vrcorr) .gt. eps4)  then
         edge = edge - vrcorr
      endif

c     Find xkmin, beginning of k' grid
      delk = 0.05 * bohr
      tmp = sign (real(one), xk(1))
      e = tmp * xk(1)**2 + vrcorr
      xkpmin = getxk (e)
      n = xkpmin / delk
c     need 1st int ABOVE xkpmin/delk
      if (xkpmin .gt. 0)  n = n + 1
c     First k grid point moved by vrcorr
      xkmin = n * delk

c     Make xkp (k') and xk0 (k0) fine grids
      do 250  i = 1, nfinex
         xkp(i) = xkmin + delk * (i - 1)
         tmp = sign (one, xkp(i))
         e = tmp * xkp(i)**2 - vrcorr
         xk0(i) = getxk(e)
         if (xk0(i) .gt. xk(ne)+eps4)  goto 260
         nkx = i
  250 continue
  260 continue

      dwcorr = .false.
      if (tk .gt. 1.0e-3)  dwcorr = .true.

c     Open chi.dat and xmu.dat (output) and start header
      open (unit=3, file='chi.dat', status='unknown', iostat=ios)
      call chopen (ios, 'chi.dat', 'ff2chi')
      open (unit=8, file='xsect.bin', status='old', iostat=ios)
      wxmu = .false.
      if (ios .eq. 0)  wxmu = .true.
      if(wxmu) then
c        read xsect.bin
         nhdxs = nheadx
         call rdhead (8, nhdxs, hdxs, lhdxs)
c        read method for xsec calculation
         read(8,*)  methat, s02p, erelax, wp
         if (mbconv .gt.0 .or. s02.le.0.1) s02=s02p
c        read gamach (in eV) for use in atan at absorption edge
c        and convert to code units
         read(8,*)  gamach
         gamach = gamach / ryd
c        skip label
         read(8,*)
         i = 1
  300    read(8,*,end=310)  emxs(i), omega(i),xkxs(i),xsnorm(i),xsec(i)
c           xsect.bin is in eV and invA, convert to code units here
            emxs(i) = emxs(i) / ryd
            omega(i) = omega(i) / ryd
            xkxs(i) = xkxs(i) * bohr
            nxsec = i
            i = i + 1
            goto 300
  310    continue
         close(unit=8)

         open (unit=8, file='xmu.dat', status='unknown', iostat=ios)
         call chopen (ios, 'xmu.dat', 'ff2chi')
      endif

      do 330  ihead = 1, nhead
         if (lhead(ihead) .gt. 0)  then
            write(3,320) head(ihead)(1:lhead(ihead))
            if(wxmu) write(8,320) head(ihead)(1:lhead(ihead))
         endif
  320    format (a)
  330 continue
      if (dwcorr)  then
         write(3,340)  s02, tk, thetad, sig2g
         if(wxmu) write(8,340)  s02, tk, thetad, sig2g
  340    format (' S02', f7.3, '  Temp', f8.2, '  Debye temp', f8.2,
     1           '  Global sig2', f9.5)
      else
         write(3,341)  s02, sig2g
         if(wxmu) write(8,341)  s02, sig2g
  341    format (' S02', f7.3,
     1   '                                        Global sig2', f9.5)
      endif
      if (alphat .gt. zero)  then
         write(3,321)  alphat
         if(wxmu)  write(8,321)  alphat
  321    format (' 1st and 3rd cumulants, alphat = ', 1pe20.4)
         write(slog,322) alphat
  322    format ('    1st and 3rd cumulants, alphat = ', 1pe20.4)
      endif

      if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
         write(3,342) vrcorr*ryd, vicorr*ryd
         if(wxmu) write(8,342) vrcorr*ryd, vicorr*ryd
         write(slog,343) vrcorr*ryd, vicorr*ryd
         call wlog(slog)
      endif
  342 format (' Energy zero shift, vr, vi ', 1p, 2e14.5)
  343 format ('    Energy zero shift, vr, vi ', 1p, 2e14.5)
      if (zzcrit .gt. eps4)  then
         write(slog,345)  zzcrit, zzkmin/bohr, zzkmax/bohr
  345    format('    Custom filter ', f10.2, '%, kmin and kmax ',
     1          2f10.4)
         call wlog(slog)
         write(3,346)  zzcrit, zzkmin/bohr, zzkmax/bohr
         if(wxmu) write(8,346)  zzcrit, zzkmin/bohr, zzkmax/bohr
  346    format(' Custom filter ', f10.2, '%, kmin and kmax ',
     1          2f10.4)
      endif

      if (critcw .gt. 0)  write(3,350) critcw
      if (critcw .gt. 0 .and. wxmu)  write(8,350) critcw
  350 format (' Curved wave amplitude ratio filter ', f7.3, '%')
      write(3,360)
      if(wxmu) write(8,360)
  360 format ('    file         sig2 tot  cw amp ratio   deg',
     1        '  nlegs   reff  inp sig2')
      write(slog,370) critcw
      call wlog(slog)
  370 format ('    Use all paths with cw amplitude ratio', f7.2, '%')
      if (dwcorr)  then
         write(slog,380) s02, tk, thetad, sig2g
         call wlog(slog)
      else
         write(slog,381) s02, sig2g
         call wlog(slog)
      endif
c     These formats same as 340 and 341 except for leading white space
  380 format('    S02', f7.3, '  Temp', f8.2, '  Debye temp', f8.2,
     1           '  Global sig2', f9.5)
  381 format('    S02', f7.3, '  Global sig2', f9.5)


c     Ready to go...

c     Keep stats on paths used to make chi
      nused = 0
      zzmax = eps4

c     make chi and sum it
      do 400  i = 1, nfinex
         cchi(i) = 0
  400 continue
      do 560  ilist = 1, ntotal
c        find index of path
         do 410  j = 1, nptot
            if (ip(ilist) .eq. index(j))  then
               ipath = j
               goto 430
            endif
  410    continue
         write(slog,420)  ilist, ip(ilist)
  420    format (' did not find path i, ip(i) ', 2i10)
         call wlog(slog)
  430    continue
c        Path ipath is the path from feff.bin that corresponds to
c        the path ilist in list.dat.  The index of the path is
c        ip(ilist) and index(ipath).

c        Use this path if it passes critcw filter
         if (crit(ipath) .lt. critcw)  goto 550

c        do debye-waller factors, get sig2d from correlated debye
c        model if required
c        A note about units:  sig2g, sig2u() and sig2d are all in
c        Angs**2.  Convert to code units after we've summed them.
         sig2 = sig2g + sig2u(ilist)
         if (dwcorr)  then
c           note that stuff from feff.bin is single precision and
c           mostly in multidim. arrays.  sigms is double precision
c           and its arrays are dimensioned for a single path, so
c           use tmp variables to call it.  tk, thetad and sig2d are
c           all dp, and therefore OK.  Also note that sigms takes
c           inputs in angstroms, except for rs which is in bohr.
            rs = rnrmav
            do 460  ileg = 1, nleg(ipath)
               iztmp(ileg) = iz(ipot(ileg,ipath))
               do 450  j = 1, 3
                  rattmp(j,ileg) = rat(j,ileg,ipath) * bohr
  450          continue
  460       continue
            iztmp(0) = iztmp(nleg(ipath))
            do 470  j = 1,3
               rattmp(j,0) = rattmp(j,nleg(ipath))
  470       continue
            call sigms (tk, thetad, rs, legtot, nleg(ipath),
     1                  rattmp, iztmp, sig2d)
            sig2 = sig2 + sig2d
         endif
         sig2 = sig2 / (bohr**2)

c        Do first and third cumulants
         sig1 = 0
         sig3 = 0
         if (alphat .gt. zero  .and. nleg(ipath) .eq. 2)  then
c           call sig3  this gets sig1 and sig3 for single scattering
c                   paths
c           use reff(ipath) for r, note that reff is single precision
         endif

c        put the debye-waller factor and other cumulants into
c        achi and phchi
         if (mbconv .gt. 0) s02 = 1.0
         do 480  i = 1, ne
            dw = exp(-2 * sig2 * ck(i)**2)
            dw1 = exp (2 * coni * ck(i) * sig1)
            dw3 = exp ((-4 * coni * ck(i)**3 * sig3) / 3)
            dw = dw * dw1 * dw3
            phdw = atan2 (dimag(dw), dble(dw))
            achi(i,ipath) = achi(i,ipath) * abs(dw) * s02 * deg(ipath)
            phchi(i,ipath) = phchi(i,ipath) + phdw
  480    continue
c        make sure no 2pi jumps in phase
         do 490  i = 2, ne
c           phchi is single precision, so use tmp variables
            curr = phchi (i, ipath)
            old = phchi (i-1, ipath)
            call pijump (curr, old)
            phchi (i, ipath) = curr
  490    continue

         do 500  ik = 1, nkx
            call terp1 (xk, achi(1,ipath),  ne, xk0(ik), achi0)
            call terp1 (xk, phchi(1,ipath), ne, xk0(ik), phchi0)
            ccpath(ik) =
     1        achi0 * exp (coni * (2 * xk0(ik) * reff(ipath) + phchi0))
c           acpath is |chi| for the path, used for custom crits
c           note that this already includes s02, deg, sig2, etc.

            ckp = sqrt (xkp(i)*abs(xkp(i)) + erefre)
            xlam0 =  - dimag(ckp)
            acpath(ik) = achi0 * exp(2 * reff(ipath) * xlam0)
  500    continue

c        check custom filter criteria if necessary
         if (zzcrit .ge. eps4)  then

            call custom (nkx, acpath, xkp, zzkmin, zzkmax, zzport)
            if (zzport .gt. zzmax)  zzmax = zzport
            zzport = (zzport / zzmax) * 100
c           skip the rest of this if path filtered out
            if (zzport .lt. zzcrit)  goto 550
c           if using custom crits, replace path's critcw with zzport
            crit(ipath) = zzport
         endif

         nused = nused + 1
c        sum total complex chi
         do 510  ik = 1, nkx
            cchi(ik) = cchi(ik) + ccpath(ik)
  510    continue

c        Put path into chi.dat, xmu.dat as required
         if (abs(sig2u(ilist)) .gt. 0.000001)  then
            write(3,515)  index(ipath), sig2*(bohr**2), crit(ipath),
     1            deg(ipath), nleg(ipath), reff(ipath)*bohr,
     1            sig2u(ilist)
            if(wxmu) write(8,515)  index(ipath), sig2*(bohr**2),
     1            crit(ipath),
     1            deg(ipath), nleg(ipath), reff(ipath)*bohr,
     1            sig2u(ilist)
         else
            write(3,515)  index(ipath), sig2*(bohr**2), crit(ipath),
     1                 deg(ipath), nleg(ipath), reff(ipath)*bohr
            if(wxmu) write(8,515)  index(ipath), sig2*(bohr**2),
     1                  crit(ipath),
     1                 deg(ipath), nleg(ipath), reff(ipath)*bohr
         endif
  515    format(1x, i10, 5x, f9.5, 2f10.2, i6, f9.4, f9.5)

c        write out a chinnnn.dat for this path, if necessary.
         if (methfs.eq.0 .and. ipr4 .ge. 2 .and. ipr4.ne.3)  then
c           make filename chipnnnn.dat
            write(fname,520)  index(ipath)
  520       format('chip', i4.4, '.dat')
            open (unit=9, file=fname, status='unknown',iostat=ios)
            call chopen (ios, fname, 'ff2chi')
            do 530  ihead = 1, nhead
               if (lhead(ihead) .gt. 0)  then
                  write(9,320) head(ihead)(1:lhead(ihead))
               endif
  530       continue
            if (dwcorr)  then
               write(9,340)  s02, tk, thetad, sig2g
            else
               write(9,341)  s02, sig2g
            endif
            if (alphat .gt. zero)  then
               write(9,321)  alphat
            endif

            if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
               write(9,342)  vrcorr, vicorr
            endif
            write(9,*) 'Debye-waller factor ', sig2

            write(9,610)
            write(9,535)
  535       format ('       k         chi           mag          ',
     1              'phase        phase-2kr  @#')
            do 540  i = 1, nkx
               ckp = sqrt (xkp(i)*abs(xkp(i)) + erefre)
               xlam0 =  - dimag(ckp)
               ccc = ccpath(i) * exp(2 * reff(ipath) * xlam0)
               phase = 0
               if (abs(ccc) .gt. 0)  phase=atan2(dimag(ccc), dble(ccc))
               if (i .gt. 1)  call pijump (phase, phase0)
               phase0 = phase
               write(9,630)  xkp(i)/bohr, dimag(ccc), abs(ccc), phase,
     1                       phase-2*xk0(i)*reff(ipath)
  540       continue
            close (unit=9)
         endif

  550    continue
  560 continue

c     Write it out

      write(3,600)  nused, ntotal
      if(wxmu) write(8,600)  nused, ntotal
  600 format (1x, i4, '/', i4, ' paths used')
      write(3,610)
  610 format (1x, 71('-'))
      write(3,620)
  620 format ( '      k          chi          mag           phase @#')

c     Write cross section
      if(wxmu)  then
c        normalize to xsec 100 eV above edge
         edg100 = edge + 100 / ryd
         call terp (emxs, xsnorm,  nxsec, 1, edg100, xsedge)
         write(8,660)  xsedge
  660    format (' xsedge+100, used to normalize mu ', 1pe20.4)
         write(8,610)
         write(8,*) ' e, e(wrt edge), k, mu=(1+chi)*mu0, mu0, chi @#'
c        check grid
         do 680 i = 1, nxsec
            del = xk(i) - xkxs(i)
            if (abs(del) .gt. eps4)  then
               call wlog(' Emesh in feff.bin and xsect.bin different.')
               call wlog
     1           (' Results may be meaningless, check input files.')
               write(slog,670)  i, xk(i)/bohr, xkxs(i)/bohr, del
               call wlog(slog)
  670          format(i7, 1p, 3e13.5)
            endif
  680    continue

c        put xsec onto fine grid,
         xloss = xloss + vicorr
         do 690  ik = 1, nkx
            call terp (xkxs, xsnorm,  nxsec, 1, xk0(ik), xsnrm0)
            rchimu(ik) = xsnrm0 * dimag(cchi(ik))
            call terp (xkxs, omega, nxsec, 1, xk0(ik), omegax(ik))
  690    continue
      else
c        need to calculate convolution for chi only
         xsnrm0 = 1.0d0
         do 590  ik = 1, nkx
            rchimu(ik) = dimag(cchi(ik))
            if (xkp(ik) .lt. 0.0) then
               omegax(ik) = - xkp(ik) * xkp(ik)
            else
               omegax(ik) = xkp(ik) * xkp(ik)
            endif
  590    continue
c        define omega(1) to have 'edge' at zero
         omega(1) = - edge
      endif

c     do convolution with excitation spectrum
c     fix later . works properly only for methfs =1,2
      wp = wp / 2.
      if (mbconv .gt. 0 .and. wxmu) then
         efermi = edge + omega(1) - emxs(1)
         call  exconv
     1   (omega, nxsec, efermi, s02p, erelax, wp, xsec)
         call  exconv
     1   (omegax, nkx, efermi, s02p, erelax, wp, rchimu)
      endif

c     do convolution or arctan correction depending on methat
      do 750  ik = 1, nkx
c        k' is value for output, k0 is k value used for
c        interpolation with original grid.

         if (wxmu) then
            call terp (xkxs, emxs,  nxsec, 1, xk0(ik), em0)
            if (methat .ge. 0 .and. methat .le. 3) then
               efermi = edge + omega(1) - emxs(1)
               call conv (omega, xsec, nxsec, omegax(ik),
     1                     efermi, xloss, xsec0)
               call conv (omega, xsnorm, nxsec, omegax(ik),
     1                     efermi, xloss, xsnrm0)
            else
               stop 'unidentified methat'
            endif
         endif

         if (methfs .eq. 0 .or. methfs .eq. 3) then
            chi0 = dimag (cchi(ik)) * xsnrm0
         elseif (methfs .eq. 1) then
            efermi = edge + omega(1) - emxs(1)
            call terp1 (xk, erefim,  ne, xk0(ik), xloss1)
            xloss1 = - xloss1 + vicorr
            call conv (omegax, rchimu, nkx, omegax(ik),
     1                 efermi, xloss1, chi0)
         elseif (methfs .eq. 2) then
            efermi = edge + omega(1) - emxs(1)
            call conv (omegax, rchimu, nkx, omegax(ik),
     1                 efermi, xloss, chi0)
         else
            stop 'unidentified methfs'
         endif

         if (wxmu) then
            chitot = chi0 / xsnrm0
c           correct later xsec using irregular solution for methat=2,3

            write(8,700)  omegax(ik)*ryd, em0*ryd, xkp(ik)/bohr,
     1                    ( chi0 + dble(xsec0) )/xsedge,
     1                    xsnrm0/xsedge, chitot
  700       format (1x, 2f11.3, f8.3, 1p, 3e13.5)
         else
            chitot = chi0
         endif

c        write to 'chi.dat'
         ccc = cchi(ik)
         phase = 0
         if (abs(ccc) .gt. 0)  then
            phase = atan2 (dimag(ccc), dble(ccc))
         endif
         if (ik .gt. 1)  call pijump (phase, phase0)
         phase0 = phase
         if (methfs.eq.0)
     1      write(3,630)  xkp(ik)/bohr,chitot , abs(ccc), phase0
  630    format (1x, f10.4, 3x, 4(1pe13.6,1x))
  750 continue
      if (wxmu)  close (unit=8)
      close (unit=3)

      return
      end

c     These routines, terp1 and locat1, are special versions to
c     be used with ff2chi, which uses some single and some double
c     precision.  They are the same as the routines in terp.f.

      subroutine terp1 (x, y, n, x0, y0)
      implicit double precision (a-h, o-z)

      real x(n), y(n)

c     Find out between which x points x0 lies
      i = locat1 (x0, n, x)
c     if i < 1, set i=1, if i > n-1, set i=n-1
      i = max (i, 1)
      i = min (i, n-1)

      if (x(i+1) - x(i) .eq. 0)  stop 'TERP-1'

      y0 = y(i) +  (x0 - x(i)) * (y(i+1) - y(i)) / (x(i+1) - x(i))

      return
      end

      function locat1 (x, n, xx)
      double precision x
      real xx(n)
      integer  u, m, n

c     Binary search for index of grid point immediately below x.
c     Array xx required to be monotonic increasing.
c     Returns
c     0            x <  xx(1)
c     1            x =  xx(1)
c     i            x =  xx(i)
c     n            x >= xx(n)

      locat1 = 0
      u = n+1

   10 if (u-locat1 .gt. 1)  then
         m = (u + locat1) / 2
         if (x .lt. xx(m))  then
            u = m
         else
            locat1 = m
         endif
         goto 10
      endif

      return
      end
      double precision function ffq (q, ef, xk, wp, alph)
      implicit double precision (a-h,o-z)

c     input:  q, wp, alph, ef, xk
c             q is dimensionless, normalized to fermi momentum
c             xk is momentum in invBohrs
c     output: ffq only

      wq = sqrt (wp**2 + alph*q**2 + q**4)
      ffq = (wp+wq)/(q**2) + alph/(2*wp)
      ffq = ((ef*wp) / (4*xk))  * log(ffq)

      return
      end
      subroutine feffdt (ntotal, iplst)
c     this reads feff.bin, writes feff.dat's and
c     files.dat for compatibility with the old feff
      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'vers.h'
      character*12 vfeff
      common /vers/ vfeff
      parameter (eps4 = 1.0e-4)
      parameter (eps = 1.0e-16)

      parameter (npx = 1000)
      character*12 fname(npx)
      character*512 slog
      dimension iplst(npx)

c     Stuff from feff.bin, note that floating point numbers are
c     single precision
      character*78 string
      real rnrmav, xmu, edge
      parameter (nheadx = 30)
      dimension ltext(nheadx)
      character*80 text(nheadx)
      character*6  potlbl(0:npotx)
      dimension iz(0:npotx)
c     central atom phase shift at l0
      complex phc(nex)
      real erefim(nex)
      complex ck(nex)
      complex*16 ckp, ccc
      real xk(nex)
      dimension index(npx)
      dimension nleg(npx)
      real deg(npx), reff(npx), crit(npx)
      dimension ipot(legtot,npx)
      real rat(3,legtot,npx)
      real beta(legtot,npx)
      real eta(legtot,npx)
      real ri(legtot,npx)
      real achi(nex,npx), phchi(nex,npx)

      complex*16 cchi, cfms

      call wlog (' feffdt, feff.bin to feff.dat conversion ' // vfeff)

c     read feff.bin
c     Use single precision for all fp numbers in feff.bin
      open (unit=3, file='feff.bin', status='old',
     1      access='sequential', form='unformatted', iostat=ios)
      read(3) string
      read(3) ntext
      do 10  itext = 1, ntext
c        text(itext) does not have carriage control
         read(3) ltext(itext)
         read(3) text(itext)
   10 continue
      call wlog (' feff.bin header')
      do 20  itext = 1, ntext
c        text(itext) does not have carriage control
         call wlog (' ' // text(itext)(1:ltext(itext)))
   20 continue
      read(3) ne, npot, ihole, methfs, rnrmav, xmu, edge, ik0, iorder,l0
      read(3) (potlbl(i),i=0,npot)
      read(3) (iz(i),i=0,npot)
      read(3) (phc(ie),ie=1,ne)
      read(3) (erefim(ie),ie=1,ne)
      read(3) (ck(ie),ie=1,ne)
      read(3) (xk(ie),ie=1,ne)
      nptot = 0
      do 40  i = 1, npx
         read(3,end=50) itmp
         nptot = nptot + 1
         index(i) = itmp
         read(3) nleg(i), deg(i), nsc, reff(i), crit(i)
         read(3) (ipot(j,i),j=1,nleg(i))
         read(3) ( (rat(k,j,i),k=1,3), j=1,nleg(i) )
         read(3) (beta(j,i),j=1,nleg(i))
         read(3) (eta(j,i),j=1,nleg(i))
         read(3) (ri(j,i),j=1,nleg(i))
         do 30  ie = 1, ne
            read(3) achi(ie,i), phchi(ie,i)

c           fix later: it is possible to do convolution here, but
c           the result may be different only in xanes region.
c           ala 1.23.96. Check losses for this case later. ala
c           instead add loss term and phase for methfs=1,2.
            if (methfs.eq.1 .or. methfs.eq.2) then
               if (methfs.eq.1) then
                  ckp = sqrt (ck(ie)**2 - coni * erefim(ie))
               else
                  ckp = sqrt (ck(ie)**2 - coni * erefim(1) )
               endif
               xlam0 = aimag(ck(ie)) - dimag(ckp)
               ccc =  ck(ie) / ckp
               phase = nleg(i) * atan2 (dimag(ccc), dble(ccc))
               achi(ie,i) = achi(ie,i) * abs(ccc) *
     1                      exp(2 * reff(i) * xlam0)
               phchi(ie,i) = phchi(ie,i) + phase
            endif
   30    continue
   40 continue
   50 continue
      close (unit=3)
      write(slog,60)  nptot
   60 format (i8, ' paths to process')
      call wlog (slog)

c     make files.dat
  150 format (a)
  160 format (1x, a)
  170 format (1x, 71('-'))

c     Save filenames of feff.dat files
      open (unit=2, file='files.dat', status='unknown', iostat=ios)
      call chopen (ios, 'files.dat', 'genfmt')
c     Put phase header on top of files.dat
      do 200  itext = 1, ntext
         write(2,160)  text(itext)(1:ltext(itext))
  200 continue
      write(2,170)
      write(2,210)
  210 format ('    file        sig2   amp ratio    ',
     1        'deg    nlegs  r effective')
c     do each path
      call wlog ('    path     filename')

      do 500  ilist = 1, ntotal
c        find index of path
         do 410  j = 1, nptot
            if (iplst(ilist) .eq. index(j))  then
               i = j
               goto 430
            endif
  410    continue
         write(slog,420)  ilist, iplst(ilist)
  420    format (' did not find path i, iplst(i) ', 2i10)
         call wlog(slog)
  430    continue
c        Path i is the path from feff.bin that corresponds to
c        the path ilist in list.dat.  The index of the path is
c        iplst(ilist) and index(i).

c        Prepare output file feffnnnn.dat
         write(fname(i),220)  index(i)
  220    format ('feff', i4.4, '.dat')
         write(slog,230)  i, fname(i)
  230    format (i8, 5x, a)
         call wlog(slog)
c        zero is debye-waller factor column
         write(2,240) fname(i), zero, crit(i), deg(i),
     1                   nleg(i), reff(i)*bohr
  240    format(1x, a, f8.5, 2f10.3, i6, f9.4)

         ip = i
c     Write feff.dat's
         open (unit=3, file=fname(ip), status='unknown', iostat=ios)
         call chopen (ios, fname(ip), 'feffdt')
c        put header on feff.dat
         do 300  itext = 1, ntext
            write(3,160)  text(itext)(1:ltext(itext))
  300    continue
         write(3,310) ip, iorder
  310    format (' Path', i5, '      icalc ', i7)
         write(3,170)
         write(3,320)  nleg(ip), deg(ip), reff(ip)*bohr, rnrmav,
     1                 edge*ryd
  320    format (1x, i3, f8.3, f9.4, f10.4, f11.5,
     1           ' nleg, deg, reff, rnrmav(bohr), edge')
         write(3,330)
  330    format ('        x         y         z   pot at#')
         write(3,340)  (rat(j,nleg(ip),ip)*bohr,j=1,3),
     1                 ipot(nleg(ip),ip),
     1                 iz(ipot(nleg(ip),ip)), potlbl(ipot(nleg(ip),ip))
  340    format (1x, 3f10.4, i3, i4, 1x, a6, '   absorbing atom')
         do 360  ileg = 1, nleg(ip)-1
            write(3,350)  (rat(j,ileg,ip)*bohr,j=1,3), ipot(ileg,ip),
     1                    iz(ipot(ileg,ip)), potlbl(ipot(ileg,ip))
  350       format (1x, 3f10.4, i3, i4, 1x, a6)
  360    continue

         write(3,370)
  370    format    ('    k   real[2*phc]   mag[feff]  phase[feff]',
     1              ' red factor   lambda     real[p]@#')

c        Make the feff.dat stuff and write it to feff.dat
c        Also write out for inspection to fort.66
c        note that dimag takes complex*16 argument, aimag takes
c        single precision complex argument.  Stuff from feff.bin
c        is single precision, cchi is complex*16
         do 450  ie = 1, ne
c           Consider chi in the standard XAFS form.  Use R = rtot/2.
            cchi = achi(ie,ip) * exp (coni*phchi(ie,ip))
            xlam = 1.0e10
            if (abs(aimag(ck(ie))) .gt. eps) xlam = 1/aimag(ck(ie))
            redfac = exp (-2 * aimag (phc(ie)))
            cdelt = 2*dble(phc(ie))
            cfms = cchi * xk(ie) * reff(ip)**2 *
     1           exp(2*reff(ip)/xlam) / redfac
            if (abs(cchi) .lt. eps)  then
               phff = 0
            else
               phff = atan2 (dimag(cchi), dble(cchi))
            endif
c           remove 2 pi jumps in phases
            if (ie .gt. 1)  then
               call pijump (phff, phffo)
               call pijump (cdelt, cdelto)
            endif
            phffo = phff
            cdelto = cdelt

c           write 1 k, momentum wrt fermi level k=sqrt(p**2-kf**2)
c                 2 central atom phase shift (real part),
c                 3 magnitude of feff,
c                 4 phase of feff,
c                 5 absorbing atom reduction factor,
c                 6 mean free path = 1/(Im (p))
c                 7 real part of local momentum p

            write(3,400)
     1         xk(ie)/bohr,
     2         cdelt + l0*pi,
     3         abs(cfms) * bohr,
     4         phff - cdelt - l0*pi,
     5         redfac,
     6         xlam * bohr,
     7         dble(ck(ie))/bohr
  400       format (1x, f6.3, 1x, 3(1pe11.4,1x),1pe10.3,1x,
     1                            2(1pe11.4,1x))

  450    continue

c        Done with feff.dat
         close (unit=3)
  500 continue
      close (unit=2)

      return
      end
      subroutine fixdsp (dxorg, dxnew, dgc0, dpc0, dgcx, dpcx)

c     This fixes up the dirac spinor components (dgc and dpc) from ATOM
c     for the xsect code.

      implicit double precision (a-h, o-z)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

      dimension dgc0(251), dpc0(251)
      dimension dgcx(nrptx), dpcx(nrptx)

      dimension xorg(nrptx), xnew(nrptx)

      parameter (xx00 = 8.8)

c     statement functions to do indexing.  delta is 'dx' for current
c     grid.  jjj is index of grid point immediately before 'r'
      xxx(j) = -xx00 + (j-1)*delta
      rrr(j) = exp (-xx00 + (j-1)*delta)
      jjj(r) = (log(r) + xx00) / delta + 1

c     Use linear interpolation in x whether necessary or not.  If
c     new grid is same as old, it shouldn't make any difference.

c     relation between x, r, and j.  xx00 = 8.8 for all grids
c     in this version, change it if more flexibility is necessary.
c     xx = -xx00 + (j-1)*delta
c     rr = exp (xx)
c     jj = (log(r) + xx00) / delta + 1; this is j immediately BELOW r

c     The dgc and dpc arrays are zero beyond a certain point, usually
c     inside the muffin tin radius.  Find this distance.
      do 100  i = 251, 1, -1
         if ( abs(dgc0(i)) .ge. 1.0d-11 .or.
     1        abs(dpc0(i)) .ge. 1.0d-11 )  then
            imax = i
            goto 16
         endif
  100 continue
      call wlog(' Should never see this line from sub fixdsp')
   16 continue
c     jmax is the first point where both dpc and dgc are zero in
c     the original grid
      jmax = imax + 1
      if (jmax.gt.251) jmax = 251

      delta = dxorg
      do 10  j = 1, jmax
         xorg(j) = xxx(j)
   10 continue
      rmax = rrr(jmax)

c     How far out do we go in the new grid?  To the last new grid
c     point before jmax.  Everything will be zero beyond jmax.
      delta = dxnew
      jnew = jjj(rmax)
      do 20  j = 1, jnew
         xnew(j) = xxx(j)
   20 continue

c     interpolate to new grid using x, only inside of rmax
      do 30  j = 1, jnew
         call terp (xorg, dgc0,  jmax, 3, xnew(j), dgcx(j))
         call terp (xorg, dpc0,  jmax, 3, xnew(j), dpcx(j))
   30 continue

c     and zero the arrays past rmax
      do 32  j = jnew+1, nrptx
         dgcx(j) = 0
         dpcx(j) = 0
   32 continue

      return
      end
      subroutine fixdsx (ifr, dxorg, dxnew, dgc, dpc, dgcn, dpcn)

c     This fixes up the dirac spinor components (dgc and dpc) from ATOM
c     for the xsect and phase codes.

      implicit double precision (a-h, o-z)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

      dimension dgc(251,30,0:nfrx), dpc(251,30,0:nfrx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)

      dimension xorg(nrptx), xnew(nrptx)

      parameter (xx00 = 8.8)

c     statement functions to do indexing.  delta is 'dx' for current
c     grid.  jjj is index of grid point immediately before 'r'
      xxx(j) = -xx00 + (j-1)*delta
      rrr(j) = exp (-xx00 + (j-1)*delta)
      jjj(r) = (log(r) + xx00) / delta + 1

c     Use linear interpolation in x whether necessary or not.  If
c     new grid is same as old, it shouldn't make any difference.

c     relation between x, r, and j.  xx00 = 8.8 for all grids
c     in this version, change it if more flexibility is necessary.
c     xx = -xx00 + (j-1)*delta
c     rr = exp (xx)
c     jj = (log(r) + xx00) / delta + 1; this is j immediately BELOW r

c     The dgc and dpc arrays are zero beyond a certain point, usually
c     inside the muffin tin radius.  Find this distance.

      delta = dxorg
      do 10  j = 1, 251
         xorg(j) = xxx(j)
   10 continue

      delta = dxnew
      do 20  j = 1, nrptx
         xnew(j) = xxx(j)
   20 continue

      do 200 iorb = 1, 30
         imax = 0
         do 100  i = 251, 1, -1
            if ( abs(dgc(i,iorb,ifr)) .ge. 1.0d-11 .or.
     1           abs(dpc(i,iorb,ifr)) .ge. 1.0d-11 )  then
               imax = i
               goto 16
            endif
  100    continue
   16    continue
         if (imax .eq. 0) then
            jnew = 0
            goto 35
         endif
c        jmax is the first point where both dpc and dgc are zero in
c        the original grid
         jmax = imax + 1
         if (jmax .gt. 251) jmax = 251

         delta = dxorg
         rmax = rrr(jmax)

c        How far out do we go in the new grid?  To the last new grid
c        point before jmax.  Everything will be zero beyond jmax.
         delta = dxnew
         jnew = jjj(rmax)

c        interpolate to new grid using x, only inside of rmax
         do 30  j = 1, jnew
            call terp(xorg,dgc(1,iorb,ifr),jmax,3, xnew(j),dgcn(j,iorb))
            call terp(xorg,dpc(1,iorb,ifr),jmax,3, xnew(j),dpcn(j,iorb))
   30    continue

c        and zero the arrays past rmax
   35    do 40  j = jnew+1, nrptx
            dgcn(j,iorb) = 0
            dpcn(j,iorb) = 0
   40    continue
  200 continue

      return
      end
      subroutine fixvar (rmt, edens, vtot, dmag,
     1                   vint, rhoint, dxorg, dxnew, jumprm,
     2                   vjump, ri, vtotph, rhoph, dmagx)

      implicit double precision (a-h, o-z)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)


      dimension edens(251), vtot (251), dmag(251)
      dimension vtotph(nrptx), rhoph(nrptx), dmagx(nrptx)
      dimension ri(nrptx)
      dimension xorg(nrptx), xnew(nrptx)

      parameter (xx00 = 8.8)

c     statement functions to do indexing.  delta is 'dx' for current
c     grid.  jjj is index of grid point immediately before 'r'
      xxx(j) = -xx00 + (j-1)*delta
      rrr(j) = exp (-xx00 + (j-1)*delta)
      jjj(r) = (log(r) + xx00) / delta + 1

c     PHASE needs
c     vtot = total potential including gs xcorr, no r**2
c     edens = rho, charge density, no factor of 4*pi, no r**2
c     From overlapping, vtot = potential only, ok as is
c                       edens = density*4*pi, so fix this here.
c     ri = r grid through imt+1

c     Only values inside the muffin tin are used, except that XCPOT
c     (in PHASE) uses values at imt+1 and requires these to be the
c     interstitial values.  So set the last part of the arrays to
c     interstitial values...

c     Use linear interpolation in x whether necessary or not.  If
c     new grid is same as old, it shouldn't make any difference.

c     relation between x, r, and j.  xx00 = 8.8 for all grids
c     in this version, change it if more flexibility is necessary.

c     xx = -xx00 + (j-1)*delta
c     rr = exp (xx)
c     jj = (log(r) + xx00) / delta + 1; this is j immediately BELOW r

      delta = dxorg
      jmtorg = jjj(rmt)
      jriorg = jmtorg + 1
      jrior1 = jriorg + 1
      do 10  j = 1, jrior1
         xorg(j) = xxx(j)
   10 continue

      delta = dxnew
      jmtnew = jjj(rmt)
      jrinew = jmtnew + 1
      jrine1 = jrinew + 1
      do 20  j = 1, jrine1
         xnew(j) = xxx(j)
   20 continue

c     interpolate to new grid using x, only inside of muffintin
c     jri (first interstitial point) must be set to interstitial value
      do 30  j = 1, jrinew
         call terp (xorg, vtot,  jrior1, 3, xnew(j), vtotph(j))
         call terp (xorg, edens, jrior1, 3, xnew(j), rhoph(j))
         call terp (xorg, dmag,  jrior1, 3, xnew(j), dmagx(j))
   30 continue

      if (jumprm .eq. 1) then
         xmt = log(rmt)
         call terp (xorg, vtot,  jriorg, 3, xmt, vmt)
         vjump = vint - vmt
      endif
      if (jumprm .gt. 0) then
         do 90  j = 1, jrinew
            vtotph(j) = vtotph(j) + vjump
   90    continue
      endif

      delta = dxnew
      do 180  j = 1, nrptx
         ri(j) = rrr(j)
  180 continue
      do 190  j = 1, jrinew
         rhoph(j) = rhoph(j)/(4*pi)
  190 continue
      do 200  j = jrinew+1, nrptx
         vtotph(j) = vint
         rhoph(j) = rhoint/(4*pi)
c fix later : need to calculate interstitial dmint
c      want interpolation beyond mt also
         dmagx(j) = 0.0d0
  200 continue

      return
      end
      subroutine fmtrxi (lam1x, lam2x, ie, ileg, ilegp)
      implicit double precision (a-h, o-z)

c     all commons except for /fmat/ are inputs

c     inputs:
c       lam1x, lam2x:  limits on lambda and lambda'
c       ie:  energy grid points
c       ileg, ilegp: leg and leg'
c
c     Inputs from common:
c        phases, use ph(ie,...,ilegp), and lmax(ie,ilegp)
c        lambda arrays
c        rotation matrix for ilegp
c        clmz for ileg and ilegp
c        path data, eta(ilegp) and ipot(ilegp)
c        xnlm array
c
c     Output:  fmati(...,ilegp) in common /fmatrx/ is set for
c              current energy point.

c     calculate scattering amplitude matrices
c     f(lam,lam') = sum_l tl gam(l,m,n)dri(l,m,m',ileg)gamt(l,m',n')
c                 *cexp(-i*m*eta),  eta = gamma+alpha'
c     lam lt lam1x, lam' lt lam2x such that m(lam) lt l0, n(lam) lt l0
c     gam = (-)**m c_l,n+m*xnlm, gamt = (2l+1)*c_ln/xnlm,
c     gamtl = gamt*tl

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'nlm.h'
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c     include 'lambda.h'
      common /lambda/
     4   mlam(lamtot),
     5   nlam(lamtot),
     1   lamx,
     2   laml0x,
     3   mmaxp1, nmax
c     include 'clmz.h'
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c     include 'fmatrx.h'
      complex*16 fmati
      common /fmatrx/ fmati(lamtot,lamtot,legtot)
c     include 'rotmat.h'
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle

      complex*16 cam, camt, cterm, tltl
      complex*16 gam(ltot+1,mtot+1,ntot+1),
     1           gamtl(ltot+1,mtot+1,ntot+1), tl

c     calculate factors gam and gamtl
      iln = 1
      ilx = lmax(ie,ipot(ilegp)) + 1
      do 30  il = iln, ilx
         tltl = 2*il - 1
         tl = (exp(2*coni*ph(ie,il,ipot(ilegp))) - 1) / (2*coni)
         tltl = tltl * tl
         lam12x = max (lam1x, lam2x)
         do 20  lam = 1, lam12x
            m = mlam(lam)
            if (m .lt. 0)  goto 20
            im = m+1
            if (im .gt. il)  goto 20
            in = nlam(lam) + 1
            imn = in + m
            if (lam .gt. lam1x)  goto 10
            cam = xnlm(il,im) * (-1)**m
            if (imn .le. il)  gam(il,im,in) = cam * clmi(il,imn,ileg)
            if (imn .gt. il)  gam(il,im,in) = 0
   10       if (lam .gt. lam2x) goto 20
            camt = tltl / xnlm(il,im)
            gamtl(il,im,in) = camt * clmi(il,in,ilegp)
   20    continue
   30 continue

      do 60 lam1 = 1,lam1x
         m1 = mlam(lam1)
         in1 = nlam(lam1) + 1
         iam1 = abs(m1) + 1
         do 60  lam2 = 1, lam2x
            m2 = mlam(lam2)
            in2 = nlam(lam2) + 1
            iam2 = iabs(m2) + 1
            imn1 = iam1 + in1 - 1
            cterm = 0
            ilmin = max (iam1, iam2, imn1, in2, iln)
            do 40  il = ilmin, ilx
c              skip terms with mu > l (NB il=l+1, so mu=il is mu>l)
               if (abs(m1).ge.il .or. abs(m2).ge.il)  goto 40
               m1d = m1 + mtot+1
               m2d = m2 + mtot+1

               cterm = cterm + gam(il,iam1,in1)*gamtl(il,iam2,in2)
     1                         *dri(il,m1d,m2d,ilegp)

   40       continue
            if (eta(ileg) .ne. 0.0) then
               m1 = mlam(lam1)
               cterm = cterm * exp(-coni*eta(ileg)*m1)
            endif
c           Above was org coding, change to use eta(ilegp) as test
c           based on algebra check.  July 20, 1992, siz&jjr
c           Changed back with redifinition of eta(see rdpath.f)
c           which is more convinient in polarization case.
c           August 8,1993, ala.
c           if (eta(ilegp) .ne. 0.0) then
c              m1 = mlam(lam1)
c              cterm = cterm * exp(-coni*eta(ilegp)*m1)
c           endif
            fmati(lam1,lam2,ilegp) = cterm
   60 continue

c     test of fmati(lam,lam',ileg)
c     plot fmat(lam,lam') = csqrt((z/2)**(m1-m2))*fmat

      return
      end
      subroutine dfovrg (ncycle, ikap, rmt, jri, jcore, p2, p2val, dx,
     1                  ri, vxc, vxcval, dny, dgcn, dpcn, adgc, adpc,
     2                  pu, qu, ps, qs,
     2                  ifr, iz, ihole, xion, irr, ic3)

c     fully relativistic version of subroutine fovrg.f
c     input:
c        ncycle  times to calculate photoelectron wave function
c                with nonlocal exchange
c        ikap    quantum number kappa for photoelectron
c        rmt     muffin-tin radius
c        jri     first interstitial grid point (imt + 1)
c        jcore   last point for \sigma_nonlocal
c        p2      current complex energy
c        dx      dx in loucks' grid (usually .05)
c        ri(nr)  loucks' position grid, r = exp ((i-1)*dx - 8.8)
c        vxc(nr) coulomb+xc potential for total density
c        vxcval  coulomb+xc potential for valence density
c        both vxc and vxcval include coulomb and nuclear potential
c        dgcn(dpcn) large(small) dirac components for 'ifr' atom
c        adgc(adpc) their development coefficients
c     work space:
c        must be dimensioned in calling program.  coded like this
c        to make using different r-grids with different nrmax easy.
c
c     output:
c        dny     r*g'/g, see loucks (4-85), q/p = cf/g (eq 4-86)
c        pu, qu  upper and lower components at muffin tin
c        ps and qs are  upper and lower components for photoelectron

      implicit double precision (a-h, o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      parameter (c = clight)
      parameter (csq = c**2)

      complex*16 vxc(nrptx), vxcval(nrptx), p2, p2val
      dimension ri(nrptx)
      complex*16 dny, pu, qu, vu, vm(nrptx)
      complex*16 ps(nrptx), qs(nrptx), aps(10),aqs(10)

c     all atoms' dirac components and their development coefficients
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30,0:nfrx), adpc(10,30,0:nfrx)

c     ifr atom's dirac components and their development coefficients
      common/dff/cg(nrptx,30), cp(nrptx,30), bg(10,30), bp(10,30),
     1             fl(30), fix(30), ibgp
c     fl power of the first term of development limits.
c     ibgp first dimension of the arrays bg and bp (=10)

      complex*16 gg,gp,ag,ap,dv,av,bid
      common/comdirc/cl,dz,gg(nrptx),ag(10),gp(nrptx),ap(10),
     1              dv(nrptx),av(10),bid(2*nrptx+20)
c      gg,gp are the input and output for solout
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/mulabkc/afgkc
      dimension afgkc(-ltot-1:ltot,30,0:3)
      common/messag/dlabpr,numerr
      character*8 dlabpr
c      xnel here - number of core electrons only
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      common/snoyauc/dvn(nrptx),anoy(10),nuc
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension xnval(30)

      complex*16 prpr
      data harryd /2./

c     initialize the data and test parameters
      ndor = 3
      if (irr.gt.0) ndor=2
      do 9 i = jri+2,nrptx
         vxc(i)=vxc(jri+1)
 9       vxcval(i)=vxcval(jri+1)
      prpr=0.0
      ibgp=10
      numerr = 0
      nz = iz
      hx = dx
      idim= 1 + nint(250*0.05/dx)
      if (idim .gt. nrptx) idim = nrptx
      if (mod(idim,2) .eq. 0) idim=idim-1
c     copy information into common's of atomic code
      do 13 j=1,30
      do 13 i=1,10
         bg(i,j)=adgc(i,j,ifr)
 13      bp(i,j)=adpc(i,j,ifr)
      do 15 j=1,30
      do 15 i=1,idim
         cg(i,j)=dgcn(i,j)
 15      cp(i,j)=dpcn(i,j)

 11   call inmuac (ihole,xion,ikap,xnval)
c     note that here norb correspond to photoelectron

c     calculate initial photoelectron orbital using lda
      cl = clight/2.0d0
      call diff (vxc,ri,ikap,cl,hx,nrptx,vm)
      call wfirdc (p2,kap,nmax,ikap,vxc,ps,qs,aps,aqs,irr,ic3,vm)
      if (numerr .ne. 0) stop 'error in wfirdc'
      if (ncycle .eq. 0) go to 999

c     to get orthogonalized photo e w.f., use alternative exit below
c     in general it should not be orthogonolized. Use for testing only
c     ala

c     further need only core electrons for exchange term
      do 40 i=1, norb-1
  40  xnel(i) = xnel(i) - xnval(i)
c     take vxcval at the origin as vxcval=vcoul +const1 + i*const2
      av(2)=av(2)+(vxcval(1)-vxc(1))/cl
      do 50 i=1,idim
  50  dv(i)=vxcval(i)/cl

      ind=1
c     if ind < 0, then test has been passed
      nter=0

c     angular coefficients
      call muatcc(xnval)

c     no orthogonalization needed. Looking for g.f., not w.f.
c     if (ipl.ne.0) call ortdac (ikap,ps,qs,aps,aqs)
c     ortdac orthogonalizes photoelectron orbital to core orbitals
c     have to use exchange 5 card to exit here; also want vxc=vxcval
c     if (ncycle .eq. 0) go to 999

c     iteration over the number of cycles
 101  continue
         nter=nter+1
c        calculate exchange potential
         call potex(ps,qs,aps,aqs,jri)

c        resolution of the dirac equation
         call solout (p2val, fl(norb), aps(1), aqs(1), ikap,
     1     nmax(norb), ic3, vm)

c     no orthogonalization needed. Looking for g.f., not w.f.
c        if (ipl.ne.0) call ortdac (ikap,gg,gp,ag,ap)

c        acceleration of the convergence
         scc(norb)=1.0d0
         do 151 i=1,idim
            ps(i)=gg(i)
 151        qs(i)=gp(i)
         do 155 i=1,ndor
            aps(i) =ag(i)
 155        aqs(i) =ap(i)

      if (nter.le.ncycle) go to 101

 999  if (numerr .eq. 0) then
c     different output for irregular solution
c     want to have vxc(jri)-smooth and vxc(jri+1)=v_mt
        call terpc (ri,ps,jri,1,rmt,pu)
        call terpc (ri,qs,jri,1,rmt,qu)
        qu=clight*qu

        vu=vxc(jcore+1)
c  there is no exchange term in loucks (4-14,4-15)
c  no exchange beyond jcore (larger or = jri )
        dny=rmt*(1.0-(vu-p2val)*harryd/csq)*qu/pu-(ikap+1)

cczero     zero pot test
czero        il=ikap
czero        if (ikap.lt.0) il = -ikap-1
czero        xk = dble( sqrt(p2*2.0))
czero         xnorm =(xk*dr(1))**(il+1)
czero 345    xnorm=xnorm /(2.0*il+1.0)
czero        il=il-1
czero        if (il.gt.0) goto 345
czero        pu = pu*xnorm
czero        print*,'test in dfov',pu
c dny is r*g'/g, see loucks (4-85), q/p = cf/g (eq 4-86)
c (watch for factors of rmt)
      else
        stop 'error in dfovrg.f'
      endif

      return
      end
      subroutine frnrm (rho, iz, rnrm)
      implicit double precision (a-h, o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension rho(nrptx)

c     finds norman radius

c     Need overlapped densities.  We'll get them in the form
c     4*pi*density = rho.  Also need z of atom

c     Then integrate out to the point where the integral of
c     4*pi*density*r**2 is equal to iz
      sum = 0.0
      do 10  i = 1, nrptx-1
         fr = rho(i+1) * rr(i+1)**3
         fl = rho(i)   * rr(i)**3
         sumsav = sum
         sum = sum + 0.025*(fr+fl)
         if (sum .ge. iz)  then
            inrm = i+1
            goto 20
         endif
   10 continue
      call wlog(' FRNRM Could not integrate enough charge to reach' //
     1          ' required z.')
      stop 'FRNRM-1'
   20 continue
c     inrm is too big, subtract one from irnm and interpolate
c     to get correct value
      inrm = inrm - 1
      deltaq = iz - sumsav
      fr = rho(inrm+1) * rr(inrm+1)**3
      fl = rho(inrm)   * rr(inrm)**3
c     dipas is delta i * 0.05
      dipas = 2*deltaq / (fl + fr)
      rnrm = rr(inrm)*(1 + dipas)

      return
      end
      subroutine genfmt (ipr3, critcw, iorder, wnstar)
      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'vers.h'
      character*12 vfeff
      common /vers/ vfeff
c     include 'clmz.h'
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c     include 'fmatrx.h'
      complex*16 fmati
      common /fmatrx/ fmati(lamtot,lamtot,legtot)
c     include 'lambda.h'
      common /lambda/
     4   mlam(lamtot),
     5   nlam(lamtot),
     1   lamx,
     2   laml0x,
     3   mmaxp1, nmax
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle
c     include 'nlm.h'
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c     include 'rotmat.h'
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola

c     complex*16  zhedin
      complex*16  rho(legtot), pmati(lamtot,lamtot,2)
      complex*16  pllp, ptrac, srho, prho, cfac
      complex*16  cchi(nex), bmati
      complex*16  rkk(nex,-1:1)
      dimension   bmati(-mtot:mtot,-mtot:mtot,-1:1,-1:1)
      dimension   t3j(-1:1, 0:1,-4:5), x3j(-1:1,-1:1, -4:5)
      dimension   xk(nex), ckmag(nex)
      complex*16  ck(nex), ckp
      dimension   ffmag(nex)
      dimension   eps1(3), eps2(3), vec1(3), vec2(3)

      character*78 string
      character*512 slog
c6    character*12 fname
      logical done, wnstar

c     Input flags:
c     iorder, order of approx in f-matrix expansion (see setlam)
c             (normal use, 2.  Do ss exactly regardless of iorder)

c     used for divide-by-zero and trig tests
      parameter (eps = 1.0e-16)

c     Read phase calculation input, data returned via commons
      open (unit=1, file='phase.bin', status='old',
     1      access='sequential', form='unformatted', iostat=ios)
      call chopen (ios, 'phase.bin', 'genfmt')
      call rphbin (1)
      close (unit=1)

c     Read normalized reduced matrix elements
      open (unit=1, file='rkk.bin', status='old',
     1      access='sequential', form='unformatted', iostat=ios)
      call chopen (ios, 'phase.bin', 'genfmt')
      read(1) ((rkk(ie,k1),ie=1,nex),k1=-1,1)
      close (unit=1)

c     Open path input file (unit in) and read title.  Use unit 1.
      ntitle = 5
      open (unit=1, file='paths.dat', status='old', iostat=ios)
      call chopen (ios, 'paths.dat', 'genfmt')
      call rdhead (1, ntitle, title, ltitle)
      if (ntitle .le. 0)  then
         title(1) = ' '
         ltitle(1) = 1
      endif

c     cgam = gamma in mean free path calc (eV).  Set to zero in this
c     version.  Set it to whatever you want if you need it.
c     cgam = 0
c     cgam = cgam / ryd
c     add cnst imag part to eref
c     do 20  ie = 1, ne
c        eref(ie) = eref(ie) - coni*cgam/2
c  20 continue

   50 format (a)
   60 format (1x, a)
   70 format (1x, 71('-'))

c     Save indices of paths for use by ff2chi
      open (unit=2, file='list.dat', status='unknown', iostat=ios)
      call chopen (ios, 'list.dat', 'genfmt')
c     Put phase header on top of list.dat
      do 100  itext = 1, ntext
         write(2,60)  text(itext)(1:ltext(itext))
  100 continue
      write(2,70)
      write(2,120)
  120 format ('  pathindex     sig2   amp ratio    ',
     1        'deg    nlegs  r effective')

c     Open nstar.dat if necessary
      if (wnstar)  then
         open (unit=4,file='nstar.dat', status='unknown', iostat=ios)
         call chopen (ios, 'nstar.dat', 'genfmt')
         write(4,198) evec
  198    format(' polarization  ',3f8.4)
         write(4,199)
  199    format(' npath     n*')
      endif

c     Set crit0 for keeping feff.dat's
      if (ipr3 .le. 0)  crit0 = 2*critcw/3
c     Make a header for the running messages.
      write(slog,130) critcw
      call wlog(slog)
  130 format ('    Curved wave chi amplitude ratio', f7.2, '%')
      if (ipr3 .le. 0)  then
         write(slog,131) crit0
         call wlog(slog)
      endif
  131 format ('    Discard feff.dat for paths with cw ratio <',
     1         f7.2, '%')
      write(slog,132)
      call wlog(slog)
  132 format ('    path  cw ratio     deg    nleg  reff')

c     open feff.bin for storing path info
c     for now, use double precision.  After it's working, try
c     single precision.
c     Use single precision for all fp numbers in feff.bin
      open (unit=3, file='feff.bin', status='unknown',
     1      access='sequential', form='unformatted', iostat=ios)
      call chopen (ios, 'feff.bin', 'genfmt')
c     put label line in feff.bin so other programs know it really
c     is a feff.bin file
      string = 'feff.bin file, written by feff version ' // vfeff
      write(3)  string
c     save stuff that is the same for all paths
c     header, ck, central atom phase shifts
      write(3) ntext
      do 133  itext = 1, ntext
c        text(itext) does not have carriage control
         write(3) ltext(itext)
         write(3) text(itext)
  133 continue
c     Misc stuff from phase.bin and genfmt call
      write(3) ne, npot, ihole, methfs, real(rnrmav), real(xmu),
     1         real(edge), ik0, iorder, ilinit
      write(3) (potlbl(i),i=0,npot)
      write(3) (iz(i),i=0,npot)
c     Central atom phase shifts
c     write(3) (cmplx(ph(ie,linit+1,0)),ie=1,ne)
c    bug??   write(3) (cmplx(ph(ie,ilinit+1,0)),ie=1,ne)
      write(3) (cmplx(ph(ie,ilinit+1,0)),ie=1,ne)

c     Set nlm factors in common /nlm/ for use later
      call snlm (ltot+1, mtot+1)

c     Make xk and ck array for later use
      do 135  ie = 1, ne
c        real momentum (k)
         xk(ie) = getxk (em(ie) - edge)
c        complex momentum (p)
         if (methfs.eq.0 .or. methfs.eq.3) then
            ck(ie) = sqrt (em(ie) - eref(ie))
         elseif (methfs.eq.1) then
            ck(ie) = sqrt (em(ie) - dble(eref(ie)))
         elseif (methfs.eq.2) then
            ck(ie) = sqrt (em(ie)-eref(ie)+(0.0,1.0)*dimag(eref(1)))
         endif
         ckmag(ie) = abs(ck(ie))
  135 continue
      write(3) (real(dimag(eref(ie))),ie=1,ne)
      write(3) (cmplx(ck(ie)),ie=1,ne)
      write(3) (real(xk(ie)),ie=1,ne)

      if (pola.gt.0 .and. pola.le.3) then
c        Put 3j factors in x3j and t3j. t3j are multiplied by
c        sqrt(2*j'+1) for  further convinience.
c        ilinit - max final momentum, initial momentum = linit.
         do 138 mp=-4,5
         do 138 ms=0,1
         do 138 k1=-1,1
  138    t3j(k1,ms,mp) = 0.0d0
         do 139 mp=-4,5
         do 139 ms=-1,1
         do 139 k1=-1,1
  139    x3j(k1,ms,mp) = 0.0d0
         do 140 k1 = -1,1
         do 140 mp = -jkap(k1)+1,jkap(k1)
            do 150 ms=0,1
               j1 = 2 * lkap(k1)
               j2 = 1
               j3 = 2 * jkap(k1) - 1
               m1 = 2*(mp-ms)
               m2 = 2*ms - 1
               t3j(k1,ms,mp)=sqrt(j3+1.0d0) * cwig3j(j1,j2,j3,m1,m2,2)
  150       continue
            do 160 i=-1,1
               j1 = 2 * abs(kinit) - 1
               j2 = 2
               j3 = 2 * jkap(k1) - 1
               m2 = 2*i
               m1 = -2*mp + 1 -m2
               x3j(k1,i,mp)= cwig3j(j1,j2,j3,m1,m2,2)
  160       continue
  140    continue
      endif


c     While not done, read path, find feff.
      npath = 0
      ntotal = 0
      nused = 0
      xportx = -1
  200 continue

c        Read current path
         call rdpath (1, done)
         icalc = iorder
         if (done)  goto  1000
         npath = npath + 1
         ntotal = ntotal + 1
         if (wnstar)  then
            do 202 ic =1,3
              vec1(ic) = rat(ic,1) - rat(ic,0)
              vec2(ic) = rat(ic,nleg-1) - rat(ic,0)
              eps1(ic) = evec(ic)
  202       continue
            if (pola .eq. 1 .and. elpty.ne. 0.0) then
              eps2(1) = xivec(2)*evec(3)-xivec(3)*evec(2)
              eps2(2) = xivec(3)*evec(1)-xivec(1)*evec(3)
              eps2(3) = xivec(1)*evec(2)-xivec(2)*evec(1)
            endif
            ndeg = nint (deg)
            xxstar = xstar (eps1, eps2, vec1, vec2, ndeg)
            write(4,205)  npath, xxstar
  205       format (i6, f10.3)
         endif

c        Need reff
         reff = 0
         do 220  i = 1, nleg
            reff = reff + ri(i)
  220    continue
         reff = reff/2

c        Set lambda for low k
         call setlam (icalc, 1)

c        Calculate and store rotation matrix elements
c        Only need to go to linit+1 for isc=nleg and
c        nleg+1 (these are the paths that involve the 'z' atom
         call rot3i (ilinit+1, ilinit+1, nleg)
         do 400  isc = 1, nsc
            call rot3i (lmaxp1, mmaxp1, isc)
  400    continue
         if (pola.eq.1) then
c           one more rotation in polarization case
c           NEED MORE rot3j FOR CENTRAL ATOM ( l \pm 1 )
            call rot3i (ilinit+1, ilinit+1, nleg+1)
         endif
         if (pola.gt.0 .and. pola.le.3) call mmtr( t3j, x3j, bmati)


c        Big energy loop
         do 800  ie = 1, ne

c           complex rho
            do 420  ileg = 1, nleg
               rho(ileg) = ck(ie) * ri(ileg)
  420       continue

c           if ck is zero, xafs is undefined.  Make it zero and jump
c           to end of calc part of loop.
            if (abs(ck(ie)) .le. eps)  then
               cchi(ie) = 0
               write(slog,430)  ie, ck(ie)
  430          format (' genfmt: ck=0.  ie, ck(ie)', i5, 1p, 2e14.5)
               call wlog(slog)
               goto 620
            endif

c           Calculate and store spherical wave factors c_l^(m)z^m/m!
c           in a matrix clmi(il,im,ileg), ileg=1...nleg.
c           Result is that common /clmz/ is updated for use by fmtrxi.

c           zero clmi arrays
            do 440  ileg = 1, legtot
            do 440  il = 1, ltot+1
            do 440  im = 1, mtot+ntot+1
               clmi(il,im,ileg) = 0
  440       continue

            mnmxp1 = mmaxp1 + nmax

            lxp1 = max (lmax(ie,ipot(1))+1, ilinit+1)
            mnp1 = min (lxp1, mnmxp1)
            call sclmz (rho, lxp1, mnp1, 1)

            lxp1 = max (lmax(ie,ipot(nsc))+1, ilinit+1)
            mnp1 = min (lxp1, mnmxp1)
            call sclmz (rho, lxp1, mnp1, nleg)

            do 460  ileg = 2, nleg-1
               isc0 = ileg-1
               isc1 = ileg
               lxp1 = max (lmax(ie,ipot(isc0))+1, lmax(ie,ipot(isc1))+1)
               mnp1 = min (lxp1, mnmxp1)
               call sclmz (rho, lxp1, mnp1, ileg)
  460       continue

c           Calculate and store scattering matrices fmati.

c           Termination matrix, fmati(...,nleg)
c           Polarization enters only this matrix
c           this will fill fmati(...,nleg) in common /fmtrxi/
            call mmtrxi ( rkk, laml0x, bmati, ie, 1, nleg)

c           First matrix
            call fmtrxi (lamx, laml0x, ie, 2, 1)
c           Last matrix if needed
            if (nleg .gt. 2)  then
               call fmtrxi (laml0x, lamx, ie, nleg, nleg-1)
            endif
c           Intermediate scattering matrices
            do 480  ilegp = 2, nsc-1
               ileg = ilegp + 1
               call fmtrxi (lamx, lamx, ie, ileg, ilegp)
  480       continue

c           Big matrix multiplication loops.
c           Calculates trace of matrix product
c           M(1,N) * f(N,N-1) * ... * f(3,2) * f(2,1), as in reference.
c           We will (equivalently) calculate the trace over lambda_N of
c           f(N,N-1) * ... * f(3,2) * f(2,1) * M(1,N), working from
c           right to left.
c           Use only 2 pmati arrays, alternating indp (index p)
c           1 and 2.

c           f(2,1) * M(1,N) -> pmat(1)
            indp = 1
            do 520  lmp = 1, laml0x
            do 520  lm = 1, lamx
               pllp = 0
               do 500  lmi = 1, laml0x
                  pllp = pllp + fmati(lm,lmi,1) * fmati(lmi,lmp,nleg)
  500          continue
               pmati(lm,lmp,indp)=pllp
  520       continue

c           f(N,N-1) * ... * f(3,2) * [f(2,1) * M(1,N)]
c           Term in [] is pmat(1)
            do 560 isc = 2, nleg-1
c              indp is current p matrix, indp0 is previous p matrix
               indp = 2 - mod(isc,2)
               indp0 = 1 + mod(indp,2)
               do 550  lmp = 1, laml0x
               do 550  lm = 1, lamx
                  pllp=0
                  do 540 lmi = 1, lamx
                     pllp = pllp +
     1                      fmati(lm,lmi,isc)*pmati(lmi,lmp,indp0)
  540             continue
  550          pmati(lm,lmp,indp) = pllp
  560       continue

c           Final trace over matrix
            ptrac=0
            do 580  lm = 1, laml0x
               ptrac = ptrac + pmati(lm,lm,indp)
  580       continue

c           Calculate xafs
c           srho=sum pr(i), prho = prod pr(i)
            srho=0
            prho=1
            do 600  ileg = 1, nleg
               srho = srho + rho(ileg)
               prho = prho * rho(ileg)
  600       continue
c           Complex chi (without 2kr term)
c           ipot(nleg) is central atom
c           cdel1 = exp(2*coni*ph(ie,ilinit+1,0))
c           central atom phase shift are included in normalized
c           reduced matrix elements rkk(....)
            cfac = exp(coni*(srho-2*xk(ie)*reff)) / prho

c           now factor 1/(2*l0+1) is inside termination matrix
c           cchi(ie) = ptrac * cfac/(2*l0+1)
            cchi(ie) = ptrac * cfac
c           cchi(ie) = ptrac * cfac*zhedin(xk(ie),nleg)

c           When ck(ie)=0, xafs is set to zero.  Calc above undefined.
c           Jump to here from ck(ie)=0 test above.
  620       continue

c        end of energy loop
  800    continue

c        Make importance factor, deg*(integral (|chi|*d|p|))
c        make ffmag (|chi|)
c        xport   importance factor
         do 810  ie = 1, ne
            if (methfs.eq.0 .or. methfs.eq.3) then
               ckp = ck(ie)
            elseif (methfs.eq.1) then
               ckp = sqrt (ck(ie)**2 - coni*dimag(eref(ie)))
            elseif (methfs.eq.2) then
               ckp = sqrt (ck(ie)**2 - coni*dimag(eref(1)))
            endif
            xlam0 = dimag(ck(ie)) - dimag(ckp)
            ffmag(ie) = abs( cchi(ie) * exp(2*reff*xlam0) )
  810    continue

c        integrate from edge (ik0) to ne
         nemax = ne - ik0 + 1
         call trap (ckmag(ik0), ffmag(ik0), nemax, xport)
         xport = abs(deg*xport)
         if (xport .gt. xportx)  xportx = xport
         crit = 100 * xport / xportx

c        Write path data to feff.bin if we need it.
         if (ipr3 .ge. 1  .or.  crit .ge. crit0)  then
c           Prepare output file feffnnnn.dat (unit 3)
c6          write(fname,241)  ipath
c6  241       format ('feff', i4.4, '.dat')
c6            open (unit=3, file=fname, status='unknown', iostat=ios)
c6            call chopen (ios, fname, 'genfmt')
c           put header on feff.dat
c6            do 245  itext = 1, ntext
c6               write(3,60)  text(itext)(1:ltext(itext))
c6  245       continue
c6            write(3,250) ipath, icalc, vfeff, vgenfm
c6  250       format (' Path', i5, '      icalc ', i7, t57, 2a12)
c6            write(3,70)
c6            write(3,290)  nleg, deg, reff*bohr, rnrmav, edge*ryd
c6  290       format (1x, i3, f8.3, f9.4, f10.4, f11.5,
c6     1              ' nleg, deg, reff, rnrmav(bohr), edge')
c6            write(3,300)
c6  300       format ('        x         y         z   pot at#')
c6            write(3,310)  (rat(j,nleg)*bohr,j=1,3), ipot(nleg),
c6     1                    iz(ipot(nleg)), potlbl(ipot(nleg))
c6  310       format (1x, 3f10.4, i3, i4, 1x, a6, '   absorbing atom')
c6            do 330  ileg = 1, nleg-1
c6               write(3,320)  (rat(j,ileg)*bohr,j=1,3), ipot(ileg),
c6     1                       iz(ipot(ileg)), potlbl(ipot(ileg))
c6  320          format (1x, 3f10.4, i3, i4, 1x, a6)
c6  330       continue
c6
c6            write(3,340)
c6  340       format    ('    k   real[2*phc]   mag[feff]  phase[feff]',
c6     1                 ' red factor   lambda      real[p]@#')
c6
c6c           Make the feff.dat stuff and write it to feff.dat
c6            do 900  ie = 1, ne
c6c           Consider chi in the standard XAFS form.  Use R = rtot/2.
c6               xlam = 1.0e10
c6               if (abs(dimag(ck(ie))) .gt. eps) xlam = 1/dimag(ck(ie))
c6               redfac = exp (-2 * dimag (ph(ie,ilinit+1,0)))
c6               cdelt = 2*dble(ph(ie,ilinit+1,0))
c6               cfms = cchi(ie) * xk(ie) * reff**2 *
c6     1              exp(2*reff/xlam) / redfac
c6               if (abs(cchi(ie)) .lt. eps)  then
c6                  phff = 0
c6               else
c6                  phff = atan2 (dimag(cchi(ie)), dble(cchi(ie)))
c6               endif
c6c              remove 2 pi jumps in phases
c6               if (ie .gt. 1)  then
c6                  call pijump (phff, phffo)
c6                  call pijump (cdelt, cdelto)
c6               endif
c6               phffo = phff
c6               cdelto = cdelt
c6
c6c              write 1 k, momentum wrt fermi level k=sqrt(p**2-kf**2)
c6c                    2 central atom phase shift (real part),
c6c                    3 magnitude of feff,
c6c                    4 phase of feff,
c6c                    5 absorbing atom reduction factor,
c6c                    6 mean free path = 1/(Im (p))
c6c                    7 real part of local momentum p
c6
c6               write(3,640)
c6     1            xk(ie)/bohr,
c6     2            cdelt + ilinit*pi,
c6     3            abs(cfms) * bohr,
c6     4            phff - cdelt - ilinit*pi,
c6     5            redfac,
c6     6            xlam * bohr,
c6     7            dble(ck(ie))/bohr
c6  640          format (1x, f6.3, 1x, 3(1pe11.4,1x),0pe11.4,1x,
c6     1                               2(1pe11.4,1x))
c6  900       continue
c6
c6c           Done with feff.dat
c6            close (unit=3)
c6
c6c           Put feff.dat and stuff into files.dat
c6            write(2,820) fname, sig2g, crit, deg,
c6     1                   nleg, reff*bohr
c6  820       format(1x, a, f8.5, 2f10.3, i6, f9.4)
c6
c6c           Tell user about the path we just did
c6            print 210, ipath, crit, deg, nleg, reff*bohr
c6  210       format (3x, i4, 2f10.3, i6, f9.4)
c6            nused = nused+1


c           write path info
            write(3) ipath
            write(3) nleg, real(deg), nsc, real(reff), real(crit)
            write(3) (ipot(i),i=1,nleg)
            write(3) ( (real(rat(j,i)),j=1,3), i=1,nleg )
            write(3) (real(beta(i)),i=1,nleg)
            write(3) (real(eta(i)),i=1,nleg)
            write(3) (real(ri(i)),i=1,nleg)

            do 900  ie = 1, ne
               if (abs(cchi(ie)) .lt. eps)  then
                  phff = 0
               else
                  phff = atan2 (dimag(cchi(ie)), dble(cchi(ie)))
               endif
c              remove 2 pi jumps in phase
               if (ie .gt. 1)  then
                  call pijump (phff, phffo)
               endif
               phffo = phff

               write(3) real(abs(cchi(ie))), real(phff)

  900       continue

c           Put feff.dat and stuff into list.dat
c           zero is debye-waller factor column
               write(2,820) ipath, zero, crit, deg,
     1                   nleg, reff*bohr
  820       format(1x, i8, f12.5, 2f10.3, i6, f9.4)

c           Tell user about the path we just did
            write(slog,210) ipath, crit, deg, nleg, reff*bohr
            call wlog(slog)
  210       format (3x, i4, 2f10.3, i6, f9.4)
            nused = nused+1

         else
c           path unimportant, tell user
            write(slog,211) ipath, crit, deg, nleg, reff*bohr
            call wlog(slog)
  211       format (3x, i4, 2f10.3, i6, f9.4, ' neglected')
         endif

c        Do next path
         goto 200

c     Done with loop over paths
 1000 continue
c     close paths.dat, list.dat, feff.bin, nstar.dat
      close (unit=1)
      close (unit=2)
      close (unit=3)
      if (wnstar) close (unit=4)
      write(slog,1010) nused, ntotal
      call wlog(slog)
 1010 format (1x, i4, ' paths kept, ', i4, ' examined.')

      return
      end
      subroutine getorb (iz, ihole, xion, norb, norbco,
     1                  iholep, den, nqn, nk, xnel, xnval)
c     Gets orbital data for chosen element.  Input is iz, atomic number
c     of desired element, other arguments are output.
c     Feel free to change occupation numbers for element of interest.
c     ival(i) is necessary only for partly nonlocal exchange model.
c     iocc(i) and ival(i) can be fractional
c     But you have to keep the sum of iocc(i) equal to nuclear charge.
c     Also ival(i) should be equal to iocc(i) or zero.
c     Otherwise you have to change this subroutine or contact authors
c     for help.

      implicit double precision (a-h, o-z)

c     Written by Steven Zabinsky, July 1989
c     modified (20 aug 1989)  table increased to at no 97
c     Recipe for final state configuration is changed. Valence
c     electron occupations are added. ala 17.1.1996

c     Table for each element has occupation of the various levels.
c     The order of the levels in each array is:

c     element  level     principal qn (nqn), kappa qn (nk)
c           1  1s        1  -1
c           2  2s        2  -1
c           3  2p1/2     2   1
c           4  2p3/2     2  -2
c           5  3s        3  -1
c           6  3p1/2     3   1
c           7  3p3/2     3  -2
c           8  3d3/2     3   2
c           9  3d5/2     3  -3
c          10  4s        4  -1
c          11  4p1/2     4   1
c          12  4p3/2     4  -2
c          13  4d3/2     4   2
c          14  4d5/2     4  -3
c          15  4f5/2     4   3
c          16  4f7/2     4  -4
c          17  5s        5  -1
c          18  5p1/2     5   1
c          19  5p3/2     5  -2
c          20  5d3/2     5   2
c          21  5d5/2     5  -3
c          22  5f5/2     5   3
c          23  5f7/2     5  -4
c          24  6s        6  -1
c          25  6p1/2     6   1
c          26  6p3/2     6  -2
c          27  6d3/2     6   2
c          28  6d5/2     6  -3
c          29  7s        7  -1

      dimension den(30), nqn(30), nk(30), xnel(30), xnval(30)
      dimension kappa (29)
      real iocc, ival
      dimension iocc (97, 29), ival (97, 29)
      dimension nnum (29)
      character*512 slog

c     kappa quantum number for each orbital
c     k = - (j + 1/2)  if l = j - 1/2
c     k = + (j + 1/2)  if l = j + 1/2
      data kappa /-1,-1, 1,-2,-1,   1,-2, 2,-3,-1,   1,-2, 2,-3, 3,
     1            -4,-1, 1,-2, 2,  -3, 3,-4,-1, 1,  -2, 2,-3,-1/

c     principal quantum number (energy eigenvalue)
      data nnum  /1,2,2,2,3,  3,3,3,3,4,  4,4,4,4,4,
     1            4,5,5,5,5,  5,5,5,6,6,  6,6,6,7/

c     occupation of each level for z = 1, 97
      data (iocc( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 3,i),i=1,29)  /2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 4,i),i=1,29)  /2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 4,i),i=1,29)  /0,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 5,i),i=1,29)  /2,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 5,i),i=1,29)  /0,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 6,i),i=1,29)  /2,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 6,i),i=1,29)  /0,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 7,i),i=1,29)  /2,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 7,i),i=1,29)  /0,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 8,i),i=1,29)  /2,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 8,i),i=1,29)  /0,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 9,i),i=1,29)  /2,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 9,i),i=1,29)  /0,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(10,i),i=1,29)  /2,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(10,i),i=1,29)  /0,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(11,i),i=1,29)  /2,2,2,4,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(11,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(12,i),i=1,29)  /2,2,2,4,2,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(12,i),i=1,29)  /0,0,0,0,2,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(13,i),i=1,29)  /2,2,2,4,2,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(13,i),i=1,29)  /0,0,0,0,2,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(14,i),i=1,29)  /2,2,2,4,2,  2,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(14,i),i=1,29)  /0,0,0,0,2,  2,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(15,i),i=1,29)  /2,2,2,4,2,  2,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(15,i),i=1,29)  /0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(16,i),i=1,29)  /2,2,2,4,2,  2,2,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(16,i),i=1,29)  /0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(17,i),i=1,29)  /2,2,2,4,2,  2,3,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(17,i),i=1,29)  /0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(18,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(18,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(19,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(19,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(20,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(20,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(21,i),i=1,29)  /2,2,2,4,2,  2,4,1,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(21,i),i=1,29)  /0,0,0,0,0,  0,0,1,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(22,i),i=1,29)  /2,2,2,4,2,  2,4,2,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(22,i),i=1,29)  /0,0,0,0,0,  0,0,2,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(23,i),i=1,29)  /2,2,2,4,2,  2,4,3,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(23,i),i=1,29)  /0,0,0,0,0,  0,0,3,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(24,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(24,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(25,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(26,i),i=1,29)  /2,2,2,4,2,  2,4,4,2,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(26,i),i=1,29)  /0,0,0,0,0,  0,0,4,2,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(27,i),i=1,29)  /2,2,2,4,2,  2,4,4,3,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(27,i),i=1,29)  /0,0,0,0,0,  0,0,4,3,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(28,i),i=1,29)  /2,2,2,4,2,  2,4,4,4,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(28,i),i=1,29)  /0,0,0,0,0,  0,0,4,4,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(29,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(29,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(30,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(30,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(31,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(31,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(32,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(32,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(33,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(34,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,2,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,2,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(35,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,3,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,3,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(36,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(37,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(38,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(39,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(40,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(41,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(42,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(43,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(44,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,3,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,3,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(45,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,4,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,4,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(46,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(47,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(48,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(49,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(50,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(51,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(52,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(53,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(54,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(55,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ival(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/
      data (iocc(56,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(57,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc(58,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,2,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(59,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,3,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(60,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,4,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(61,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,5,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(62,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(63,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           1,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           1,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(64,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           1,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           1,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc(65,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           3,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           3,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(66,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           4,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           4,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(67,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           5,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           5,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(68,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           6,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           6,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(69,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           7,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           7,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(70,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           8,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(71,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc(72,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ival(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,2,  0,0,0,2,0,  0,0,0,0/
      data (iocc(73,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,3,  0,0,0,2,0,  0,0,0,0/
      data (ival(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,3,  0,0,0,2,0,  0,0,0,0/
      data (iocc(74,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  0,0,0,2,0,  0,0,0,0/
      data (ival(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  0,0,0,2,0,  0,0,0,0/
      data (iocc(75,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  1,0,0,2,0,  0,0,0,0/
      data (ival(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  1,0,0,2,0,  0,0,0,0/
      data (iocc(76,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  2,0,0,2,0,  0,0,0,0/
      data (ival(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  2,0,0,2,0,  0,0,0,0/
      data (iocc(77,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  3,0,0,2,0,  0,0,0,0/
      data (ival(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  3,0,0,2,0,  0,0,0,0/
      data (iocc(78,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  5,0,0,1,0,  0,0,0,0/
      data (ival(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  5,0,0,1,0,  0,0,0,0/
      data (iocc(79,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,1,0,  0,0,0,0/
      data (ival(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,1,0,  0,0,0,0/
      data (iocc(80,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,0,  0,0,0,0/
      data (ival(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,0,  0,0,0,0/
      data (iocc(81,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,1,  0,0,0,0/
      data (ival(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,1,  0,0,0,0/
      data (iocc(82,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  0,0,0,0/
      data (ival(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  0,0,0,0/
      data (iocc(83,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  1,0,0,0/
      data (ival(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  1,0,0,0/
      data (iocc(84,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  2,0,0,0/
      data (ival(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  2,0,0,0/
      data (iocc(85,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  3,0,0,0/
      data (ival(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  3,0,0,0/
      data (iocc(86,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,0/
      data (ival(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  4,0,0,0/
      data (iocc(87,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,1/
      data (ival(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/
      data (iocc(88,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,2/
      data (ival(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,2/
      data (iocc(89,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,1,0,2/
      data (ival(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,1,0,2/
      data (iocc(90,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,2,0,2/
      data (ival(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,2,0,2/
      data (iocc(91,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,2,0,2,2,  4,1,0,2/
      data (ival(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,2,0,0,0,  0,1,0,2/
      data (iocc(92,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,3,0,2,2,  4,1,0,2/
      data (ival(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,3,0,0,0,  0,1,0,2/
      data (iocc(93,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,4,0,2,2,  4,1,0,2/
      data (ival(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,4,0,0,0,  0,1,0,2/
      data (iocc(94,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,0,2,2,  4,0,0,2/
      data (ival(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,0,0,0,  0,0,0,2/
      data (iocc(95,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,1,2,2,  4,0,0,2/
      data (ival(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,1,0,0,  0,0,0,2/
      data (iocc(96,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,2,2,2,  4,0,0,2/
      data (ival(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,2,0,0,  0,0,0,2/
      data (iocc(97,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,3,2,2,  4,0,0,2/
      data (ival(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,3,0,0,  0,0,0,2/

      if (iz .lt. 1  .or.  iz .ge. 97)  then
    8    format(' Atomic number ', i5, ' not available.')
         write(slog,8)  iz
         call wlog(slog)
         stop
      endif

      ion = nint(xion)
      delion=xion-ion
      index = iz - ion
      ilast = 0
      iscr = 0
      iion = 0
      iholep = ihole

c     find last occupied orbital (ilast)
      do 30 i=29,1,-1
 30   if (ilast.eq.0 .and. iocc(index,i).gt.0) ilast=i

      if (ihole.lt.0 .and. iocc(index,ihole) .lt. 1 .or.
     1   (ihole.eq.ilast .and. iocc(index,ihole)-delion.lt.1) ) then
         call wlog(' Cannot remove an electron from this level')
         stop 'GETORB-1'
      endif

c        the recipe for final state atomic configuration is changed
c        from iz+1 prescription, since sometimes it changed occupation
c        numbers in more than two orbitals. This could be consistent
c        only with s02=0.0. New recipe remedy this deficiency.

c     find where to put screening electron
      index1 = index + 1
      do 10  i = 1, 29
 10   if (iscr.eq.0 .and. (iocc(index1,i)-iocc(index,i)).gt.0.5) iscr=i
c     special case of hydrogen like ion
c     if (index.eq.1) iscr=2

c     find where to add or subtract charge delion (iion).
      if (delion .gt. 0) then
c        removal of electron charge
         iion = ilast
      elseif (delion .lt. 0) then
c        addition of electron charge
         iion = iscr
c        except special cases
         if (ihole.ne.0 .and.
     1       iocc(index,iscr)+1-delion.gt.2*abs(kappa(iscr))) then
             iion = ilast
             if (ilast.eq.iscr .or. iocc(index,ilast)-delion.gt.
     1                          2*abs(kappa(ilast)) ) iion = ilast + 1
         endif
      endif

      norb = 0
      do 20  i = 1, 29
         if (iocc(index,i).gt.0 .or. (i.eq.iscr .and. ihole.gt.0)
     1       .or. (i.eq.iion .and. xnel(norb)-delion.ne.0))  then
            if (i.ne.ihole .or. iocc(index,i).ge.1) then
               norb = norb + 1
               nqn(norb) = nnum(i)
               nk(norb)  = kappa(i)
               xnel(norb) = iocc(index,i)
               if (i.eq.ihole) then
                  xnel(norb) = xnel(norb) - 1
                  iholep = ihole
               endif
               if (i.eq.iscr .and. ihole.gt.0)  xnel(norb)=xnel(norb)+1
               xnval(norb)= ival(index,i)
               if (i.eq.ihole .and. xnval(norb).ge.1)
     1                         xnval(norb) = xnval(norb) - 1
               if (i.eq.iscr .and. ihole.gt.0)
     1                         xnval(norb) = xnval(norb) + 1
               if (i.eq.iion)  xnel(norb) = xnel(norb) - delion
               if (i.eq.iion)  xnval(norb) = xnval(norb) - delion
               den(norb) = 0.0
            endif
         endif
   20 continue
      norbco = norb

c     check that all occupation numbers are within limits
      do 50 i = 1, norb
         if ( xnel(i).lt.0 .or.  xnel(i).gt.2*abs(nk(i)) .or.
     1       xnval(i).lt.0 .or. xnval(i).gt.2*abs(nk(i)) ) then
            write (slog,55) i
   55       format(' error in getorb.f. Check occupation number for ',
     1      i3, '-th orbital. May be a problem with ionicity.')
            call wlog(slog)
            stop
         endif
  50  continue
c      do 60 i=1,norb
c60    xnval(i) = 0.0d0
c60    xnval(i) = xnel(i)

      return
      end
      double precision function getxk (e)
      implicit double precision (a-h, o-z)

c     Make xk from energy as
c          k =  sqrt( e)  for e > 0  (above the edge)
c          k = -sqrt(-e)  for e < 0  (below the edge)

      getxk = sqrt(abs(e))
      if (e .lt. 0)  getxk = - getxk
      return
      end
      subroutine vlda(ia, xnval,srho, srhovl,vtrho, ilast, idfock)
c    this program calculates xc potential, using core-vlaence separation
c    discussed in ankuodinov's thesis.
c    written by alexei ankoudinov. 11.07.96
      implicit double precision (a-h,o-z)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      dimension xnval(30), srho (251), srhovl(251), vtrho(251)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1        fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10),
     2              eg(251),ceg(10),ep(251),cep(10)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim

      do 10 i = 1,251
        srhovl(i) = 0.0d0
 10     srho(i) = 0.0d0

c  find total and valence densities. Remove self-interaction if SIC
      do 50 j = 1, norb
        a = xnel(j)
        b = xnval(j)
c      use to test SIC
c       if (j .eq. ia) a=a-1.0d0
c       if (j .eq. ia) b=b-1.0d0
      do 50 i = 1,nmax(j)
        srho(i) = srho(i) + a * (cg(i,j)**2+cp(i,j)**2)
 50     srhovl(i) = srhovl(i) + b * (cg(i,j)**2+cp(i,j)**2)

c  constract lda potential. Put your favorite model into vbh.f.
c  exch=5,6 correspond to 2 ways of core-valence separation of V_xc.
      vi0 = 0.0d0
      do 90 i = 1,251
        rho = srho(i) / (dr(i)**2)
        if (idfock.eq.5) then
c          for exch=5 valence density*4*pi
           rhoc = srhovl(i) / (dr(i)**2)
        elseif (idfock.eq.6) then
c          for exch=6 core density*4*pi
           rhoc = (srho(i)-srhovl(i)) / (dr(i)**2)
        elseif (idfock.eq.1) then
           rhoc = 0.0d0
        else
            stop ' undefined idfock in subroutine vlda'
        endif

        if (rho .gt. 0.0 ) then
           rs = (rho/3)**(-third)
           rsc =101.0
           if (rhoc .gt.0.0) rsc = (rhoc/3)**(-third)
           xm = 1.0d0
c          vbh in Ryd and edp in Hartrees
           if (idfock.eq.5) then
c             for exch=5
              call vbh(rsc, xm, vvbh)
              vxcvl = vvbh/2
           elseif (idfock.eq.6) then
c             for exch=6
              call vbh(rs, xm, vvbh)
                 xf = fa/rs
              call edp(rsc,xf,vi0,vdh,vi)
              vxcvl = vvbh/2 - vdh
           elseif (idfock.eq.1) then
c          for pure Dirac-Fock
              vxcvl = 0.0d0
           endif

c   contribution to the total energy from V_xc:=\int d^3 r V_xc * rho/2
           if (ilast.gt.0) vtrho (i) = vtrho(i) +
     1         vxcvl * srho(i)
c    1         vxcvl * xnel(ia)*(cg(i,ia)**2+cp(i,ia)**2)
c           use to test SIC

c  add to the total potential and correct it's development coefficients
           if (i.eq.1) av(2) = av(2) +vxcvl/cl
           dv(i) = dv(i) +vxcvl/cl
        endif
 90   continue
 999  continue

      return
      end
      subroutine sthead (ntitle, title, ltitle, nph, iz, rmt, rnrm,
     1                  xion, ifrph, ihole, ixc,
     2                  vr0, vi0, rs0, gamach, xmu, xf, vint, rs,
     2                  nohole, lreal,  rgrd,
     3                  nhead, lhead, head)

c     SeT HEAD
c     This routine makes the file header, returned in head array.
c     header lines do not include a leading blank.
c     Last header line is not --------- end-of-header line

c     title lines coming into sthead include carriage control, since
c     they were read from potph.dat

      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      logical nohole, lreal
      dimension ifrph(0:nphx)
      dimension xion(0:nfrx)
      dimension iz(0:nfrx)
      dimension rmt(0:nphx)
      dimension rnrm(0:nphx)

      character*80 title(ntitle)
      parameter (nheadx = 30)
      character*80 head(nheadx)
      dimension lhead(nheadx), ltitle(ntitle)

      character*80 heada(nheadx)
      dimension lheada(nheadx)
      save nheada, lheada, heada
c     heada, etc., are saved for use by entry wthead

      character*10 shole(0:29)
      character*8  sout(0:7)
      common /labels/ shole, sout
c     include 'vers.h'
      character*12 vfeff
      common /vers/ vfeff
c     character*12 vfeff, vpotph, vpaths, vgenfm, vff2ch
c     common /vers/ vfeff, vpotph, vpaths, vgenfm, vff2ch

c     Fills head arrray, n = number of lines used.
c     Does not include line of dashes at the end.

      nhead = 1
      if (ntitle .ge. 1  .and.  ltitle(1).gt.1)  then
         write(head(nhead),100)  title(1)(2:), vfeff
      else
         write(head(nhead),102)  vfeff
      endif
  100 format(a55, t66, a12)
  102 format(t66, a12)
      do 120  ititle = 2, ntitle
         if (ltitle(ititle).le.1)  goto 120
         nhead = nhead+1
         write(head(nhead),110) title(ititle)(2:)
  110    format(a78)
  120 continue
      if (xion(0) .ne. 0)  then
         nhead = nhead+1
         write(head(nhead),130)  iz(0), rmt(0)*bohr,
     1                    rnrm(0)*bohr, xion(0), shole(ihole)
      else
         nhead = nhead+1
         write(head(nhead),140)  iz(0), rmt(0)*bohr,
     1                    rnrm(0)*bohr, shole(ihole)
      endif
  130 format('Abs   Z=',i2, ' Rmt=',f6.3, ' Rnm=',f6.3,
     1       ' Ion=',f5.2,  1x,a10)
  140 format('Abs   Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3, 1x,a10)
      if (nohole)  then
         nhead = nhead+1
         write(head(nhead),142)
  142    format ('Calculations done with no core hole.')
      endif
      if (lreal)  then
         nhead = nhead+1
         write(head(nhead),144)
  144    format ('Calculations done using only real phase shifts.')
      endif
      if (abs(rgrd - 0.05) .gt. 1.0e-5)  then
         nhead = nhead+1
         write(head(nhead),146)  rgrd
  146    format ('Calculations done using rgrid ', f12.7)
      endif

      do 150  iph = 1, nph
         ifr = ifrph(iph)
         if (xion(ifr) .ne. 0)  then
            nhead = nhead+1
            write(head(nhead),160)  iph, iz(ifr),  rmt(iph)*bohr,
     1           rnrm(iph)*bohr, xion(ifr)
         else
            nhead = nhead+1
            write(head(nhead),170)  iph, iz(ifr),  rmt(iph)*bohr,
     1           rnrm(iph)*bohr
         endif
  150 continue
  160 format('Pot',i2,' Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3,' Ion=',f5.2)
  170 format('Pot',i2,' Z=',i2,' Rmt=',f6.3,' Rnm=',f6.3)
      if (abs(vi0) .gt. 1.0e-8 .or. abs(vr0) .gt. 1.0e-8)  then
         nhead = nhead+1
         write(head(nhead),180)  gamach*ryd, sout(ixc), vi0*ryd,
     1                           vr0*ryd
      else
         nhead = nhead+1
         write(head(nhead),190)  gamach*ryd, sout(ixc)
      endif
      nhead = nhead+1
  180 format('Gam_ch=',1pe9.3, 1x,a8, ' Vi=',1pe10.3, ' Vr=',1pe10.3)
  190 format('Gam_ch=',1pe9.3, 1x,a8)
  200 format('Mu=',1pe10.3, ' kf=',1pe9.3, ' Vint=',1pe10.3,
     x        ' Rs_int=',0pf6.3)
      write(head(nhead),200)  xmu*ryd, xf/bohr, vint*ryd, rs
      if (ixc .eq. 4)  then
          nhead = nhead+1
          write(head(nhead),210)  rs0
  210     format ('Experimental DH-HL exch, rs0 = ', 1pe14.6)
      endif
      do 220  i = 1, nhead
         lhead(i) = istrln(head(i))
         heada(i) = head(i)
         lheada(i) = lhead(i)
  220 continue
      nheada = nhead

      return

      entry wthead (io)
c     Dump header to unit io, which must be open.  Add carriage control
c     to head array, which doesn't have it.

      do 310 i = 1, nheada
         ll = lheada(i)
         write(io,300)  heada(i)(1:ll)
  300    format (1x, a)
  310 continue
      end
c     These heap routines maintain a heap (array h) and an index
c     array (array ih) used to keep other data associated with the heap
c     elements.

      subroutine hup (h, ih, n)
c     heap is in order except for last element, which is new and must
c     be bubbled through to its proper location
c     new element is at i, j = index of parent
      integer  n,i,j
      integer  ih(n)
      dimension h(n)

      i = n

   10 j = i/2
c     if no parent, we're at the top of the heap, and done
      if (j .eq. 0)  return
      if (h(i) .lt. h(j))  then
         call swap (h(i), h(j))
         call iswap (ih(i), ih(j))
         i = j
         goto 10
      endif
      return
      end

      subroutine hdown (h, ih, n)
c     h is in order, except that 1st element has been replaced.
c     Bubble it down to its proper location.  New element is i,
c     children are j and k.

      integer  n,i,j,k
      integer  ih(n)
      dimension h(n)

      i = 1

   10 continue
      j = 2*i
      k = j + 1

c     if j > n, new element is at bottom, we're done
      if (j .gt. n)  return
c     handle case where new element has only one child
      if (k .gt. n)  k = j

      if (h(j) .gt. h(k))  j = k
c     j is now index of smallest of children

      if (h(i) .gt. h(j))  then
         call swap (h(i), h(j))
         call iswap (ih(i), ih(j))
         i = j
         goto 10
      endif

      return
      end

      subroutine swap (a, b)
      t = a
      a = b
      b = t
      return
      end

      subroutine iswap (i, j)
      integer  i,j,k
      k = i
      i = j
      j = k
      return
      end
      subroutine imhl (rs, xk, eim, icusp)
      implicit double precision (a-h,o-z)

c     what is xk?  k**2 - mu + kf**2?

c written by j. mustre (march 1988)
c code is based on analytical expression derived by john rehr.
c it leaves the real part, calculated in rhl unchanged.
c
c modified by j. rehr  (oct 1991) - adds quinn approximation for
c losses due to electron-hole pairs below the plasmon turn on
c see new subroutine quinn.f, which incorporates r. albers coding of
c j.j. quinn's approximations for details.

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     alph is Hedin-Lundquist parameter
      parameter (alph = 4.0 / 3.0)
      external ffq

      icusp=0
      xf = fa / rs
      ef = xf**2 / 2

c     xk0 is xk normalized by k fermi.
      xk0 = xk/xf
c     set to fermi level if below fermi level
      if (xk0 .lt. 1.00001) then
         xk0 = 1.00001
      endif

c     wp is given in units of the fermi energy in the formula below.
      wp = sqrt (3 / rs**3) / ef
      xs = wp**2 - (xk0**2 - 1)**2

      eim = 0
      if (xs .lt. 0.)  then
         q2 = sqrt ( (sqrt(alph**2-4*xs) - alph) / 2 )
         qu = min (q2, (1+xk0))
         d1 = qu - (xk0 - 1)
         if (d1 .gt. 0)  then
            eim = ffq (qu,ef,xk,wp,alph) - ffq (xk0-1,ef,xk,wp,alph)
         endif
      endif
      call cubic (xk0, wp, alph, rad, qplus, qminus)

      if (rad .le. 0) then
         d2 = qplus - (xk0 + 1)
         if (d2 .gt. 0)  then
            eim = eim + ffq (qplus,ef,xk,wp,alph) -
     1                  ffq (xk0+1,ef,xk,wp,alph)
         endif
         d3 = (xk0-1) - qminus
         if (d3 .gt. 0)  then
            eim = eim + ffq (xk0-1,ef,xk,wp,alph) -
     1                  ffq (qminus,ef,xk,wp,alph)
c           beginning of the imaginary part and position of the cusp x0
            icusp = 1
         endif
      endif

      call quinn (xk0, rs, wp, ef, ei)
      if (eim .ge. ei)  eim = ei

      return
      end
      subroutine ipack (iout, n, ipat)

c     Input:  n          number of things to pack, nmax=8
c             ipat(1:n)  integers to pack
c     Output: iout(3)    packed version of n and ipat(1:n)
c
c     Packs n and ipat(1:n) into 3 integers, iout(1:3).  Algorithm
c     packs three integers (each between 0 and 1289 inclusive) into a
c     single integer.  Single integer must be INT*4 or larger, we assume
c     that one bit is wasted as a sign bit so largest positive int
c     is 2,147,483,647 = (2**31 - 1).
c     This version is specifically for the path finder and
c     degeneracy checker.

      dimension iout(3), ipat(n)
      dimension itmp(8)
      parameter (ifac1 = 1290, ifac2 = 1290**2)

      if (n .gt. 8)  stop 'ipack n too big'

      do 10  i = 1, n
         itmp(i) = ipat(i)
   10 continue
      do 20  i = n+1, 8
         itmp(i) = 0
   20 continue

      iout(1) = n       + itmp(1)*ifac1 + itmp(2)*ifac2
      iout(2) = itmp(3) + itmp(4)*ifac1 + itmp(5)*ifac2
      iout(3) = itmp(6) + itmp(7)*ifac1 + itmp(8)*ifac2

      return
      end
      subroutine upack (iout, n, ipat)

c     retrieve n and ipat from iout
c     Input:  iout(3)  packed integers
c             n        max number to get, must be .le. 8
c     Output: n        number unpacked
c             ipat(1:n) unpacked integers

      dimension iout(3), ipat(n)
      dimension itmp(8)
      parameter (ifac1 = 1290, ifac2 = 1290**2)

      nmax = n
      if (nmax .gt. 8)  stop 'nmax .gt. 8 in upack'

      n = mod (iout(1), ifac1)
      if (n .gt. nmax)  stop 'nmax in upack too small'

      itmp(1) = mod (iout(1), ifac2) / ifac1
      itmp(2) = iout(1) / ifac2
      itmp(3) = mod (iout(2), ifac1)
      itmp(4) = mod (iout(2), ifac2) / ifac1
      itmp(5) = iout(2) / ifac2
      itmp(6) = mod (iout(3), ifac1)
      itmp(7) = mod (iout(3), ifac2) / ifac1
      itmp(8) = iout(3) / ifac2

      do 10  i = 1, n
         ipat(i) = itmp(i)
   10 continue

      return
      end
      subroutine istprm ( nph, nat, iphat, rat, iatph, xnatph,
     1                novr, iphovr, nnovr, rovr, folp, edens, edenvl,
     2                dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     2                ixc, rhoint, vint, rs, xf, xmu,
     3                rhinvl, vintvl, rsval, xfval, xmuval,
     3                rnrmav, intclc, german, rd, sigmd, pgrid)

c     Finds interstitial parameters, rmt, vint, etc.
      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)
      dimension xnatph(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)
      dimension folp(0:nphx)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension dmag(251,0:nfrx)
      dimension vclap(251,0:nphx)
      dimension vtot (251,0:nphx), vvalgs (251,0:nphx)
      dimension imt(0:nphx)
      dimension inrm(0:nphx)
      dimension rmt(0:nphx)
      dimension rnrm(0:nphx)
      logical german
      dimension fractn(0:nphx)
c7      dimension rd(251,0:nphx), dr(251), formf(100,0:nphx)
c7      dimension xq(100),sigmd(51), pgrid(51)
      parameter (big = 5000)
      character*512 slog

c     intclc = 0, average evenly over all atoms
c              1, weight be lorentzian, 1 / (1 + 3*x**2), x = r/rnn,
c                 r   = distance to central atom,
c                 rnn = distance of near neighbor to central atom

c Find muffin tin radii.  We'll find rmt based on norman prescription,
c ie, rmt(i) = R * folp * rnrm(i) / (rnrm(i) + rnrm(j)),
c a simple average
c based on atoms i and j.  We average the rmt's from each pair of
c atoms, weighting by the volume of the lense shape formed by the
c overlap of the norman spheres.
c NB, if folp=1, muffin tins touch without overlap, folp>1 gives
c overlapping muffin tins.
c
c rnn is distance between sphere centers
c rnrm is the radius of the norman sphere
c xl_i is the distance to the plane containing the circle of the
c    intersection
c h_i  = rnrm_i - xl_i is the height of the ith atom's part of
c    the lense
c vol_i = (pi/3)*(h_i**2 * (3*rnrm_i - h_i))
c
c xl_i = (rnrm_i**2 - rnrm_j**2 + rnn**2) / (2*rnn)

      do 140  iph = 0, nph
         voltot = 0
         rmtavg = 0
         fractn(iph) = 0.0
         if (novr(iph) .gt. 0)  then
c           Overlap explicitly defined by overlap card
            rnear = big
            do 124  iovr = 1, novr(iph)
               rnn  = rovr(iovr,iph)
               if (rnn .le. rnear)  rnear = rnn
               inph = iphovr(iovr,iph)
c              Don't avg if norman spheres don't overlap
               if (rnrm(iph)+rnrm(inph) .le. rnn)  goto 124
               voltmp = calcvl (rnrm(iph), rnrm(inph), rnn)
               voltmp = voltmp + calcvl (rnrm(inph), rnrm(iph), rnn)
               rmttmp = rnn * folp(iph) * rnrm(iph) /
     1                  (rnrm(iph) + rnrm(inph))
               ntmp = nnovr(iovr,iph)
               rmtavg = rmtavg + rmttmp*voltmp*ntmp
               voltot = voltot + voltmp*ntmp
  124       continue
         else
            iat = iatph(iph)
            rnear = big
            do 130  inat = 1, nat
               if (inat .eq. iat)  goto 130
               rnn = dist (rat(1,inat), rat(1,iat))
               if (rnn .le. rnear)  rnear = rnn
               inph = iphat(inat)
c              Don't avg if norman spheres don't overlap
               if (rnrm(iph)+rnrm(inph) .lt. rnn)  goto 130
               voltmp = calcvl (rnrm(iph), rnrm(inph), rnn)
               voltmp = voltmp + calcvl (rnrm(inph), rnrm(iph), rnn)
               rmttmp = rnn * folp(iph) * rnrm(iph) /
     1                  (rnrm(iph) + rnrm(inph))
               rmtavg = rmtavg + rmttmp*voltmp
               voltot = voltot + voltmp
  130       continue
         endif
         if (rmtavg .le. 0)  then
            write(slog,132) iat, iph
            call wlog(slog)
  132       format (' WARNING: NO ATOMS CLOSE ENOUGH TO OVERLAP ATOM',
     1              i5, ',  UNIQUE POT', i5, '!!  ',
     2              'Rmt set to Rnorman.  May be error in ',
     3              'input file.')
            rmt(iph) = rnrm(iph)
         else
            rmt(iph) = rmtavg / voltot
            if (rmt(iph) .ge. rnear)  then
               call wlog(' Rmt >= distance to nearest neighbor.  ' //
     1            'Not physically, meaningful.')
               call wlog(' FEFF may crash.  Look for error in ATOM '//
     1            'list or OVERLAP cards.')
            endif
         endif
  140 continue

c     Need potential with ground state xc, put it into vtot
      do 160  iph = 0, nph
         call sidx (edens(1,iph), 250, rmt(iph), rnrm(iph),
     1              imax, imt(iph), inrm(iph))
         do 150  i = 1, imax
            rs = (edens(i,iph)/3)**(-third)
c     spin dependent xc potential for ground state from Von Barth, Hedin
c     J.Phys.C:Solid State Phys., 5, 1629 (1972).
c     xmag/2 -fraction of spin up or down, depending on sign in renorm.f
c     put xmag = 1.0 to calculate cmd with external potential difference
            xmag = 1.0 + dmag(i,iph)/edens(i,iph)
c           wrong for ferromagnets, need to overlap dmag(i)

c           vvbh from Von Barth Hedin paper, 1971
            call vbh(rs,xmag,vvbh)
            vtot(i,iph) = vclap(i,iph) + vvbh

            if (mod(ixc,10).eq.5) then
              rsval = 10.0
              if (edenvl(i,iph) .gt. 0.00001)
     1           rsval = (edenvl(i,iph)/3)**(-third)
              if (rsval.gt.10.0) rsval = 10.0
              xmagvl = 1.0 +dmag(i,iph)/edenvl(i,iph)
              call vbh(rsval,xmagvl,vvbhvl)
              vvalgs(i,iph) = vclap(i,iph) + vvbhvl
            elseif (mod(ixc,10) .ge. 6) then
              if (edens(i,iph).le.edenvl(i,iph)) then
                 rscore =101.0
              else
                 rscore = ((edens(i,iph)-edenvl(i,iph)) / 3)**(-third)
              endif
              rsmag = ((edens(i,iph)+dmag(i,iph)) / 3)**(-third)
              xfmag = fa/rsmag
              vi0 = 0.0
              call edp(rscore,xfmag,vi0,vrdh,vi)
              vvalgs(i,iph) = vclap(i,iph) + vvbh -2*vrdh
c             factor 2 to transform from Hartrees to Ryd
            endif
  150    continue
  160 continue

c     What to do about interstitial values?
c     Calculate'em for all atoms, print'em out for all unique pots along
c     with derivative quantities, like fermi energy, etc.
c     Interstitial values will be average over all atoms in problem.

c     rnrmav is averge norman radius,
c     (4pi/3)rnrmav**3 = (sum((4pi/3)rnrm(i)**3)/n, sum over all atoms
c     in problem
      rnrmav = 0
      xn = 0
      rs = 0
      vint   = 0
      rhoint = 0
      rsval = 0
      vintvl   = 0
      rhinvl = 0
c     volint is total interstitial volume
      volint = 0

      do 170  iph = 0, nph
         call istval (vtot(1,iph), edens(1,iph), rmt(iph), imt(iph),
     2                rnrm(iph), inrm(iph), vintx, rhintx, ierr)
c  to get interstitial values from valence electrons only. ala 05.23.95
         if (mod(ixc,10).ge.5)
     1    call istval (vvalgs(1,iph), edenvl(1,iph),rmt(iph),imt(iph),
     2                rnrm(iph), inrm(iph), vintvx, rhinvx, ierr)
c        if no contribution to interstitial region, skip this unique pot
         if (ierr .ne. 0)  goto 170
c        (factor 4pi/3 cancel in numerator and denom, so leave out)
         volx = (rnrm(iph)**3 - rmt(iph)**3)
         if (german) fractn(iph)=xnatph(iph)*3.0/4.0/pi
         if (volx .le. 0)  goto 170
         if (.not. german) fractn(iph)=xnatph(iph)*volx
         volint = volint + volx * xnatph(iph)
         vint   = vint   + vintx * volx * xnatph(iph)
         rhoint = rhoint + rhintx* volx * xnatph(iph)
         if (mod(ixc,10).ge.5) then
            vintvl   = vintvl   + vintvx * volx * xnatph(iph)
            rhinvl = rhinvl + rhinvx* volx * xnatph(iph)
         endif
  170 continue
c     If no contribution to interstitial from any atom, die.
      if (volint .le. 0)  then
         call wlog(' No interstitial density.  Check input file.')
         stop 'ISTPRM'
      endif
      vint   = vint   / volint
      rhoint = rhoint / volint
      call fermi (rhoint, vint, xmu, rs, xf)
      xmuval = xmu
      if (mod(ixc,10).ge.5) then
         vintvl   = vintvl   / volint
         rhinvl = rhinvl / volint
         if (mod(ixc,10).eq.5) then
            call fermi (rhinvl, vintvl, xmuval, rsval, xfval)
         elseif (mod(ixc,10).eq.6) then
            vintvl = vint
         elseif (mod(ixc,10).eq.7) then
            call fermi (rhoint, vintvl, xmuval, rs, xf)
         endif
      endif


      do 180  iph = 0, nph
         rnrmav = rnrmav + xnatph(iph) * rnrm(iph)**3
         xn = xn + xnatph(iph)
  180 continue
      if (mod(ixc,10) .eq. 7) then
         do 190 iph = 0,nph
            if (german) then
               fractn(iph) = fractn(iph)/rnrmav
            else
               fractn(iph) = fractn(iph)/volint
            endif
  190    continue
      endif

      rnrmav = (rnrmav/xn) ** third

c7      if (mod(ixc,10) .eq. 7) then
c        calculate \sigma_d in interstitial region using wkb approach
c        (ala thesis) german=false should be used
c        german=true can be used to reproduce the results in
c        Horsch, von der Linden, Lukas, Sol.St.Comm.62,359 (1987),
c        but it will overestimate the importance of \sigma_d
c7       open (unit=9, file='sigmad.dat', status='unknown')
c7         open (unit=8, file='formf.dat', status='unknown')
c7         do 210 ir = 1,251
c7 210        dr(ir) = exp(-8.8 + 0.05*(ir-1))
c7         do 220 iph = 0,nph
c7         do 220 i = 1,251
c7            rd(i,iph) = rd(i,iph) * dr(i)
c7 220     continue
c7         dq= 0.1
c7         do 230 i=1,100
c7 230        xq(i) = dq*(i-1)*(i+100)/100.0
c7         do 240 iph = 0,nph
c7            formf(1,iph) = 0.0
c7         do 240 i=2,100
c7            formf(i,iph) = frmfac(xq(i),rd(1,iph),dr)
c7            write(8,235) xq(i), formf(i,iph)
c7 235        format ( 2e15.5)
c7 240     continue

c7         dxk = 0.2
c7         do 290 i = 1,51
c7c        define p-grid to store \sigma_d
c7            xk = (i-1)*dxk
c7            pgrid(i) = sqrt(xf**2 + xk**2)
c7            call sigmad(pgrid(i), nph, rmt, rnrm, formf, xq, rd, dr,
c7     1                      fractn,german,sigmd(i))
c7c           transform sigma_d from a.u. to rydbergs
c7            sigmd(i) = sigmd(i) * 2.0
c7            if (i.eq.1) xmuval= xmuval + sigmd(1)

c7c         test rhl for the system
c7            xkp = sqrt(xf**2 + xk**2)
c7            call rhl(rs,xkp,vxcr,vxci)
c7            call rhl(rsval,pgrid(i),vxcrvl,vxcivl)
c7            ener=13.6*(xk*xk + xmuval)
c7            write(9,280) ener,xk, sigmd(i)*1.36,vxcr*2.72,vxci*2.72,
c7     1           vxcrvl*2.72,vxcivl*2.72
c7 280        format ( 7e11.3)
c7 290     continue
c7         close (unit=9)
c7         close (unit=8)

c     for core-valence separation in interstitial region
c        xmuval = xmuval + sigmd(1) already done above for rhl test
c7         vintvl = vintvl + sigmd(1)
c7      endif

      return
      end

      double precision function calcvl (r1, r2, r)
      implicit double precision (a-h, o-z)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      xl = (r1**2 - r2**2 + r**2) / (2*r)
      h = r1 - xl
      calcvl = (pi/3) * h**2 * (3*r1 - h)
      return
      end
      subroutine istval (vtot, rholap, rmt, imt, rws, iws, vint, rhoint,
     1                   ierr)

c     This subroutine calculates interstitial values of v and rho
c     for an overlapped atom.  Inputs are everything except vint and
c     rhoint, which are returned.  vtot includes ground state xc.
c     rhoint is form density*4*pi, same as rholap
c
c     ierr = 0, normal exit
c          =-1, rmt=rws, no calculation possible

      implicit double precision (a-h, o-z)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      parameter (delta = 0.050 000 000 000 000)

      dimension vtot (nrptx)
      dimension rholap (nrptx)

c     Integrations are done in x (r = exp(x), see Louck's grid)
c     Trapezoidal rule, end caps use linear interpolation.
c     imt is grid point immediately below rmt, etc.
c     We will integrate over spherical shell and divide by volume of
c     shell, so leave out factor 4pi, vol = r**3/3, not 4pi*r**3/3,
c     similarly leave out 4pi in integration.

c     If rmt and rws are the same, cannot contribute to interstitial
c     stuff, set error flag
      vol = (rws**3 - rmt**3) / 3
      if (vol .le. 0)  then
         ierr = -1
         return
      endif
      ierr = 0

c     Calculation of vint including exchange correlation
c     Trapezoidal rule from imt+1 to iws
      vint = 0
      do 100  i = imt, iws-1
         fr = rr(i+1)**3 * vtot(i+1)
         fl = rr(i)**3   * vtot(i)
         vint = vint + (fr+fl)*delta/2
  100 continue
c     End cap at rws (rr(iws) to rws)
      xws = log (rws)
      xiws = xx(iws)
      g = xws - xiws
      fr = rr(iws+1)**3 * vtot(iws+1)
      fl = rr(iws)**3   * vtot(iws)
      vint = vint + (g/2) * ( (2-(g/delta))*fl + (g/delta)*fr)
c     End cap at rmt (rmt to rr(imt+1))
      xmt = log (rmt)
      ximt = xx(imt)
      g = xmt - ximt
      fr = rr(imt+1)**3 * vtot(imt+1)
      fl = rr(imt)**3   * vtot(imt)
      vint = vint - (g/2) * ( (2-(g/delta))*fl + (g/delta)*fr)
      vint = vint / vol

c     Calculation of rhoint
c     Trapezoidal rule from imt+1 to iws
      rhoint = 0
      do 200  i = imt, iws-1
         fr = rr(i+1)**3 * rholap(i+1)
         fl = rr(i)**3   * rholap(i)
         rhoint = rhoint + (fr+fl)*delta/2
  200 continue
c     End cap at rws (rr(iws) to rws)
      xws = log (rws)
      xiws = xx(iws)
      g = xws - xiws
      fr = rr(iws+1)**3 * rholap(iws+1)
      fl = rr(iws)**3   * rholap(iws)
      rhoint = rhoint + (g/2) * ( (2-(g/delta))*fl + (g/delta)*fr)
c     End cap at rmt (rmt to rr(imt+1))
      xmt = log (rmt)
      ximt = xx(imt)
      g = xmt - ximt
      fr = rr(imt+1)**3 * rholap(imt+1)
      fl = rr(imt)**3   * rholap(imt)
      rhoint = rhoint - (g/2) * ( (2-(g/delta))*fl + (g/delta)*fr)
      rhoint = rhoint / vol

      return
      end
      subroutine mcrith (npat, ipat, ri, indbet,
     1                   ipot, nncrit, fbetac, ckspc, xheap)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension ipat(npatx)
      dimension ri(npatx+1), indbet(npatx+1)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)

c     Decide if we want the path added to the heap.

      if (ipat(npat) .eq. 0 .or. npat.le.2)  then
c        Partial path is used for xheap, not defined for ss and
c        triangles.  Special case: central atom added to end of path
c        necessary for complete tree, but not a real path, again,
c        xheap not defined.  Return -1 as not-defined flag.
         xheap = -1
      else
c        Calculate xheap and see if we want to add path to heap.
c        Factor for comparison is sum over nncrit of
c        f(beta1)*f(beta2)*..*f(beta npat-2)/(rho1*rho2*..*rho npat-1).
c        Compare this to sum(1/p), multiply by 100 so we can think
c        in percent.  Allow for degeneracy when setting crit.
         xheap = 0
         spinv = 0
         do 340  icrit = 1, nncrit
            x = ckspc(icrit) ** (-(npat-1)) * ri(npat-1)
            do 320  i = 1, npat-2
               ipot0 = ipot(ipat(i))
               x = x * fbetac(indbet(i),ipot0,icrit) / ri(i)
  320       continue
            spinv = spinv + 1/ckspc(icrit)
            xheap = xheap + x
  340    continue
         xheap = 100 * xheap / spinv

c        Factor for comparison is sum over nncrit of
c        New xheap:
c        Full chi is
c f(beta1)*f(beta2)*..*f(beta npat)cos(beta0)/(rho1*rho2*..*rho nleg).
c Some of this stuff may change when the path is modified --
c we can't use rho nleg or nleg-1, beta0, beta(npat) or beta(npat-1).
c We DO want to normalize wrt first ss path, f(pi)/(rho nn)**2.
c
c So save f(pi)/(rho nn)**2,
c calculate
c f(beta1)*f(beta2)*..*f(beta npat-2)/(rho1*rho2*..*rho npat-1).
c divide nn ss term by stuff we left out -- beta(npat), beta(npat-1),
c cos(beta0), rho nleg, rho nleg-1.
c
c Sum this over nncrit and try it out.
*
c        Sum over nncrit of
c        1/(rho1+rho2+..+rho npat-1).
*        reff = 0
*        do 350  i = 1, npat-1
*           reff = reff + ri(i)
* 350    continue
*        xss = 0
*        do 360  icrit = 1, nncrit
*           rho = ckspc(icrit) * reff
*           xss = xss + 1/rho
* 360    continue
*        xheap = 100 * xheap / xss
      endif

      return
      end
      subroutine mcritk (npat, ipat, ri, beta, indbet,
     1      ipot, nncrit, fbetac, xlamc, ckspc, xout, xcalcx)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension ipat(npatx)
      dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

c     xcalcx is max xcalc encountered so far.  Set to -1 to reset it --
c     otherwise it gets passed in and out as mcritk gets called.

c     We may want path in heap so that other paths built from this
c     path will be considered, but do not want this path to be
c     written out for itself.  Decide that now and save the flag
c     in the heap, so we won't have to re-calculate the mpprm
c     path parameters later.

c     Do not want it for output if last atom is central atom,
c     use xout = -1 as flag for undefined, don't keep it.
      if (ipat(npat) .eq. 0)  then
         xout = -1
         return
      endif

c     Make xout, output inportance factor.  This is sum over p of
c     (product of f(beta)/rho for the scatterers) *
c                                 (cos(beta0)/rho(npat+1).
c     Compare this to xoutx, max xout encountered so far.
c     Use mean free path factor, exp(-rtot/xlam)
c     Multiply by 100 so we can think in percent.

      xcalc = 0
      rtot = 0
      do 410  i = 1, npat+1
         rtot = rtot + ri(i)
  410 continue
      do 460  icrit = 1, nncrit
         rho = ri(npat+1) * ckspc(icrit)
c        when beta(0)=90 degrees, get zero, so fudge with cos=.2
         x = max (abs(beta(npat+1)), 0.3) / rho
         do 420  iat = 1, npat
            rho = ri(iat) * ckspc(icrit)
            ipot0 = ipot(ipat(iat))
            x = x * fbetac(indbet(iat),ipot0,icrit) / rho
  420    continue
         x = x * exp (-rtot/xlamc(icrit))
         xcalc = xcalc + x
  460 continue
      if (xcalc .gt. xcalcx)  xcalcx = xcalc
      xout = 100 * xcalc / xcalcx
      return
      end
      subroutine mkptz
c     makes polarization tensor ptz if necessary
      implicit double precision (a-h, o-z)

c     all input and output through common area /pol/
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

c     addittonal local stuff to create polarization tensor ptz(i,j)
      real e2(3)
      complex*16  e(3),eps,epc
      dimension eps(-1:1),epc(-1:1)
      character*512 slog


c     Begin to make polarization tensor
c     Normalize polarization vector
      x = sqrt (evec(1)**2 + evec(2)**2 + evec(3)**2)
      if (x .eq. 0.0) then
         call wlog(' STOP  Polarization vector of zero length')
         stop
      endif
      do 290  i = 1, 3
         evec(i) = evec(i) / x
  290 continue
      if (elpty .eq. 0.0) then
c        run linear polarization code
         do 291 i = 1, 3
            xivec(i) = 0.0
  291    continue
      endif
      x = sqrt (xivec(1)**2 + xivec(2)**2 + xivec(3)**2)
      if (x .gt. 0) then
c        run elliptical polarization code
         do 293  i = 1, 3
            xivec(i) = xivec(i) / x
  293    continue
         x = evec(1)*xivec(1)+evec(2)*xivec(2)+evec(3)*xivec(3)
         if (abs(x) .gt. 0.9) then
            call wlog(' polarization')
            write(slog,292)  (evec(i), i=1,3)
            call wlog(slog)
            call wlog(' incidence')
            write(slog,292) (xivec(i), i=1,3)
            call wlog(slog)
            call wlog(' dot product')
            write(slog,292)  x
            call wlog(slog)
  292       format (5x, 1p, 2e13.5)
            call wlog(' STOP polarization almost parallel' //
     1                ' to the incidence')
            stop
         endif
         if (x .ne. 0.0) then
c          if xivec not normal to evec then make in normal, keeping the
c          plane based on two vectors
           do 294 i = 1,3
              xivec(i) = xivec(i) - x*evec(i)
  294      continue
           x = sqrt (xivec(1)**2 + xivec(2)**2 + xivec(3)**2)
           do 295  i = 1, 3
              xivec(i) = xivec(i) / x
  295      continue
         endif
      else
         elpty = 0.0
      endif

      e2(1) = xivec(2)*evec(3)-xivec(3)*evec(2)
      e2(2) = xivec(3)*evec(1)-xivec(1)*evec(3)
      e2(3) = xivec(1)*evec(2)-xivec(2)*evec(1)
      do 296  i = 1,3
        e(i) = (evec(i)+elpty*e2(i)*coni)
  296 continue
      eps(-1) =  (e(1)-coni*e(2))/sqrt(2.0)
      eps(0)  =   e(3)
      eps(1)  = -(e(1)+coni*e(2))/sqrt(2.0)
      do 297  i = 1,3
        e(i) = (evec(i)-elpty*e2(i)*coni)
  297 continue
      epc(-1) =  (e(1)-coni*e(2))/sqrt(2.0)
      epc(0)  =   e(3)
      epc(1)  = -(e(1)+coni*e(2))/sqrt(2.0)
      do 298 i = -1,1
      do 298 j = -1,1
c        ptz(i,j) = ((-1.0)**i)*epc(-i)*eps(j)/(1+elpty**2) nonrel.
c        ptz(i,j) = ((-1.0)**j)*epc(-i)*eps(j)/(1+elpty**2) relativ.
c       above - true polarization tensor for given ellipticity,
c       below - average over left and right in order to have
c       path reversal simmetry
        ptz(i,j) = ((-1.0)**j)*(epc(-i)*eps(j)+eps(-i)*epc(j))
     1               /(1+elpty**2)/2.0
  298 continue
c     end of making polarization tensor

      return
      end
      subroutine mmtr( t3j, x3j, bmati)
c     calculates the part of matrix M which does not depend on energy
c     point.( see Rehr and Albers paper)

      implicit double precision (a-h, o-z)

c     all commons are inputs
c     inputs:
c        kap: quantum number kappa for initial orbital
c        t3j: appropriate table of the 3j symbols
c        x3j: appropriate table of the 3j symbols
c     Inputs from common:
c        rotation matrix for ilegp
c        path data, eta(ilegp) and ipot(ilegp)
c        mtot,l0
c     Output:  bmati(...)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola
c     include 'rotmat.h'
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle

      dimension t3j(-1:+1,0:1,-4:5), x3j(-1:1,-1:1,-4:5)
      complex*16 bmati,sum1,sum2
      dimension bmati(-mtot:mtot,-mtot:mtot,-1:1,-1:1)

      do 10 i = -1,1
      do 10 j = -1,1
      do 10 k = -mtot,mtot
      do 10 l = -mtot,mtot
         bmati(l,k,j,i)=0.0d0
  10  continue

c     linit is inintial orb. momentum.
      lx = min(mtot,ilinit)
      mf= abs(kinit)
      mi=-mf+1

      if (pola.eq.1) then

c     set indices for bmati (no indentation)
      do 60 mu1 = -lx,lx
      mu1d = mu1+mtot+1
      do 50 mu2 = -lx,lx
      mu2d = mu2+mtot+1
      do 40 kp = -1,1
      do 40 kpp= -1,1
         do 35 i = -1,1
         do 35 j = -1,1
            sum1 =0.0d0
            do 30 m = mi,mf
               mp = m - i
               mpp = m - j
               sum2 = 0.0d0
               do 25 ms = 0,1
                  m1 = mpp - ms
                  m2 = mp - ms
                  m1d = m1 + mtot+1
                  m2d = m2 + mtot+1
                if (abs(m1).gt.lkap(kpp).or.abs(m2).gt.lkap(kp)) goto 25
                  sum2 = sum2 + exp(-coni*(eta(nsc+2)*m2+eta(0)*m1)) *
     1           dri(ilk(kpp),mu1d,m1d,nsc+2)*dri(ilk(kp),m2d,mu2d,nleg)
     2            * t3j(kpp,ms,mpp) * t3j(kp,ms,mp)
  25           continue
               sum1 = sum1 + sum2 * x3j(kpp, j,mpp) * x3j(kp, i,mp)
  30        continue

            bmati(mu1,mu2,kp,kpp) =bmati(mu1,mu2,kp,kpp) + ptz(i,j)*sum1

c           dri(nsc+2)  is angle between z and leg1
c           dri(nsc+1)  is angle between last leg and z
c           eta(nsc+3)  is gamma between eps and rho1,
c           eta(nsc+2)  is alpha between last leg and eps
c           t3j(m0,i)    are 3j symbols multiplied by sqrt(3)
   35    continue

       bmati(mu1,mu2,kp,kpp)=bmati(mu1,mu2,kp,kpp)*exp(-coni*eta(1)*mu1)
     1                       * coni ** (lkap(kp) - lkap(kpp))
c      the last factor is from definitions of green's functions in
c      the Rehr-Albers paper and normalization of radial wave function

   40 continue
   50 continue
   60 continue

      elseif (pola.eq.2 .or. pola.eq.3) then
         do 70 k1=-1,1
         do 70 k2=-1,1
         mf = min(jkap(k1),jkap(k2))
         mi = -mf +1
         do 80 mp = mi,mf
           if (pola.eq.2) dum = t3j(k2,1,mp) * t3j(k1,1,mp)
           if (pola.eq.3) dum = t3j(k2,0,mp) * t3j(k1,0,mp)
           bmati(0,0,k1,k2) = bmati(0,0,k1,k2) + dum *
     1   ( x3j(k2,-1,mp) * x3j(k1,-1,mp) - x3j(k2,1,mp) * x3j(k1,1,mp) )
     2                       * coni ** (lkap(k1) - lkap(k2))
  80     continue
  70     continue
      endif

      return
      end
      subroutine mmtrxi ( rkk, lam1x, bmati, ie, ileg, ilegp)
c     calculates matrix M in Rehr,Albers paper.
c     in polarization case
      implicit double precision (a-h, o-z)

c     all commons except for /fmat/ are inputs

c     inputs:
c       lam1x:  limits on lambda and lambda'
c       ie:  energy grid points
c       ileg, ilegp: leg and leg'
c
c     Inputs from common:
c        phases, use ph(ie,...,ilegp), and lmax(ie,ilegp)
c        lambda arrays
c        rotation matrix for ilegp
c        clmz for ileg and ilegp
c        path data, eta(ilegp) and ipot(ilegp)
c        xnlm array
c
c     Output:  fmati(...,ilegp) in common /fmatrx/ is set for
c              current energy point.

c     calculate scattering amplitude matrices
c     f(lam,lam') = sum_l tl gam(l,m,n)dri(l,m,m',ileg)gamt(l,m',n')
c                 *cexp(-i*m*eta),  eta = gamma+alpha'
c     lam lt lam1x, lam' lt lam2x such that m(lam) lt l0, n(lam) lt l0
c     gam = (-)**m c_l,n+m*xnlm, gamt = (2l+1)*c_ln/xnlm,
c     gamtl = gamt*tl

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'nlm.h'
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c     include 'lambda.h'
      common /lambda/
     4   mlam(lamtot),
     5   nlam(lamtot),
     1   lamx,
     2   laml0x,
     3   mmaxp1, nmax
c     include 'clmz.h'
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola
c     include 'fmatrx.h'
      complex*16 fmati
      common /fmatrx/ fmati(lamtot,lamtot,legtot)
c     include 'rotmat.h'
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle

      complex*16 cam, camt, tltl,bmati
      dimension bmati(-mtot:mtot,-mtot:mtot,-1:1,-1:1)
      complex*16  rkk(nex,-1:1)
      complex*16 gam(ltot+1,mtot+1,ntot+1),
     1           gamtl(ltot+1,mtot+1,ntot+1)

c     calculate factors gam and gamtl

      iln = ilinit - 1
      ilx = ilinit + 1
      if (iln.eq.0) iln=ilx

      do 30  il = iln, ilx, 2
         tltl = 2*il - 1
         do 20  lam = 1, lam1x
            m = mlam(lam)
            if (m .lt. 0)  goto 20
            im = m+1
            if (im .gt. il)  goto 20
            in = nlam(lam) + 1
            imn = in + m
            if (lam .gt. lam1x)  goto 20
            cam = xnlm(il,im) * (-1)**m
            if (imn .le. il)  gam(il,im,in) = cam * clmi(il,imn,ileg)
            if (imn .gt. il)  gam(il,im,in) = 0
            camt = tltl / xnlm(il,im)
            gamtl(il,im,in) = camt * clmi(il,in,ilegp)
   20    continue
   30 continue

      do 60 lam1 = 1,lam1x
         m1 = mlam(lam1)
         in1 = nlam(lam1) + 1
         iam1 = abs(m1) + 1
         do 50  lam2 = 1, lam1x
            m2 = mlam(lam2)
            in2 = nlam(lam2) + 1
            iam2 = abs(m2) + 1
c           iam2 = iabs(m2) + 1
            imn1 = iam1 + in1 - 1
            fmati(lam1,lam2,ilegp) = 0.0d0
            if (pola.eq.1) then
               do 40 k1 = -1, 1
               do 40 k2 = -1, 1
                  if (ilk(k1).gt.0 .and. ilk(k2).gt.0
     1             .and. iam1.le.ilk(k2) .and. iam2.le.ilk(k1))
     1            fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp) -
     2            bmati(m1,m2,k1,k2) * rkk(ie,k1) * rkk(ie,k2) *
     3            gam( ilk(k2), iam1, in1) * gamtl( ilk(k1), iam2, in2)
   40          continue
            elseif (pola.eq.0 .or. pola.gt.3) then
               m1d = m1 + mtot + 1
               m2d = m2 + mtot + 1
c              for nonrelativistic test do 45 k1 =  1,1
               do 45 k1 =  -1, 1
                  if (ilk(k1).gt.0 .and. iam1.le.ilk(k1) .and.
     1             iam2.le.ilk(k1)) then
                  fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp) -
     2            rkk(ie,k1) * rkk(ie,k1) /3.0d0 / ( 2*ilk(k1) - 1 ) *
     3            gam( ilk(k1), iam1, in1) * gamtl( ilk(k1), iam2, in2)
     4            * dri( ilk(k1), m1d, m2d, ilegp)
                  endif
  45           continue
               fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp) *
     1         exp(-coni*eta(ileg)*m1)
            elseif (pola.eq.2 .or. pola.eq.3) then
              m1d = m1 + mtot + 1
              m2d = m2 + mtot + 1
              do 55 k1 = -1,1
                if (ilk(k1).gt.0 .and. iam1.le.ilk(k1).and.
     1          iam2.le.ilk(k1)) then
                  do 56 k2 = -1,1
c                 do 56 k2 = k1,k1
                    if (ilk(k1).eq.ilk(k2))
     1              fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp) -
     2              rkk(ie,k1) * rkk(ie,k2) / (2*ilk(k1) - 1) *
     3              gam( ilk(k1), iam1,in1) * gamtl( ilk(k1), iam2,in2)
     4              * dri( ilk(k1), m1d, m2d, ilegp) /3.0d0
     5              *3.0d0 * bmati(0,0,k1,k2)
  56              continue
                endif
  55          continue
              fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp)
     1        * exp(-coni*eta(ileg)*m1)
            endif
   50    continue
   60 continue

      return
      end
      subroutine mpprmd (npat, ipat, ri, beta, eta)
c     double precision version so angles come out right
c     for output...

c     Used with pathsd, a single precision code, so BE CAREFUL!!
c     No implicit, all variables declared explicitly.

c     make path parameters, ie, ri, beta, eta for each leg for a given
c     path.

c     Input is list of atoms (npat, ipat(npat)), output is
c     ri(npat+1), beta, eta.

      dimension ipat(npat)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

c     /atoms/ is single precision from pathsd
      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)

      complex*16  coni
      parameter (coni = (0,1))

      complex*16  alph(npatx+1), gamm(npatx+2), eieta
      double precision beta(npatx+1)
      double precision ri(npatx+1), eta(npatx+1)

      double precision x, y, z
      double precision ct, st, cp, sp, ctp, stp, cpp, spp
      double precision cppp, sppp

      n = npat + 1
      do 100  j = 1, n

c        get the atoms in this path
c        we actually have them already via the ipat array
c        remember that we'll want rat(,npat+1)=rat(,0) and
c                                 rat(,npat+2)=rat(,1) later on
c        make alpha, beta, and gamma for point i from 1 to N
c        NB: N is npat+1, since npat is number of bounces and N is
c            number of legs, or think of N=npat+1 as the central atom
c            that is the end of the path.
c
c        for euler angles at point i, need th and ph (theta and phi)
c        from rat(i+1)-rat(i)  and  thp and php
c        (theta prime and phi prime) from rat(i)-rat(i-1)
c
c        Actually, we need cos(th), sin(th), cos(phi), sin(phi) and
c        also for angles prime.  Call these  ct,  st,  cp,  sp   and
c                                            ctp, stp, cpp, spp.
c
c        We'll need angles from n-1 to n to 1,
c        so use rat(n+1) = rat(1), so we don't have to write code
c        later to handle these cases.

c        i = ipat(j)
c        ip1 = ipat(j+1)
c        im1 = ipat(j-1)
c        except for special cases...
         if (j .eq. n)  then
c           j central atom, j+1 first atom, j-1 last path atom
            i = 0
            ip1 = ipat(1)
            im1 = ipat(npat)
         elseif (j .eq. npat)  then
c           j last path atom, j+1 central, j-1 next-to last atom
c              unless only one atom, then j-1 central
            i = ipat(j)
            ip1 = 0
            if (npat .eq. 1)  then
               im1 = 0
            else
               im1 = ipat(npat-1)
            endif
         elseif (j .eq. 1)  then
c           j first atom, j+1 second unless only one,
c           then j+1 central, j-1 central
            i = ipat(j)
            if (npat .eq. 1)  then
               ip1 = 0
            else
               ip1 = ipat (j+1)
            endif
            im1 = 0
         else
            i = ipat(j)
            ip1 = ipat(j+1)
            im1 = ipat(j-1)
         endif

         x = rat(1,ip1) - rat(1,i)
         y = rat(2,ip1) - rat(2,i)
         z = rat(3,ip1) - rat(3,i)
         call strigd (x, y, z, ct, st, cp, sp)
         x = rat(1,i) - rat(1,im1)
         y = rat(2,i) - rat(2,im1)
         z = rat(3,i) - rat(3,im1)
         call strigd (x, y, z, ctp, stp, cpp, spp)

c        cppp = cos (phi prime - phi)
c        sppp = sin (phi prime - phi)
         cppp = cp*cpp + sp*spp
         sppp = spp*cp - cpp*sp

c        alph = exp**(i alpha)  in ref eqs 18
c        beta = cos(beta)
c        gamm = exp**(i gamma)
         alph(j) = st*ctp - ct*stp*cppp - coni*stp*sppp
         beta(j) = ct*ctp + st*stp*cppp
c        Watch out for roundoff errors
         if (beta(j) .lt. -1)  beta(j) = -1
         if (beta(j) .gt.  1)  beta(j) =  1
         gamm(j) = st*ctp*cppp - ct*stp + coni*st*sppp
         ri(j) = sdist (rat(1,i), rat(1,im1))
  100 continue

c     Make eta(i) = alpha(i) + gamma(i+1).  We only really need
c     exp(i*eta)=eieta, so that's what we'll calculate.
c     We'll need gamm(N+1)=gamm(npat+2)=gamm(1)
      gamm(npat+2) = gamm(1)
      do 150  j = 1, npat+1
         eieta = alph(j) * gamm(j+1)
         call sargd (eieta, eta(j))
  150 continue

c     Return beta as an angle, ie, acos(beta).  Check for beta >1 or
c     beta <1 (roundoff nasties)
      do 160  j = 1, npat+1
         if (beta(j) .gt.  1)  beta(j) =  1
         if (beta(j) .lt. -1)  beta(j) = -1
         beta(j) = acos(beta(j))
  160 continue

      return
      end
      subroutine strigd (x, y, z, ct, st, cp, sp)
      double precision x, y, z, ct, st, cp, sp, r, rxy
c     returns cos(theta), sin(theta), cos(phi), sin(ph) for (x,y,z)
c     convention - if x=y=0, phi=0, cp=1, sp=0
c                - if x=y=z=0, theta=0, ct=1, st=0
      parameter (eps = 1.0e-6)
      r = sqrt (x**2 + y**2 + z**2)
      rxy = sqrt (x**2 + y**2)
      if (r .lt. eps)  then
         ct = 1
         st = 0
      else
         ct = z/r
         st = rxy/r
      endif
      if (rxy .lt. eps)  then
         cp = 1
         sp = 0
      else
         cp = x / rxy
         sp = y / rxy
      endif

      return
      end
      subroutine sargd (c, th)

      double precision x, y, th
      complex*16  c
      parameter (eps = 1.0e-6)
      x = dble(c)
      y = dimag(c)
      if (abs(x) .lt. eps)  x = 0
      if (abs(y) .lt. eps)  y = 0
      if (abs(x) .lt. eps  .and.  abs(y) .lt. eps)  then
         th = 0
      else
         th = atan2 (y, x)
      endif
      return
      end
      subroutine mpprmp (npat, ipat, xp, yp, zp)

c     make path parameters,  xp, yp,zp for each atom for a given
c     path.

c     Input is list of atoms (npat, ipat(npat)), output are
c     x,y,z coord. of path in standard frame of reference
c     (see comments in timrep.f or here below)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola
      double precision  ro2, norm, zvec, xvec, yvec, ri, xp1, yp1, zp1
      dimension ipat(npatx+1), zvec(3), xvec(3), yvec(3)

      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)

      dimension xp(npatx), yp(npatx), zp(npatx)
      dimension xp1(npatx), yp1(npatx), zp1(npatx)
      dimension ri(3,npatx)

      parameter (eps4 = 1.0E-4)

c        get the atoms in this path
c        we actually have them already via the ipat array

c     initialize staff
      do 10 j = 1, npatx
         xp(j) = 0
         yp(j) = 0
         zp(j) = 0
         xp1(j) = 0
         yp1(j) = 0
         zp1(j) = 0
   10 continue
      nleg = npat + 1
      do 20  j = 1, npat
      do 20  i = 1, 3
         ri(i,j) = rat(i,ipat(j)) - rat(i,0)
   20 continue
      do 30  j = nleg, npatx
      do 30  i = 1, 3
         ri(i,j) = 0
   30 continue
      do 40 i =1, 3
         xvec(i) = 0.0
         yvec(i) = 0.0
         zvec(i) = 0.0
   40 continue

      if (pola.ne.1) then
c        z-axis along first leg
         norm = ri(1,1)*ri(1,1)+ri(2,1)*ri(2,1)+ri(3,1)*ri(3,1)
         norm = sqrt(norm)
         do 140 i = 1, 3
           zvec(i) = ri(i,1)/norm
  140    continue
      else
c        z-axis in direction of polarization
         do 120 i = 1, 3
           zvec(i) = evec(i)
  120    continue
      endif

      do 160 j = 1,npat
      do 160 i = 1, 3
        zp1(j) = zp1(j) + zvec(i)*ri(i,j)
  160 continue

      num = 1
      if (pola.ne.1) then
c        first nonzero z-coord. is already positive
         goto 240
      endif
  200 continue
      if (abs(zp1(num)) .gt. eps4) then
         if (zp1(num) .lt. 0.0) then
c           inverse all z-coordinates and zvec, if
c           first nonzero z-coordinate is negative
            do 210 j = 1, 3
               zvec(j) = - zvec(j)
  210       continue
            do 220 j = 1, npat
               zp1(j) = - zp1(j)
  220       continue
         endif
         goto 240
      endif
      num = num +1
      if (num .lt. nleg) then
         goto 200
      endif
c     here first nonzero z-coordinate is positive
  240 continue

      num = 1
  300 continue
      ro2 = 0.0
      do 310 i =1, 3
         ro2 = ro2 + ri(i,num)*ri(i,num)
  310 continue
c     looking for first atom which is not on z-axis
      ro2 = ro2 - zp1(num)*zp1(num)
      ro2 = sqrt(abs(ro2))
      if (ro2 .ge. eps4) then
c     if atom not on the z-axis then
         if (elpty .eq. 0.0) then
c           if not elliptical polarization then
c           choose x-axis so that x-coord. positive and y=0.
            do 320 i = 1, 3
               xvec(i) = ri(i,num) - zvec(i)*zp1(num)
  320       continue
            do 330 i = 1, 3
               xvec(i) = xvec(i)/ro2
  330       continue
         else
c           if elliptical polarization then
c           choose x-axis along incident beam
            do 350 i =1, 3
               xvec(i) = xivec(i)
  350       continue
         endif
         yvec(1) = zvec(2)*xvec(3) - zvec(3)*xvec(2)
         yvec(2) = zvec(3)*xvec(1) - zvec(1)*xvec(3)
         yvec(3) = zvec(1)*xvec(2) - zvec(2)*xvec(1)
         goto 390
      endif
      num = num + 1
      if (num .lt. nleg) then
         goto 300
      endif
  390 continue

c     calculate x,y coord for each atom in chosen frame of reference
      do 400 j = 1, npat
      do 400 i =1,3
         xp1(j) = xp1(j) + xvec(i)*ri(i,j)
         yp1(j) = yp1(j) + yvec(i)*ri(i,j)
  400 continue

      if ( elpty .ne. 0.0) then
c        if no polarization or linear polarization then first nonzero
c        x-coordinate is already positive, no need to check it.
         num = 1
  500    continue
         if (abs(xp1(num)) .ge. eps4) then
            if (xp1(num) .lt. 0.0) then
               do 510 j = 1, npat
                  xp1(j) = - xp1(j)
  510          continue
            endif
            goto 520
         endif
         num = num + 1
         if (num .lt. nleg) then
            goto 500
         endif
  520    continue
      endif

      num = 1
  570 continue
c     inverse all y-coordinates if first nonzero y-coord is negative
      if (abs(yp1(num)) .ge. eps4) then
         if (yp1(num) .lt. 0.0) then
            do 580 j = 1, npat
               yp1(j) = - yp1(j)
  580       continue
         endif
         goto 590
      endif
      num = num + 1
      if (num .lt. nleg) then
         goto 570
      endif
  590 continue

      do 595 j = 1, npat
        xp(j) = xp1(j)
        yp(j) = yp1(j)
        zp(j) = zp1(j)
  595 continue
c     now xp,yp,zp represent the path in standard order
      return
      end
      subroutine mrb (npat, ipat, ri, beta)

c     Make ri, beta and rpath path parameters for crit calculations.

c     Input is list of atoms (npat, ipat(npat)), output is
c     ri(npat+1), beta, eta.

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension ipat(npatx)

      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)

      dimension beta(npatx+1), ri(npatx+1), ipat0(npatx+1)

      nleg = npat+1
c     central atom is atom 0 in rat array
c     need local ipat0 array since we use ipat0(npat+1), final atom
c     in path (final atom is, of course, the central atom)
      do 10  i = 1, npat
         ipat0(i) = ipat(i)
   10 continue
      ipat0(nleg) = 0

      do 30  ileg = 1, nleg
c        make beta and ri for point i from 1 to N
c        NB: N is npat+1, since npat is number of bounces and N is
c            number of legs, or think of N=npat+1 as the central atom
c            that is the end of the path.
c
c        We'll need angles from n-1 to n to 1,
c        so use rat(n+1) = rat(1), so we don't have to write code
c        later to handle these cases.

c        Work with atom j
c        jp1 = (j+1)
c        jm1 = (j-1)
         j = ileg
         jm1 = j-1
         jp1 = j+1
c        Fix special cases (wrap around when j is near central atom,
c        also handle ss and triangular cases).
         if (jm1 .le.    0)  jm1 = nleg
         if (jp1 .gt. nleg)  jp1 = 1

         jat = ipat0(j)
         jm1at = ipat0(jm1)
         jp1at = ipat0(jp1)

         ri(ileg) = sdist (rat(1,jat), rat(1,jm1at))

c        Make cos(beta) from dot product
         call dotcos (rat(1,jm1at), rat(1,jat), rat(1,jp1at),
     1               beta(ileg))
   30 continue

      rpath = 0
      do 60  ileg = 1, nleg
         rpath = rpath + ri(ileg)
   60 continue

      return
      end
      subroutine dotcos (rm1, r, rp1, cosb)
      dimension rm1(3), r(3), rp1(3)

      parameter (eps = 1.0e-8)

      cosb = 0
      do 100  i = 1, 3
         cosb = cosb + (r(i)-rm1(i)) * (rp1(i)-r(i))
  100 continue

c     if denom is zero (and it may be if 2 atoms are in the same place,
c     which will happen when last path atom is central atom), set
c     cosb = 0, so it won't be undefined.

      denom = (sdist(r,rm1) * sdist(rp1,r))
      if (denom .gt. eps)  then
         cosb = cosb / denom
      else
         cosb = 0
      endif
      return
      end
      subroutine outcrt (npat, ipat, ckspc,
     1    nncrit, fbetac, xlamc, ne, ik0, cksp,
     1    fbeta, xlam, ipotnn, ipot,
     1    xport, xheap, xheapr,
     1    xout, xcalcx)

c     This make pw importance factor for pathsd, also recalculates
c     pathfinder criteria for output.  Pathfinder recalculation
c     is hacked from ccrit, so be sure to update this if ccrit
c     is changed.

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension ipat(npatx)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      dimension fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex)
      dimension xlamc(necrit), xlam(nex)

c     local variables
      dimension ri(npatx+1), beta(npatx+1), indbet(npatx+1)
      dimension xporti(nex)
      parameter (eps = 1.0e-6)

c     Space for variables for time reversed path (used in xheapr
c     calculation below)
      dimension ipat0(npatx)
      dimension ri0(npatx+1), indbe0(npatx+1)

c     mrb is 'efficient' way to get only ri and beta
c     note that beta is cos(beta)
      call mrb (npat, ipat, ri, beta)

c     Make index into fbeta array (this is nearest cos(beta) grid point,
c     code is a bit cute [sorry!], see prcrit for grid).
      do 290  i = 1, npat+1
         tmp = abs(beta(i))
         n = tmp / 0.025
         del = tmp - n*0.025
         if (del .gt. 0.0125)  n = n+1
         if (beta(i) .lt. 0)  n = -n
         indbet(i) = n
  290 continue

c     Make pw importance factor by integrating over all points
c     above the edge
c     Path importance factor is integral d|p| of
c        (product of f(beta)/rho for the scatterers) * cos(beta0)/rho0
c     Include mean free path factor, exp(-rtot/xlam)
      rtot = 0
      do 510  i = 1, npat+1
         rtot = rtot + ri(i)
  510 continue
      do 560  ie = ik0, ne
         rho = ri(npat+1) * cksp(ie)
         crit = max (abs(beta(npat+1)), 0.3) / rho
         do 520  iat = 1, npat
            rho = ri(iat) * cksp(ie)
            ipot0 = ipot(ipat(iat))
            crit = crit * fbeta(indbet(iat),ipot0,ie) / rho
  520    continue
         crit = crit * exp (-rtot/xlam(ie))
         xporti(ie) =  abs(crit)
  560 continue


c     integrate from ik0 to ne
      nmax = ne - ik0 + 1
      call strap (cksp(ik0), xporti(ik0), nmax, xport)

c     Stuff for  output.
c     Heap crit thing (see ccrit and mcrith for comments)
c     If a path got time reversed, its xheap may be smaller than
c     it was before it got time-reversed.  So calculate it both
c     ways.
c     xheap for path, xheapr for time-reversed path

      xheap  = -1
      xheapr = -1
      call mcrith (npat, ipat, ri, indbet,
     1             ipot, nncrit, fbetac, ckspc, xheap)

c     Prepare arrays for time reversed path and make xheapr
c     See timrev.f for details on indexing here.

      nleg = npat+1
c     ri
      do 200  i = 1, nleg
         ri0(i) = ri(nleg+1-i)
  200 continue
c     indbet  and ipat
      indbe0(nleg) = indbet(nleg)
      do 210  i = 1, nleg-1
         indbe0(i) = indbet(nleg-i)
         ipat0(i) = ipat(nleg-i)
  210 continue

      call mcrith (npat, ipat0, ri0, indbe0,
     1             ipot, nncrit, fbetac, ckspc, xheapr)

c     Keep crit thing (see mcritk for comments)
      call mcritk (npat, ipat, ri, beta, indbet,
     1             ipot, nncrit, fbetac, xlamc, ckspc, xout, xcalcx)

      return
      end
      subroutine ovrlp (iph, iphat, rat, iatph, ifrph, novr, iphovr,
     1                nnovr, rovr, iz, nat, rho, dmag, rhoval, vcoul,
     2                edens, edenvl, vclap, rnrm)

c     Overlaps coulomb potentials and electron densities for current
c     unique potential
      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola

      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)
      dimension ifrph(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)
      dimension iz(0:nfrx)
      dimension rho(251,0:nfrx), dmag(251,0:nfrx), rhoval(251,0:nfrx)
      dimension vcoul(251,0:nfrx)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension rnrm(0:nphx)

c     find out which free atom we're dealing with
      ifr = ifrph(iph)

c     start with free atom values for current atom
      do 100  i = 1, 250
         vclap(i,iph) = vcoul(i,ifr)
         edens(i,iph) = rho  (i,ifr)

c      for antiferromagnet fix later , too fragile here
c        -1 factor for opposite spin
c      iph=0,2 are parallel, iph=0,3 are antiparallel
c      iph=1 or iph>3 dmag=0.

         if (iph .eq. ifr) then
            dmag(i,iph) = (-1.0)**(pola) * dmag(i,ifr)
         else
c           dmag(i,iph) = - dmag(i,ifr)
            dmag(i,iph) =   dmag(i,ifr)
         endif
         if (iph.eq.1 .or. iph.gt.3) dmag(i,iph) = 0.0

c     for GdFeO
c        if (iph .eq. 0 .or. iph.eq. 1 .or. iph.eq.4) then
c           dmag(i,iph) = (-1.0)**(pola) * dmag(i,ifr)
c        elseif(iph.eq.2) then
c           dmag(i,iph) = - dmag(i,ifr)
c        endif
c        if (iph.eq.4) then
c           dmag(i,3) = 0.0
c        endif

c      for ferromagnet
c        dmag(i,iph) = dmag(i,ifr) * (-1.0)**(pola)

         if (pola .le. 1)  dmag(i,iph) = 0.0
         edenvl(i,iph) = rhoval  (i,ifr)
  100 continue

      if (novr(iph) .gt. 0)  then
         do 104  iovr = 1, novr(iph)
            rnn  = rovr(iovr,iph)
            ann  = nnovr(iovr,iph)
            infr = ifrph(iphovr(iovr,iph))
            call sumax (250, rnn, ann, vcoul(1,infr), vclap(1,iph))
            call sumax (250, rnn, ann, rho  (1,infr), edens(1,iph))
            call sumax (250, rnn, ann, rhoval(1,infr), edenvl(1,iph))
  104    continue
      else
c        Do overlapping from geometry with model atom iat
         iat = iatph(iph)

c        overlap with all atoms within r overlap max (rlapx)
c        12 au = 6.35 ang  This number pulled out of a hat...
         rlapx = 12
c        inat is Index of Neighboring ATom
         do 110  inat = 1, nat
c           don't overlap atom with itself
            if (inat .eq. iat)  goto 110

c           if neighbor is too far away, don't overlap it
            rnn = dist (rat(1,inat), rat(1,iat))
            if (rnn .gt. rlapx)  goto 110

            infr = ifrph(iphat(inat))
            call sumax (250, rnn, one, vcoul(1,infr), vclap(1,iph))
            call sumax (250, rnn, one, rho  (1,infr), edens(1,iph))
            call sumax (250, rnn, one, rhoval(1,infr), edenvl(1,iph))
  110       continue
      endif

c     set norman radius
      call frnrm (edens(1,iph), iz(ifr), rnrm(iph))

      return
      end
      subroutine paths (ckspc, fbetac, xlamc, pcritk, pcrith, nncrit,
     1                  rmax, nlegxx, ipotnn)

c     finds multiple scattering paths
c     This is single precision, units are Angstroms.  BE CAREFUL!

c     pcrith is cut-off fraction used when building paths
c            (path criterion for heap)
c     pcritk is cut-off fraction used on output
c            (path criterion for keeping)

c     ipotnn is output, used by pathsd to duplicate paths criteria,
c     which are used only for diagnostic output.

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

c     This common in pathsd, mpprm
      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)

      dimension m(-1:natx,0:natx)
      dimension mindex(natx+1)
c     Used for packed integers
      dimension iout(3)

c     ok true if all paths to rmax found.  If heap full, npx exceeded,
c     etc., last general shell may be incomplete, set ok=.false.
      logical ok
c     is label nfound, etc, written yet?
      logical wlabel

c     Heap data structure:
c     index is the pointer to the element of the data structure.
c     Each element contains
c        r        total path length
c                 Note that r is sorted along with index -- this keeps
c                 the heap maintenance routines fast.
c        mi, mj   m matrix elements used to place last atom in this path
c        npat     number of atoms in this path
c        ipat(npatx) indices of atoms in this path
c     next is the index of the next data structure element available.
c     If an element is freed, npat is the index of the free element
c     to use after using current "next" element.
c     nx is max number in heap
      integer    nx
c     parameter (nx = 10 000)
      parameter (nx = 60 000)
c     r also used in making m matrix, must have nx >= natx+1
      integer   index(nx), npx, np, n, ip, i
c     parameter (npx = 100 000)
      parameter (npx = 4000000)
      dimension r(nx), mi(nx), mj(nx)
      dimension npat(nx)
      dimension ipat (npatx,nx)
c     Keep this path on output
      logical keep1(nx), kp1tmp

c     Used with ipack, so need ipat(8)
      dimension ipat0(8)

c     paths are typically about 10 or 20 Ang
      parameter (big = 1.0e3)

      parameter (nheadx = 30)
      character*80  head(nheadx)
      character*80  title
      dimension lhead(nheadx)

c     Returned from criterion checker, false if path fails criterion
      logical keep

      character*512 slog

c     read input
c     header...
c     i, x, y, z, ipot, i1b   of nat+1 atoms (i=0 is central atom)
      open (1, file='geom.dat', status='old', iostat=ios)
      call chopen (ios, 'geom.dat', 'paths')
      nhead = nheadx
      call rdhead (1, nhead, head, lhead)
c     header from geom.dat includes carriage control...
c     nlegxx is max number of legs user wants to consider.
c     nlegs = npat+1, so set npatxx = min (npatx, nlegxx-1)
      npatxx = min (npatx, nlegxx-1)
c     Input rmax is one-way distances
      rmax = rmax*2
      nat = -1
c     ratx is distance to most distant atom, used to check rmax
      ratx = 0
   10 continue
         nat = nat+1
         if (nat .gt. natx)  then
            write(slog,12) ' nat, natx ', nat, natx
            call wlog(slog)
   12       format(a, 2i10)
            stop 'Bad input'
         endif
         read(1,*,end=20)  idum, (rat(j,nat),j=1,3), ipot(nat), i1b(nat)
         rtmp = sdist(rat(1,nat),rat(1,0))
         if (rtmp .gt. ratx)  ratx = rtmp
      goto 10
   20 continue
      nat = nat-1
      close (unit=1)

c     Warn user if rmax > dist to most distant atom
c     1.01 to avoid roundoff error, matches rdinp where rmax default set
      if (rmax/2 .gt. 1.01 * ratx)  then
         call wlog('   WARNING:  rmax > distance to most distant atom.')
         call wlog('             Some paths may be missing.')
         write(slog,22) rmax/2, ratx
         call wlog(slog)
   22    format('             rmax, ratx ', 1p, 2e13.5)
      endif

c     Count number of 1st bounce atoms (at least 1 required).
      n1b = 0
      do 30  i = 1, nat
         if (i1b(i) .gt. 0)  n1b = n1b + 1
   30 continue
      if (n1b .lt. 1) stop 'At least one 1st bounce atoms required.'

      if (rmax .ge. big)  stop 'Hey, get real with rmax!'

c     Make title for this run, include carriage control because head
c     (read above) includes carriage control.
      write(title,32)  rmax/2, pcritk, pcrith
   32 format(' Rmax', f8.4, ',  keep limit', f7.3,
     1       ', heap limit', f7.3)

      write(slog,34) rmax/2, pcritk, pcrith
      call wlog(slog)
   34 format ('    Rmax', f8.4,
     1        '  keep and heap limits', 2f12.7)

      call wlog('    Preparing neighbor table')

   36 format (1x, a)
c     prepare table telling distance from atom i to atom j and then
c     back to central atom
c     First bounce is m(-1,...), m(0,...) is bounces from central
c     atom that are not first bounces.
      do 60  i = -1, nat
         ir = i
         if (i .eq. -1)  ir = 0
         do 40  j = 0, nat
c           r begins with element 1 so sort routine later will work
            r(j+1) = sdist (rat(1,ir), rat(1,j))
            r(j+1) = r(j+1) + sdist (rat(1,j), rat(1,0))
c           we don't need m(i,i), since this will be = shortest
c           of the r(j), so just set it to something very big,
c           it will sort to the end of this row and it won't
c           bother us
            if (j .eq. ir)  r(j+1) = big
c           If we're doing first bounce, use only the allowed first
c           bounce paths.
            if (i .eq. -1)  then
               if (i1b(j) .le. 0)  r(j+1) = big
            endif
   40    continue

c        prepare row i of m table
c        m is a distance table ordered such that distance from
c               i to m(i,0) to 0 <
c               i to m(i,1) to 0 <
c               i    m(i,2)    0 <
c               :    :    :
c               i    m(i,nat)  0
c
c        That is, m(i,0) is index of atom that gives shortest path,
c                 m(i,1)                        next shortest path, etc.
c        Note that m(0,0) is shortest single bounce path.

c        Again, r and mindex go from 1 to nat+1, m goes from 0 to nat
         call sortir (nat+1, mindex, r)
         do 50  j = 0, nat
            m(i,j) = mindex(j+1)-1
   50    continue
   60 continue

c     label for nfound, heap size, etc written?
      wlabel = .false.
c     initialize heap data space "next" pointers
      do 70  i = 1, nx-1
         npat(i) = i+1
   70 continue
      npat(nx) = -1
c     initial condition:  make the first path
c     n    number in heap
c     nna  number skipped counter
c     nhx  number used in heap max, a counter
      n = 1
      nna = 0
      nhx = n
      nwrote = 0
      index(n) = 1
      ip = index(n)
      next = 2
      mi(ip) = -1
      mj(ip) = 0
      npat(ip) = 1
      ipat(npat(ip),1) = m(mi(ip),mj(ip))

c     near neighbor is atom ipat(npat(ip),1) for first path into heap
      ipotnn = ipot(ipat(npat(ip),1))

c     Someday change keep and keep1 to lkeep and lheap to match
c     ccrit variable names.
c     Initialize keep criterion
      xcalcx = -1
      call ccrit (npat(ip), ipat(1,ip), ckspc,
     1    fbetac, xlamc, rmax, pcrith, pcritk, nncrit, ipotnn, ipot,
     2    r(n), keep, keep1(ip), xcalcx)

      open (file='paths.bin', unit=3, access='sequential',
     1      form='unformatted', status='unknown', iostat=ios)
      call chopen (ios, 'paths.bin', 'paths')
c     These strings are all char*80 and include carriage control
      write(3) nhead+1
      do 88  ihead = 1, nhead
         write(3) head(ihead)
         write(3) lhead(ihead)
   88 continue
      write(3) title
      write(3) istrln(title)
      write(3)  nat
      do 90  i = 0, nat
         write(3) (rat(j,i),j=1,3), ipot(i), i1b(i)
   90 continue

c     r is the heap, index is the pointer to the rest of the data
c     np is the number of paths found and saved
      np = 0
c     nbx  mpat max (Number of Bounces maX)
      nbx = 0

c     done if path at top of heap is longer than longest path we're
c        interested in
c     done if max number of paths we want have been found
c     begin 'while not done' loop
      ok = .false.
  800 continue
         if (r(1) .gt. rmax  .or.  np .ge. npx .or. n.le.0)  then
c           n=0 means heap is empty
            if (n.le.0)  ok=.true.
            goto 2000
         endif

c        save element at top of heap in arrays labeled 0
c        dump to unit 3 (unformatted)
         ip = index(1)
         npat0 = npat(ip)
         do 100  i = 1, npat0
            ipat0(i) = ipat(i,ip)
  100    continue
         r0 = r(1)

c        Don't write out path if last atom is central atom, or
c        if it doesn't meet pcritk
         if (ipat0(npat0).ne.0 .and. keep1(ip))  then
            np = np+1
c           pack integers
            call ipack (iout, npat0, ipat0)
            write(3)  r0, iout
            nwrote = nwrote+1
c           write status report to screen
            if (mod(np,1000) .eq. 0)  then
               if (.not. wlabel)  then
                  call wlog('    nfound  heapsize  maxheap' //
     1               '  maxscatt   reff')
                  wlabel = .true.
               endif
               write(slog,132) np, n, nhx, nbx, r0/2
               call wlog(slog)
  132          format (4x, i6, i9, i9, i7, f12.4)
            endif
         endif

         if (np .ge. npx)  then
            write(slog,134) np
            call wlog(slog)
  134       format(i15, ' paths found.  (np .ge. npx)')
            goto 2000
         endif

c        Make new path by replacing last atom in path from top of heap,
c        put this path on top of heap and buble it down.  If row is
c        finished, or new path is too long, don't add it, instead
c        move last path in heap to the top.
c        If working on row mi=-1 (first bounce atoms), don't
c        use them if not allowed 1st bounce atoms.
         mj(ip) = mj(ip) + 1
         if (mi(ip).eq.-1  .and.  i1b(m(mi(ip),mj(ip))).le.0)  then
c           not allowed first bounce atom
            r(1) = big
            keep = .false.
c           type*, '1st bounce limit!'
         elseif (mj(ip) .ge. nat)  then
c           we've finished a row of m matrix
            r(1) = big
            keep = .false.
         else
c           new path has same indices, etc.  Only need to replace
c           last atom.
            ipat(npat(ip),ip) = m(mi(ip),mj(ip))
            call ccrit (npat(ip), ipat(1,ip), ckspc,
     1                  fbetac, xlamc, rmax, pcrith, pcritk, nncrit,
     1                  ipotnn, ipot,
     2                  r(1), keep, keep1(ip), xcalcx)
         endif

c        If r is bigger than rmax or keep=false, remove element from
c        heap by taking the last element in the heap and moving it to
c        the top.  Then bubble it down.  When removing an element
c        from the heap, be sure to save the newly freed up index.
c        r(1) and index(1) are new path, set above
         if (r(1).gt.rmax .and. keep)  then
            call wlog(' odd case rmax...')
         endif
         if (r(1).gt.rmax .or. .not.keep)  then
            index(1) = index(n)
            r(1) = r(n)
c           use npat as pointer to next free location
            npat(ip) = next
            next = ip
            n = n-1
c           nna is Number Not Added to heap
            nna = nna + 1
c           Maybe heap may be empty here, but that's alright
         endif
         if (npat(index(1)).gt.nbx .and. n.gt.0)  nbx = npat(index(1))

c        If heap is empty, don't call hdown.
         if (n.gt.0)  call hdown (r, index, n)

c        and make a new path by adding an atom onto the end of the path
c        we saved, put this at the end of the heap and bubble it up.
c        Do this only if it won't be too many bounces.
         if (npat0+1 .le. npatxx)  then
            ip = next
            if (ip .lt. 0)  then
c              call wlog('   Heap full')
               goto 2000
            endif
            next0 = npat(ip)
            do 200  i = 1, npat0
               ipat(i,ip) = ipat0(i)
  200       continue
            mi(ip) = ipat0(npat0)
            mj(ip) = 0
            npat(ip) = npat0+1
            ipat(npat(ip),ip) = m(mi(ip),mj(ip))
            call ccrit (npat(ip), ipat(1,ip), ckspc,
     1                  fbetac, xlamc, rmax, pcrith, pcritk, nncrit,
     1                  ipotnn, ipot,
     2                  rtmp, keep, kp1tmp, xcalcx)
            if (rtmp .gt. rmax  .and.  keep)  then
               call wlog(' odd case rmax and tmp...')
            endif
            if (rtmp .gt. rmax  .or.  .not.keep)  then
               npat(ip) = next0
               nna = nna+1
            else
c              add it to the heap
               next = next0
               n = n+1
               if (n .gt. nhx)  nhx = n
               index(n) = ip
               r(n) = rtmp
               keep1(ip) = kp1tmp
               if (npat(index(n)) .gt. nbx)  nbx = npat(index(n))
               call hup (r, index, n)
            endif
         endif

      goto 800
 2000 continue
c     end of 'while not done' loop
      if (.not. ok)  then
         call wlog('   Internal path finder limit exceeded -- ' //
     1             'path list may be incomplete.')
      endif
      close (unit=3)
      write(slog,2010) np, nhx, nbx
      call wlog(slog)
 2010 format ('    Paths found', i9, 3x,
     1        '(maxheap, maxscatt', i8, i4, ')')

      end
      subroutine pathsd (ckspc, fbetac, xlamc, ne, ik0, cksp,
     1                   fbeta, xlam,
     1                   critpw, ipotnn, ipr2,
     1                   pcritk, pcrith, nncrit, potlbl)

c     New degeneracy checker, cute and hopefully fast for large
c     problems

c     pcritk and pcrith used only for analysis after outcrt

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola
      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)

c     np1x  number of paths to consider at 1 time
c     parameter (np1x = 12 000)
      parameter (np1x = 60 000)
      dimension iout(3,np1x), iout0(3)

      dimension index(np1x)
      double precision dhash(np1x), dcurr, ddum
      dimension rx(npatx), ry(npatx), rz(npatx), ipat(npatx+1)
      dimension rx0(npatx), ry0(npatx), rz0(npatx), ipat0(npatx+1)
      double precision rid(npatx+1), betad(npatx+1), etad(npatx+1)

      parameter (nheadx = 40)
      character*80 head(nheadx)
      dimension lhead(nheadx)

      character*6  potlbl(0:npotx)

c     eps5 for rtotal range, eps3 for individual leg parameters.
c     eps3 large since code single precision and don't want round-off
c     error to reduce degeneracy.
      parameter (eps5 = 2.0e-5)
      parameter (eps3 = 1.0e-3)

      logical ldiff, last
      parameter (necrit=9, nbeta=40)
      real fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      real fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex)
      real xlamc(necrit), xlam(nex)

      character*512 slog

      write(slog,30) critpw
      call wlog(slog)
   30 format ('    Plane wave chi amplitude filter', f7.2, '%')

c     Read atoms info
      open (file='paths.bin', unit=3, access='sequential',
     1      form='unformatted', status='old', iostat=ios)
      call chopen (ios, 'paths.bin', 'pathsd')
      read(3) nhead
      do 40  ihead = 1, nhead
         read(3)  head(ihead)
         read(3)  lhead(ihead)
   40 continue
c     Header lines above include carriage control
      read(3)  nat
      do 50  i = 0, nat
         read(3) (rat(j,i),j=1,3), ipot(i), i1b(i)
   50 continue

c     Initialize stuff...
c     nptot  number of total paths, incl all degeneracies
c     nuptot number of unique paths for which must calc xafs
c     ngs    number of generalized shells (unique distances)
      nptot = 0
      nuptot = 0
      ngs = 0
      xportx = eps5
      ndegx = 1
      c0lim = 1.0e10
      c1lim = 1.0e10
c     Initialize keep criterion
      xcalcx = -1

c     write output to paths.dat
      if (ipr2 .ne. 5)  then
         open (unit=1, file='paths.dat', status='unknown', iostat=ios)
         call chopen (ios, 'paths.dat', 'pathsd')
         do 60  ihead = 1, nhead
            write(1,58)  head(ihead)(1:lhead(ihead))
   58       format(a)
   60    continue
         write(1,61)  critpw
   61    format (' Plane wave chi amplitude filter', f7.2, '%')
         write(1,62)
   62    format (1x, 71('-'))
      endif

c     Write crit.dat (criteria information)
      if (ipr2 .ge. 1)  then
         open (unit=4, file='crit.dat', status='unknown', iostat=ios)
         call chopen (ios, 'crit.dat', 'pathsd')
         do 65  ihead = 1, nhead
            write(4,58)  head(ihead)(1:lhead(ihead))
   65    continue
         write(4,61)  critpw
         write(4,62)
         write(4,80)
   80    format (' ipath nleg ndeg     r       pwcrit    ',
     1           'xkeep   accuracy   xheap    accuracy')
      endif

c     Read path data for each total path length range

c     Prepare for first path.
      read(3,end=999)  r0, iout0

c     Begin next total path length range
      last = .false.
  100 continue
      ngs = ngs+1
      rcurr = r0
      np = 1
      do 110  i = 1,3
         iout(i,np) = iout0(i)
  110 continue
  120 read(3,end=140)  r0, iout0
         if (abs(r0-rcurr) .lt. eps3)  then
            np = np+1
            if (np .gt. np1x) then
               write(slog,122) ' np, np1x ', np, np1x
               call wlog(slog)
  122          format (a, 2i15)
               stop 'np > np1x'
            endif
            do 130  i = 1, 3
               iout(i,np) = iout0(i)
  130       continue
         else
c           r0 is the rtot for the next set
c           iout0 is the packed atom list for the first path of the
c           next set
            goto 200
         endif
      goto 120
  140 continue
c     Get here only if end-of-file during read
      last = .true.

  200 continue

      nupr = 0
c     variable nuprtt was nuprtot, changed to be six chars, SIZ 12/93
      nuprtt = 0

c     Hash each path into an integer
      iscale = 1000
      do 230  ip = 1, np

         npat = npatx
         call upack (iout(1,ip), npat, ipat)

c        Get hash key for this path.
c        If two paths are the same, except time-reversed, the xafs
c        will be the same, so check for this type of degeneracy.
c        We do this by choosing a 'standard order' for a path --
c        if it's the other-way-around, we time-reverse here.
         call timrep (npat, ipat, rx, ry, rz, dhash(ip))

  230 continue

c     Do a heap sort on these things
      call sortid (np, index, dhash)

c     Find beginning and end of range with same hash key
c     i0 is beginning of hash range, i1 is end of the range

      i0 = 1
  300 continue
         i1 = np + 1
         dcurr = dhash(index(i0))
         do 310  ip = i0+1, np
            if (dhash(index(ip)) .ne. dcurr)  then
c              end of a hash range
               i1 = ip
               goto 311
            endif
  310    continue
  311    continue
         i1 = i1-1

c        At this point, i0 is the first path and i1 the last
c        of a hash range.  Do whatever you want with them!

c        Sum degeneracy, including degeneracy from 1st bounce atom.
c        Check this range to see if all of the paths are actually
c        degenerate.  Make sure time-ordering is standard.
         npat0 = npatx
         call upack (iout(1,index(i0)), npat0, ipat0)
         call timrep (npat0, ipat0, rx0, ry0, rz0, ddum)

         ndeg = 0
         do 430  ii = i0, i1
            npat = npatx
            call upack (iout(1,index(ii)), npat, ipat)
c           Note that if path gets time-reversed, we lose 1st bounce
c           flag (since first atom is now last...), so save path deg
            ndpath = i1b(ipat(1))
            call timrep (npat, ipat, rx, ry, rz, ddum)
c           Sum degeneracy here.
            ndeg = ndeg + ndpath
c           Check for hash collisons begins here.
            ldiff = .false.
            if (npat .ne. npat0)  then
               ldiff = .true.
               goto 430
            endif
            do 320  iat = 1, npat
               if (ipot(ipat(iat)) .ne. ipot(ipat0(iat)))  then
                  ldiff = .true.
                  goto 400
               endif
  320       continue
            do 330  ileg = 1, npat
               if (abs(rx(ileg)-rx0(ileg)) .gt. eps3  .or.
     1             abs(ry(ileg)-ry0(ileg)) .gt. eps3  .or.
     2             abs(rz(ileg)-rz0(ileg)) .gt. eps3)  then
                  ldiff = .true.
                  goto 400
               endif
  330       continue
  400       continue
            if (ldiff)  then
               call wlog(' WARNING!!  Two non-degenerate paths,' //
     1                   ' hashed to the same hash key!!')
  402          format (1x, 2e28.20)
               write(slog,402) dhash(index(i0)), dhash(index(ii))
               call wlog(slog)
  404          format (1x, 2i10, a)
               write(slog,404) npat0, npat, '  npat0, npat'
               call wlog(slog)
               call wlog(' iat, ipot0, ipot, ipat0, ipat')
               do 410  iat = 1, npat
  406             format (5i10)
                  write(slog,406) iat, ipot(ipat0(iat)),
     1               ipot(ipat(iat)), ipat0(iat), ipat(iat)
                  call wlog(slog)
  410          continue
               call wlog(' ileg, rx0,ry0,rz0,  rx1,ry1,rz1')
               do 420  ileg = 1, npat
  412             format(i6, 1p, 3e18.10)
                  write(slog,412) ileg, rx0(ileg), rx(ileg)
                  call wlog(slog)
                  write(slog,412) ileg, ry0(ileg), ry(ileg)
                  call wlog(slog)
                  write(slog,412) ileg, rz0(ileg), rz(ileg)
                  call wlog(slog)
  420          continue
               stop 'hash error'
            endif
  430    continue

c        Find path pw importance factors, and recalculate
c        pathfinder crits for output
         call outcrt (npat0, ipat0, ckspc,
     1                nncrit, fbetac, xlamc, ne, ik0, cksp,
     1                fbeta, xlam,
     1                ipotnn, ipot,
     1                xport, xheap, xheapr, xkeep, xcalcx)

         if (xport*ndeg .gt. xportx*ndegx)  then
            xportx = xport
c           ndegx is degeneracy of path that makes xportx, used for
c           testing new path keep crit
            ndegx = ndeg
         endif
c        frac is fraction of max importance to use for test
         frac = 100*ndeg*xport/(ndegx*xportx)

c        Write output if path is important enough (ie, path is
c        at least critpw % important as most important path found
c        so far.)
         if (frac .ge. critpw)  then
            nupr = nupr+1
            nuprtt = nuprtt+ndeg
            nptot = nptot + ndeg
            nuptot = nuptot + 1

c           Write path info to paths.dat
c           mpprmd is double precision, used to get angles
c           180.000 instead of 179.983, etc.
            call mpprmd (npat0, ipat0, rid, betad, etad)
c           skip paths.dat if not necessary
            if (ipr2 .eq. 5)  goto 576
            write(1,500) nuptot, npat0+1, real(ndeg),
     1              rcurr/2
  500       format (1x, 2i5, f8.3,
     1             '  index, nleg, degeneracy, r=', f8.4)
            write(1,502)
  502       format ('      x           y           z     ipot  ',
     1              'label      rleg      beta        eta')
            do 510  i = 1, npat0
               iat = ipat0(i)
               write(1,506)  rat(1,iat), rat(2,iat),
     1                  rat(3,iat), ipot(iat), potlbl(ipot(iat)),
     1                  rid(i), betad(i)*raddeg, etad(i)*raddeg
  506          format (3f12.6, i4, 1x, '''', a6, '''', 1x, 3f10.4)
  510       continue
            write(1,506)  rat(1,0), rat(2,0), rat(3,0), ipot(0),
     1         potlbl(ipot(0)),
     1         rid(npat0+1), betad(npat0+1)*raddeg, etad(npat0+1)*raddeg
c           End of paths.dat writing for this path

c           Write to crit.dat here (unit 4, opened above)
  576       continue

c           cmpk is degeneracy corrected xkeep, should equal frac
            cmpk = xkeep*ndeg/ndegx
c           cmpk is accuracy of xkeep, 100 is perfect
            cmpk = 100 - 100*(abs(frac-cmpk)/frac)

c           cmph is same thing for xheap
            if (xheap .lt. 0)  then
               cmph = 100
            else
               cmph = xheap*ndeg/ndegx
               cmph = 100 - 100*(abs(frac-cmph)/frac)
            endif

            if (ipr2 .ge. 1)  then
               write(4,560)  nuptot, npat0+1, ndeg, rcurr/2, frac,
     1             xkeep, cmpk, xheap, cmph
  560          format (i6, i4, i6, 3f10.4, f8.2, f10.4, 1pe14.3)
            endif

c           write out fraction error between xkeep and critpw
         endif

c        And do next ihash range
         i0 = i1+1
      if (i0 .le. np)  goto 300

c     type600,  ngs, rcurr, nupr
  600 format (1x, i5, f12.6, i7, ' igs, rcurr, nupr')
c     write(80,601)  ngs, rcurr/2, nupr, nuprtt
  601 format (1x, i8, f12.6, 2i9)

      if (.not. last) goto 100

      if (ipr2 .ne. 5)  close (unit=1)
c     delete paths.bin when done...
      close (unit=3, status='delete')
      close (unit=4)

      write(slog,620) nuptot, nptot
      call wlog(slog)
  620 format ('    Unique paths', i7, ',  total paths', i8)

c     Do not let user accidently fill up their disk
      if (nuptot .gt. 1200)  then
      call wlog(' You have found more than 1200 paths.  Genfmt')
      call wlog(' could require a lot of time and more than 6 meg of')
      call wlog(' storage.  Suggest a larger critpw to reduce number')
      call wlog(' of paths.  To continue this calculation, restart')
      call wlog(' with current paths.dat and module genfmt (3rd module')
      call wlog(' on CONTROL card).')
      stop 'User must verify very large run.'
      endif
      return
  999 stop 'no input'
      end
c     Periodic table of the elements
c     Written by Steven Zabinsky, Feb 1992.  Deo Soli Gloria

c     atwts(iz)  single precision fn, returns atomic weight
c     atwtd(iz)  double precision fn, returns atomic weight
c     atsym(iz)  character*2 fn, returns atomic symbol

      double precision function atwtd (iz)
      double precision weight
      common /atwtco/ weight(103)
      atwtd = weight(iz)
      return
      end

      real function atwts (iz)
      double precision weight
      common /atwtco/ weight(103)
      atwts = weight(iz)
      return
      end

      character*2 function atsym (iz)
      character*2 sym
      common /atsyco/ sym(103)
      atsym = sym(iz)
      return
      end

      block data prtbbd
c     PeRiodic TaBle Block Data

c     Atomic weights from inside front cover of Ashcroft and Mermin.

      double precision weight
      common /atwtco/ weight(103)

      character*2 sym
      common /atsyco/ sym(103)

      data weight /
     1   1.0079, 4.0026, 6.941,  9.0122, 10.81,   12.01,
     2   14.007, 15.999, 18.998, 20.18,  22.9898, 24.305,
     3   26.982, 28.086, 30.974, 32.064, 35.453,  39.948,
     4   39.09,  40.08,  44.956, 47.90,  50.942,  52.00,
     5   54.938, 55.85,  58.93,  58.71,  63.55,   65.38,
     6   69.72,  72.59,  74.922, 78.96,  79.91,   83.80,
     7   85.47,  87.62,  88.91,  91.22,  92.91,   95.94,
     8   98.91,  101.07, 102.90, 106.40, 107.87,  112.40,
     9   114.82, 118.69, 121.75, 127.60, 126.90,  131.30,
     x   132.91, 137.34, 138.91, 140.12, 140.91,  144.24,
     1   145,    150.35, 151.96, 157.25, 158.92,  162.50,
     2   164.93, 167.26, 168.93, 173.04, 174.97,  178.49,
     3   180.95, 183.85, 186.2,  190.20, 192.22,  195.09,
     4   196.97, 200.59, 204.37, 207.19, 208.98,  210,
     5   210,    222,    223,    226,    227,     232.04,
     6   231,    238.03, 237.05, 244,    243,     247,
     7   247,    251,    254,    257,    256,     254,
     8   257/

      data sym /  'H', 'He','Li','Be','B', 'C', 'N', 'O', 'F', 'Ne',
     1            'Na','Mg','Al','Si','P', 'S', 'Cl','Ar','K', 'Ca',
     2            'Sc','Ti','V', 'Cr','Mn','Fe','Co','Ni','Cu','Zn',
     3            'Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y', 'Zr',
     4            'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn',
     5            'Sb','Te','I', 'Xe','Cs','Ba','La','Ce','Pr','Nd',
     6            'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb',
     7            'Lu','Hf','Ta','W', 'Te','Os','Ir','Pt','Au','Hg',
     8            'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th',
     9            'Pa','U', 'Np','Pu','Am','Cm','Bk','Cf','Es','Fm',
     x            'Md','No','Lw'/

      end
       subroutine phase (iph, dx, x0, ri, ne, em, edge,
     1                  ixc, lreal, rmt, rcore, xmu, xmuval,
     2                  vi0, rs0, gamach,
     2                  vtot, vvalgs, edens, dmag, edenvl,
     3                  dgcn, dpcn, adgc, adpc, eref, ph, lmax,
     2                  methfs, iz, ihole, xion, sigmd, pgrid)

      implicit double precision (a-h, o-z)

c     INPUT
c     iph          unique pot index (used for messages only)
c     dx, x0, ri(nr)
c                  Loucks r-grid, ri=exp((i-1)*dx-x0)
c     ne, em(ne)   number of energy points, real energy grid
c     edge         energy for k=0 (note, edge=xmu-vr0)
c     ixc        0  Hedin-Lunqist + const real & imag part
c                  1  Dirac-Hara + const real & imag part
c                  2  ground state + const real & imag part
c                  3  Dirac-Hara + HL imag part + const real & imag part
c                  4, 5, 6, see rdinp or xcpot
c     lreal        logical, true for real phase shifts only
c     rmt          r muffin tin
c     xmu          fermi level
c     vi0          const imag part to add to complex potential
c     rs0          user input density cutoff, used only with ixc=4
c     gamach       core hole lifetime
c     vtot(nr)     total potential, including gsxc
c     vvalgs(nr)   overlap Coulomb+gsxc potential for valence electrons
c     edens(nr)    density
c     dmag(nr)     density magnetization
c     edenvl(nr)  valence charge density
c     dgcn(dpcn)   large (small) dirac components for 'iph' atom
c     adgc(adpc)   their development coefficients
c
c     OUTPUT
c     eref(ne)     complex energy reference including energy dep xc
c     ph(nex,ltot+1) complex scattering phase shifts
c     lmax         max l (lmax = kmax*rmt)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     testing
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     parameter (bohr = 0.529 177 249, ryd  = 13.605 698 )
      parameter ( harryd = 2.0d0 )

      dimension  ri(nrptx), em(nex), vtot(nrptx), edens(nrptx)
      dimension  dmag(nrptx), vvalgs(nrptx), edenvl(nrptx)
      dimension  sigmd(51), pgrid(51)
      dimension  adgc(10,30,0:nfrx), adpc(10,30,0:nfrx)
      dimension  dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16  eref(nex), erefvl(nex)
      complex*16  ph(nex,ltot+1)
      logical lreal

c     work space for xcpot
      dimension   vxcrmu(nrptx), vxcimu(nrptx), gsrel(nrptx)
      dimension   vvxcrm(nrptx), vvxcim(nrptx)
c     p and q were needed in xsect to calc. matrix elements.
      complex*16 p(nrptx), q(nrptx)

      complex*16  p2, p2val, xkmt, temp, dny, pu, qu
      complex*16 jl(ltot+2), nl(ltot+2)
      complex*16 v(nrptx), vval(nrptx)
c     character*512 slog

c     zero phase shifts (some may not be set below)
      do 100  ie = 1, ne
         do 90  il = 1, ltot+1
            ph(ie,il) = 0
   90    continue
  100 continue

c     limit l, lmax = kmax * rmt
c     lmax = rmt * sqrt(em(ne)-edge)
c     Use kmax = 20 so we get enough l-points even if kmax is small
      lmax = rmt * (20 * bohr)
      lmax = min (lmax, ltot)
c     set imt and jri (use general Loucks grid)
c     rmt is between imt and jri (see function ii(r) in file xx.f)
      imt = (log(rmt) + x0) / dx  +  1
      jri = imt+1
      jri1 = jri+1
      if (jri1 .gt. nrptx)  stop 'jri .gt. nrptx in phase'

      ifirst = 0
c     jcore = jri
c     if (mod(ixc,10) .eq. 5) then
c        if (rcore .gt. 1.5*rmt) rcore = 1.5*rmt
c        if (rcore. gt. rmt) jcore= (log(rcore)+x0) / dx  +  2
c     endif

c     calculate phase shifts
      do 220 ie = 1, ne
c        print*,ie

         call xcpot (iph, ie, ixc, lreal, ifirst, jri,
     1               em(ie), xmu, xmuval, vi0, rs0, gamach,
     2               vtot, vvalgs, edens, dmag, edenvl, sigmd, pgrid,
     3               eref(ie), erefvl(ie), v, vval, emp,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim)

c        set the method to calculate phase shifts
c        p2 is (complex momentum)**2 referenced to energy dep xc
         if (methfs.ne.1) then
c           notice that constant Im part (gamach/2+vi0) is cancelled,
c           since it is also present in v and vval.
            p2 = emp - eref(ie)
         else
c        real phases; convolute later with xloss= -Im\sigma+gamach/2+vi0
            p2 = emp - dble(eref(ie))
            do 101  i = 1, jri1
  101       v(i) = dble(v(i))
         endif
         if (mod(ixc,10) .lt. 5) then
            if (methfs .ne. 2) then
c              xkmt = rmt * sqrt (p2)
               xkmt = rmt * sqrt (p2+ (p2/clight)**2)
            else
               xkmt = rmt * sqrt (p2 + (0.0,1.0) * dimag (eref(1)) )
            endif
         else
c           p2val is for core-valence model. It has the same real part
c           as p2 by construction in xcpot.
            if (methfs.ne.1) then
               p2val = em(ie) - erefvl(ie)
            else
               p2val = em(ie) - dble(erefvl(ie))
               do 105  i = 1, jri1
  105          vval(i) = dble(vval(i))
            endif

c        testing
c         itest =1
c         if (itest.eq.1) p2val=p2

            if (methfs .ne. 2) then
c              xkmt = rmt * sqrt (p2val)
c            testing
               xkmt = rmt * sqrt (p2val + (p2val/clight)**2 )
            else
               xkmt = rmt * sqrt (p2val+(0.0,1.0)*dimag(erefvl(1)))
            endif
         endif

         call besjn (xkmt, jl, nl)

         if (mod(ixc,10) .lt. 5) then
             ncycle = 0
             p2val = p2
         else
             ncycle = 2
         endif

c        need hartree units for dfovrg
         do 125 i =1, jri1
            v(i) = v(i)/harryd
            vval(i) = vval(i)/harryd
  125    continue
         p2 = p2/harryd
         p2val = p2val/harryd

         do 210  il = 1, lmax+1
            l = il - 1
c           nonlocal exchange is unstable for high il.
c           need to do integrals instead of diff. eq. fix later
c           use local xc for high il
            if (il*dx.gt.0.50) then
               ncycle=0
c              p2val = p2
            endif

c  v should be V_N+V_COUL+V_XCtotal-V_mt, vval= V_N+V_COUL+V_XCVAL-V_mt
            ikap=-il
c           if ( il.ne.1 ) ikap=il-1
            irr = -1
            ic3 = 1
c           never use irr=0, only positive or negative
            call dfovrg (ncycle, ikap, rmt, jri, jri, p2, p2val, dx,
     1               ri, v,vval, dny, dgcn, dpcn, adgc, adpc,
     1               pu, qu, p, q,
     1               iph, iz, ihole, xion, irr, ic3)

            temp = (jl(il)*(dny-l) + xkmt*jl(il+1))  /
     1             (nl(il)*(dny-l) + xkmt*nl(il+1))
            xx = dble (temp)
            yy = dimag(temp)
            if (xx .ne. 0)  then
               alph = (1 - xx**2 - yy**2)
               alph = sqrt(alph**2 + 4*xx**2) - alph
               alph = alph / (2 * xx)
               alph = atan (alph)
            else
               alph = 0
            endif
            beta = (xx**2 + (yy+1)**2) /
     1             (xx**2 + (yy-1)**2)
            beta = log(beta) / 4

            ph(ie,il) = dcmplx (alph, beta)

c           cut phaseshift calculation if they become too small
            if (abs(ph(ie,il)) .lt. 1.0e-6)  goto 220
czero       print*,'jl=',l,jl(il)*xkmt
czero       print*,ie,il,ph(ie,il)

  210    continue

  220 continue

      if (mod(ixc,10) .ge. 5) then
         do 225 ie = 1, ne
  225    eref(ie) = erefvl(ie)
      endif

      return
      end
      subroutine phash (npat, ipat, rx, ry, rz, dhash)
c     hashes a path into double precision real dhash

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      double precision dhash
      dimension rx(npatx), ry(npatx), rz(npatx), ipat(npatx+1)

      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)

      double precision xx

      parameter (iscale = 1000)
      parameter (factor = 16.12345678)
      parameter (facto2 = 8.57654321)

c     Hashing scheme: Assume about 15 significant digits in a double
c     precision number.  This is 53 bit mantissa and 11 bits for sign
c     and exponent, vax g_floating and probably most other machines.
c     With max of 9 legs, 47**9 = 1.12e15, so with a number less than
c     47, we can use all these digits, scaling each leg's data by
c     47**(j-1).  Actually, since our numbers can go up to about 10,000,
c     we should keep total number < 1.0e11, 17**9 = 1.18e11, which means
c     a factor a bit less than 17.  Choose 16.12345678, a non-integer,
c     to help avoid hash collisions.

c     iscale and 'int' below are to strip off trailing digits, which
c     may contain roundoff errors

      dhash = 0
      do 210  j = 1, npat
         xx = factor**(j-1)
         dhash = dhash + xx * (nint(rx(j)*iscale) +
     1               nint(ry(j)*iscale)*0.894375 +
     2               nint(rz(j)*iscale)*0.573498)
  210 continue
      do 220  j = 1, npat
         xx = facto2**(j-1)
         dhash = dhash + xx * iscale * ipot(ipat(j))
c        dhash = dhash + xx * ipot(ipat(j))
  220 continue
      dhash = dhash + npat * 40 000 000

      return
      end
c     make e mesh for phase
c     input:  nemax, iprint,
c             ixanes, edge, xmu, vint, vr0, imt, edens, nph
c             edge, xmu... used only with ixanes = 1
c     output: ne, em(ne), ik0 [grid point with k=0]
c
c     set nemax = nex (from dim.h) for max number of points

      subroutine phmesh (nemax, iprint,
     1                   ixanes, edge, xmu, vint, vr0,
     1                   imt, edens, nph,
     2                   ne, em, ik0)
      implicit double precision (a-h, o-z)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension em(nex)

c     edens       overlapped density*4*pi
c     imt         r mesh index just inside rmt
c     see arrays.h
      dimension edens(251,0:nphx)
      dimension imt(0:nphx)

      character*512 slog

c     xkmin needed only with ixanes
      if (ixanes .gt. 0)  then
c        Need xf**2 min for all unique potentials, take rho(imt) as
c        min rho
         xf2int = xmu-vint
         xf2min = xf2int
         do 400  i = 0, nph
            rs = (3 / edens(imt(i),i)) ** third
            xf2 = (fa / rs) ** 2
            if (xf2 .le. xf2min) xf2min = xf2
  400    continue

         xkmin2 = xf2min - vr0
         if (xkmin2 .lt. 0)  then
            call wlog(' xf2min, vr0, xkmin2')
            write(slog,402) xf2min, vr0, xkmin2
            call wlog(slog)
  402       format(1p, 3e13.5)
            call wlog(' bad vr0 in phmesh')
            stop 'bad vr0 in phmesh'
         endif

         delk = bohr/10
         xkmin = sqrt (xkmin2)
         n = int(xkmin/delk) - 1
      else
         xkmin = 0
         n = 0
      endif

c     energy mesh
c      n pts (-2 le k lt 0,  delk=0.1 ang(-1) ) (only if xanes)
c     20 pts (0 le k le 1.9, delk=0.1 ang(-1) )
c     20 pts (2 le k le 5.8, delk=0.2 ang(-1) )
c      9 pts (6 le k le 10., delk=0.5 ang(-1) )
c     10 pts (11 le k le 20.0, delk=1.0 ang(-1) )
      ne = 0
      delk = bohr/10
      if (ixanes .gt. 0)  then
         xkmin = n*delk
         do 110 i=1,n
            tempk=-xkmin+(i-1)*delk
            ne = ne+1
            em(ne)=-tempk**2+edge
  110    continue
      endif
      delk = bohr/10
      do 111 i=1,20
         tempk=(i-1)*delk
         ne = ne+1
         em(ne)=tempk**2+edge
         if (i.eq.1)  ik0 = ne
  111 continue
      delk = bohr/5
      do 112 i=1,20
         tempk=2*bohr + (i-1)*delk
         ne = ne+1
         em(ne)=tempk**2+edge
  112 continue
      delk = bohr/2
      do 113 i=1,9
         tempk=6*bohr + (i-1)*delk
         ne = ne+1
         em(ne)=tempk**2+edge
  113 continue
      delk=bohr
      do 114 i=1,10
         tempk=11*bohr + (i-1)*delk
         ne = ne+1
         em(ne)=tempk**2+edge
  114 continue

c     type*, 'phmesh: ne, nex, nemax before setting ne ',
c    1                 ne, nex, nemax
      ne = min (ne, nemax)
c     type*, 'phmesh: ne, nex, nemax after  setting ne ',
c    1                 ne, nex, nemax


      if (iprint .ge. 3)  then
         open (unit=44, file='emesh.dat')
         write(44,*) 'edge, bohr, edge*ryd ', edge, bohr, edge*ryd
         write(44,*) 'ixanes, ik0 ', ixanes, ik0
         write(44,*) vint, xkmin, n, ' vint, xkmin, n'
         write(44,*) 'ie, em(ie), xk(ie)'
         do 230  ie = 1, ne
            write(44,220)  ie, em(ie), getxk(em(ie)-edge)/bohr
  220       format (i5, 2f20.5)
  230    continue
         close (unit=44)
      endif

      return
      end
      subroutine pijump (ph, old)
      implicit double precision (a-h, o-z)

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

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      parameter (twopi = 2 * pi)
      dimension xph(3)

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


      xphmin = min (abs(xph(1)), abs(xph(2)), abs(xph(3)))
      isave = 0
      do 10  i = 1, 3
         if (abs (xphmin - abs(xph(i))) .le. 0.01)  isave = i
   10 continue
      if (isave .eq. 0)  then
         stop 'pijump'
      endif

      ph = old + xph(isave)

      return
      end
      subroutine potph (rgrd, lreal, nohole)

c     Cluster code -- multiple shell single scattering version of FEFF
c     This program (or subroutine) calculates potentials and phase
c     shifts for unique potentials specifed by atoms and overlap cards.
c
c     Input files:  potph.inp    input data, atoms, overlaps, etc.
c     Output:       phases.bin   phase shifts for use by the rest of the
c                                program
c                   xxx.dat      various diagnostics

      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

c     include 'arrays.h'
c     Notes:
c        nat    number of atoms in problem
c        nph    number of unique potentials
c        nfr    number of unique free atoms
c        ihole  hole code of absorbing atom
c        iph=0 for central atom
c        ifr=0 for central atom

c     Specific atom input data
      dimension iphat(natx)
      dimension rat(3,natx)

c     Unique potential input data
      dimension iatph(0:nphx)
      dimension ifrph(0:nphx)
      dimension xnatph(0:nphx)
      character*6 potlbl(0:nphx)

      dimension folp(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)

c     Free atom data
      dimension xion(0:nfrx)
      dimension iz(0:nfrx)

c     ATOM output
c     Note that ATOM output is dimensioned 251, all other r grid
c     data is set to nrptx, currently 250
      dimension rho(251,0:nfrx)
      dimension vcoul(251,0:nfrx)

c     Overlap calculation results
      dimension edens(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension vtot (251,0:nphx)

c     Muffin tin calculation results
      dimension imt(0:nphx)
      dimension inrm(0:nphx)
      dimension rmt(0:nphx)
      dimension rnrm(0:nphx)

c     PHASE output
      complex*16 eref(nex)
      complex*16 ph(nex,ltot+1,0:nphx)
      dimension lmax(0:nphx)
      common /print/ iprint

      parameter (nheadx = 30)
      character*80 head(nheadx)
      dimension lhead(nheadx)

      logical lreal, nohole

c     head0 is header from potph.dat, include carriage control
      character*80 head0(nheadx)
      dimension lhead0(nheadx)

      dimension em(nex)
      complex*16  rkk(nex,-1:1)
c     need irregular solution for complex potential. fix later
      dimension xsnorm(nex), xsec(nex)
      dimension dgc0(251), dpc0(251)

c     additioal data needed for relativistic version
      dimension dgc(251,30,0:nfrx), dpc(251,30,0:nfrx)
      dimension adgc(10,30,0:nfrx), adpc(10,30,0:nfrx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension rhoval(251,0:nphx), edenvl(251,0:nphx)
      dimension vvalgs (251,0:nphx), rcore(0:nphx)

c     nrx = max number of r points for phase and xsect r grid
      parameter (nrx = nrptx)
      dimension ri(nrptx), vtotph(nrx), rhoph(nrx)
      dimension  dmagx(nrptx), dmag(251,0:nfrx)
      dimension dgcx(nrptx), dpcx(nrptx), vvalph(nrx), rhphvl(nrx)
      logical german
      dimension rd(251,0:nfrx), sigmd(51), pgrid(51)

      character*512 slog

   10 format (4x, a, i5)

      do 15 i = 1,251
      do 15 iorb = 1,30
      do 15 ifr  = 0,nfrx
         dgc(i,iorb,ifr) = 0.0d0
   15    dpc(i,iorb,ifr) = 0.0d0

c     Read input from file potph.inp
      open (unit=1, file='potph.dat', status='old', iostat=ios)
      call chopen (ios, 'potph.dat', 'potph')
      nhead0 = nheadx
      call rpotph (1, nhead0, head0, lhead0, nat, nph,
     1             nfr, ihole, gamach, iafolp, intclc,
     1             ixc, vr0, vi0, rs0, iphat, rat, iatph, ifrph,
     1             xnatph, novr,
     2             iphovr, nnovr, rovr, folp, xion, iz, iprint,
     2             ixanes, nemax, xkmin, xkmax,
     3             methat, methfs, jumprm, mbconv, potlbl)
      close (unit=1)

c     Free atom potentials and densities
c     Final state is (usually) with a core hole, initial state is
c     w/o a corehole.
c     NB wsatom is needed in SUMAX, if changed here, change it there
c     wsatom = 15
c     do not save spinors
      ispinr = 0
      do 20  ifr = 0, nfr
         write(slog,10)
     1     'free atom potential and density for atom type', ifr
         call wlog(slog)
c        Include corehole if absorber (unless user says nohole)
         if (ifr .eq. 0  .and. .not.nohole)  then
            itmp = ihole
         else
            itmp = 0
         endif
         call scfdat (head0(1)(1:40), ifr, iz(ifr), itmp, xion(ifr),
     1         vcoul(1,ifr), rho(1,ifr), dmag(1,ifr), rhoval(1,ifr),
     2         rcore(ifr), ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,
     3         s02, efrozn, et)
c        etfin is absorbing atom final state total energy, see nohole
c           case below
         if (ifr .eq. 0)  etfin = et
   20 continue
c     if (ixanes .gt. 0)  then
         write(slog,10) 'initial state energy'
         call wlog(slog)
c        Save initial state energy and spinors for core hole orbital,
c        do not save potentials.
         ispinr = ihole
         itmp = 0
         call scfdat (head0(1)(1:40), nfr+1, iz(0), itmp, xion(0),
     1     vcoul(1,nfr+1), rho(1,nfr+1), dmag(1,nfr+1), rhoval(1,nfr+1),
     2     rcore(nfr+1), ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,
     3     s02, efrozn, etinit)
c        etinit is absorbing atom initial state (no hole)
c        efrozn is ionization energy with frozen orbitals (koopman's
c         theorem)
c        etfin-etinit is ionization energy in adiabatic approximation
         erelax= -efrozn - ( etfin - etinit)
         emu = etfin - etinit - vr0
c     endif
c     if (ixanes .gt. 0 .and. nohole)  then
      if (nohole)  then
c        If nohole, the final state energy we need must include the
c        corehole so the absorption edge will be in the right place.
c        Do not save spinors or potentials.
         ispinr = 0
         itmp = ihole
         call scfdat (head0(1)(1:40), nfr+1, iz(0), itmp, xion(0),
     1     vcoul(1,nfr+1), rho(1,nfr+1), dmag(1,nfr+1), rhoval(1,nfr+1),
     2     rcore(nfr+1), ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,
     3     s02, efrozn, etfin)
      endif

c     Overlap potentials and densitites
      do 40  iph = 0, nph
         write(slog,10)
     1    'overlapped potential and density for unique potential', iph
         call wlog(slog)
         call ovrlp (iph, iphat, rat, iatph, ifrph, novr, iphovr,
     1               nnovr, rovr, iz, nat, rho, dmag, rhoval, vcoul,
     2               edens, edenvl, vclap, rnrm)
   40 continue
c     if (pola.eq.2 .or. pola.eq.3) then
c        do 44 i=1,251
c  44    dmag(i,nph+1) = dmag(i,nfr+1) * (-1)**pola
c     endif


c     Find muffin tin radii, add gsxc to potentials, and find
c     interstitial parameters
      write(slog,10) 'muffin tin radii and interstitial parameters'
      call wlog(slog)
c   need fraction for sigma_d for ixc=6,7
c     if (mod(ixc,10) .ge. 5) then
         german = .false.
         iorb=9
c        d-orbital for Cu
         do 410 iph = 0,nph
         do 410 ir = 1,251
c        take upper component, approx. equal to nonrelativistic w.f.
 410        rd(ir,iph) = dgc(ir,iorb,ifrph(iph))
c        used to test sigma_d
c        call testd (nph,german,rmt,rnrm,rd,fractn)
c     endif

      call istprm (nph, nat, iphat, rat, iatph, xnatph,
     1            novr, iphovr, nnovr, rovr, folp, edens, edenvl,
     2            dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3            ixc, rhoint,vint, rs, xf, xmu,
     4            rhinvl,vintvl, rsval, xfval, xmuval,
     5            rnrmav, intclc, german, rd, sigmd, pgrid)
c     wp is plasmon frequency in ryd.
      wp = sqrt(12.*rs/fa**4)*xf*xf

c     Automatic max reasonable overlap
      if (iafolp .eq. 1)  then
         write(slog,10) 'automatic overlapping'
         call wlog(slog)
         call wlog(' iph, rnrm(iph)*bohr, rmt(iph)*bohr, folp(iph)')
         do 400  iph = 0, nph
            folp(iph) = 1 + 0.7*(rnrm(iph)/rmt(iph) - 1)
  398       format(i5, 1p, 3e13.5)
            write(slog,398) iph, rnrm(iph)*bohr,
     1                      rmt(iph)*bohr, folp(iph)
            call wlog(slog)
  400    continue
         call istprm (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, edens, edenvl,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu,
     4               rhinvl,vintvl, rsval, xfval, xmuval,
     5               rnrmav, intclc, german, rd, sigmd, pgrid)
         wp = sqrt(12.*rs/fa**4)*xf*xf
      endif

c     Initialize header routine and write misc.dat
      if (mod(ixc,10) .ne. 5) then
         call sthead (nhead0, head0, lhead0, nph, iz, rmt, rnrm,
     1             xion, ifrph, ihole, ixc,
     2             vr0, vi0, rs0, gamach, xmu, xf, vint, rs,
     2             nohole, lreal, rgrd,
     3             nhead, lhead, head)
      else
         call sthead (nhead0, head0, lhead0, nph, iz, rmt, rnrm,
     1             xion, ifrph, ihole, ixc,
     2             vr0, vi0, rs0, gamach, xmuval, xfval, vintvl, rsval,
     2             nohole, lreal, rgrd,
     3             nhead, lhead, head)
      endif
      if (iprint .ge. 1)  then
         open (unit=1, file='misc.dat', status='unknown', iostat=ios)
         call chopen (ios, 'misc.dat', 'potph')
         call wthead(1)
         close (unit=1)
      endif

      if (iprint .ge. 2)  then
c        call wpot (nph, edens, ifrph, imt, inrm,
c    1              edenvl, vclap, vvalgs, vtot)
         call wpot (nph, edens, ifrph, imt, inrm,
     1              rho, vclap, vcoul, vtot)
      endif

c     Phase shift calculation
c     Atom r grid
      dx = 0.05d0
      x0 = 8.8d0
c     Phase r grid
      dxnew = rgrd

c     Make energy mesh
      edge = xmuval - vr0
      if (mod(ixc,10) .lt. 5) then
         call phmesh (nemax, iprint,
     1             ixanes, edge, xmu, vint, vr0,
     1             imt, edens, nph,
     2             ne, em, ik0)
       else
         call phmesh (nemax, iprint,
     1             ixanes, edge, xmuval, vintvl, vr0,
     1             imt, edenvl, nph,
     2             ne, em, ik0)
       endif

c     Cross section calculation, use phase mesh for now
c     Absorbing atom is iph=0
      write(slog,10) 'absorption cross section'
      call wlog(slog)
      ifr = 0
      call fixvar (rmt(0), edens(1,0), vtot(1,0), dmag(1,0),
     1             vint, rhoint, dx, dxnew, jumprm,
     2             vjump, ri, vtotph, rhoph, dmagx)
      call fixdsx (ifr, dx, dxnew, dgc, dpc, dgcn, dpcn)
      if (mod(ixc,10) .ge. 5) then
         if (jumprm .gt. 0) jumprm = 2
         call fixvar (rmt(0), edenvl(1,0), vvalgs(1,0), dmag(1,0),
     1             vintvl, rhinvl, dx, dxnew, jumprm,
     2             vjump, ri, vvalph, rhphvl, dmagx)
         if (jumprm .gt. 0) jumprm = 1
      endif
      call fixdsp (dx, dxnew, dgc0, dpc0, dgcx, dpcx)

      call xsect (dxnew, x0, ri, ne, em, edge,
     1            ihole, emu, dgcx, dpcx,
     2            ixc, lreal, rmt(0), rcore(0), xmu, xmuval, vi0, rs0,
     3            gamach, vtotph, vvalph, rhoph, dmagx, rhphvl,
     4            dgcn, dpcn, adgc, adpc, xsec, xsnorm, rkk,
     5            methat, ifr, iz, xion, sigmd, pgrid)

      if (ixanes .gt. 0)  then
         open (unit=1, file='xsect.bin', status='unknown')
         call chopen (ios, 'xsect.bin', 'potph')
         call wthead (1)
         write(1,*) 'vtot in eV, rho in code units, includes 4pi'
         write(1,*) 'ipot, vtot(imt), rho(imt) '
         write(1,122) 'interstitial', vint*ryd, rhoint
         do 386  iph = 0, nph
            write(1,123)iph,vtot(imt(iph),iph)*ryd,edens(imt(iph),iph)
  386    continue
  122    format (1x, a, 1p, 2e20.6)
  123    format (i10, 1p, 2e20.6)
         write(1,42)  emu*ryd
   42    format ('       edge ', 2f20.5)
         write(1,*)  imt(0), ' imt(0)'
         write(1,200)  vint*ryd, rhoint, ri(imt(0)+1)
  200    format ('  v, rho, r', /, 1p, 3e20.4, ' intersitial')
         do 220  iii = imt(0), imt(0)-4, -1
            write(1,210)  vtot(iii,0)* ryd, edens(iii,0), ri(iii), iii
  210    format (1p, 3e20.4, i6)
  220    continue
         write(1,45)
   45    format (1x, 71('-'))
         write(1,55) methat, s02, erelax, wp
   55    format (i4,3e15.7, ' method to calculate xsect')
         write(1,56) gamach*ryd
   56    format (1p, e15.7, ' gamach in eV')
         write(1,57)
   57 format ('    em           omega        k           xsnorm     ',
     1        'xsec  ')
         do 50  ie = 1, ne
            xk = getxk (em(ie) - edge)
c           omega = em(ie) + etfin - etinit
c           now edge position is given by atomic estimate,
c           thus we neglect chemical shift of the edge
            omega = (em(ie) - edge) + emu
            write(1,46) em(ie)*ryd,omega*ryd,xk/bohr,xsnorm(ie),xsec(ie)
   46       format (1p, 6e13.5)
   50    continue
         close (unit=1)
      endif
c     Write out reduced matrix elements for genfmt
      open (unit=1, file='rkk.bin', access='sequential',
     1      form='unformatted', status='unknown', iostat=ios)
      call chopen (ios, 'rkk.bin', 'potph')
      write(1) ((rkk(ie,k1),ie=1,nex),k1=-1,1)
      close(unit=1)

      do 60  iph = 0, nph
         write(slog,10) 'phase shifts for unique potential', iph
         call wlog(slog)
c        fix up variable for phase
         call fixvar (rmt(iph), edens(1,iph), vtot(1,iph), dmag(1,iph),
     1                vint, rhoint, dx, dxnew, jumprm,
     2                vjump, ri, vtotph, rhoph, dmagx)
         if (mod(ixc,10) .ge.5) then
            if (jumprm .gt. 0) jumprm = 2
            call fixvar (rmt(iph), edenvl(1,iph), vvalgs(1,iph),
     1                dmag(1,iph), vintvl, rhinvl, dx, dxnew, jumprm,
     2                vjump, ri, vvalph, rhphvl, dmagx)
            if (jumprm .gt. 0) jumprm = 1
            call fixdsx (ifrph(iph), dx, dxnew, dgc, dpc, dgcn, dpcn)
         endif

         call phase (iph, dxnew, x0, ri, ne, em, edge, ixc,
     1             lreal, rmt(iph), rcore(ifrph(iph)), xmu, xmuval,
     1             vi0, rs0,
     2             gamach, vtotph, vvalph, rhoph, dmagx, rhphvl,
     3             dgcn, dpcn, adgc, adpc, eref, ph(1,1,iph), lmax(iph),
     4             methfs, iz(ifrph(iph)), ihole, xion(ifrph(iph)),
     5             sigmd, pgrid)
   60 continue

      if (iprint .ge. 2)  then
         call wphase (nph, em, eref, lmax, ne, ph)
      endif

c     Write out phases for genfmt
c     May need stuff for use with headers only
      open (unit=1, file='phase.bin', access='sequential',
     1      form='unformatted', status='unknown', iostat=ios)
      call chopen (ios, 'phase.bin', 'potph')
      write(1) nhead
      do 62  i = 1, nhead
         write(1) head(i)
         write(1) lhead(i)
   62 continue
      write(1) ne, nph, ihole, rnrmav, xmu, edge, ik0, methfs
      write(1) (em(ie),ie=1,ne)
      write(1) (eref(ie),ie=1,ne)
      do 80  iph = 0, nph
         write(1) lmax(iph), iz(ifrph(iph))
         write(1) potlbl(iph)
         do 70  ie = 1, ne
            write(1)  (ph(ie,ll,iph), ll=1,lmax(iph)+1)
   70    continue
   80 continue
      close (unit=1)

c     print*,'s02=',s02,' erelax=',erelax*ryd,' wp=',wp*ryd,
c    1 ' Ed=',erelax*ryd/(1-s02)
      return
      end
      subroutine prcrit (neout, nncrit, ik0out, cksp, fbeta, ckspc,
     1                   fbetac, potlb0, xlam, xlamc)
      implicit double precision (a-h, o-z)

c     Prepare fbeta arrays, etc., for pathfinder criteria
c
c     Note that path finder is single precision, so be sure that
c     things are correct precision in calls and declarations!
c     See declarations below for details.
c
c     Inputs:  Reads phase.bin
c     Output:  neout   'ne', number of energy grid points
c              ik0out  index of energy grid with k=0
c              cksp    |p| at each energy grid point in single precision
c              fbeta   |f(beta)| for each angle, npot, energy point, sp
c              ckspc   |p| at each necrit point in single precision
c              fbetac  |f(beta)| for each angle, npot, nncrit point, sp
c              potlb0  unique potential labels
c              xlam    mean free path for each energy point in Ang, sp
c              xlamc   mean free path for each nncrit point in Ang, sp

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle

c     Output variables SINGLE PRECISION for use with path finder.
c     BE CAREFUL!!
      parameter (necrit=9, nbeta=40)
      real fbetac(-nbeta:nbeta,0:npotx,necrit), ckspc(necrit)
      real fbeta(-nbeta:nbeta,0:npotx,nex), cksp(nex)
      real xlamc(necrit)
      real xlam(nex)
      character*6  potlb0(0:npotx)

c     Local variables
      complex*16 cfbeta, tl, cktmp
      dimension dcosb(-nbeta:nbeta)
      dimension pl(ltot+1)
      dimension iecrit(necrit)
      parameter (eps = 1.0e-16)


c     Need stuff from phase.bin
c     Read phase calculation input, data returned via commons
      open (unit=1, file='phase.bin', status='old',
     1      access='sequential', form='unformatted', iostat=ios)
      call chopen (ios, 'phase.bin', 'prcrit')
      call rphbin (1)
      close (unit=1)
c     Pass out ne, ik0, potlbl (from rphbin via /pdata/)
      neout = ne
      ik0out = ik0
      do 40  i = 0, npotx
         potlb0(i) = potlbl(i)
   40 continue

c     |p| at each energy point (path finder uses invA, convert here)
c     Also make mfp (xlam) in Ang
      do 100  ie = 1, ne
         cksp(ie) = abs (sqrt (em(ie) - eref(ie))) / bohr
c        xlam code lifted from genfmt
         cktmp = sqrt (em(ie) - eref(ie))
         xlam(ie) = 1.0e10
         if (abs(dimag(cktmp)) .gt. eps) xlam(ie) = 1/dimag(cktmp)
         xlam(ie) = xlam(ie) * bohr
  100 continue

c     Make the cos(beta)'s
c     Grid is from -40 to 40, 81 points from -1 to 1, spaced .025
      do 200  ibeta = -nbeta, nbeta
         dcosb(ibeta) = 0.025 * ibeta
  200 continue
c     watch out for round-off error
      dcosb(-nbeta) = -1
      dcosb(nbeta)  =  1

c     make fbeta (f(beta) for all energy points
      do 280  ibeta = -nbeta, nbeta
         call cpl0 (dcosb(ibeta), pl, lmaxp1)
         do 260  iii = 0, npot
            do 250  ie = 1, ne
               cfbeta = 0
               do 245  il = 1, lmax(ie,iii)+1
                  tl = (exp (2*coni*ph(ie,il,iii)) - 1) / (2*coni)
                  cfbeta = cfbeta + tl*pl(il)*(2*il-1)
  245          continue
               fbeta(ibeta,iii,ie) = abs(cfbeta)
  250       continue
  260    continue
  280 continue

c     Make similar arrays for only the icrit points

c     Use 9 points at k=0,1,2,3,4,6,8,10,12 invA
c     See phmesh for energy gid definition.  These seem to work fine,
c     and results aren't too sensitive to choices of k.  As few as 4
c     points work well (used 0,3,6,9), but time penalty for 9 points
c     is small and increased safety seems to be worth it.
      iecrit(1) = ik0
      iecrit(2) = ik0 + 5
      iecrit(3) = ik0 + 10
      iecrit(4) = ik0 + 15
      iecrit(5) = ik0 + 20
      iecrit(6) = ik0 + 30
      iecrit(7) = ik0 + 34
      iecrit(8) = ik0 + 38
      iecrit(9) = ik0 + 40

c     make sure that we have enough energy grid points to use all
c     9 iecrits
      nncrit = 0
      do 290  ie = 1, necrit
         if (iecrit(ie) .gt. ne)  goto 295
         nncrit = ie
  290 continue
  295 continue
      if (nncrit .eq. 0) stop 'bad nncrit in prcrit'


      do 320  icrit = 1, nncrit
         ie = iecrit(icrit)
         ckspc(icrit) = cksp(ie)
         xlamc(icrit) = xlam(ie)
         do 310  ibeta = -nbeta, nbeta
            do 300  iii = 0, npot
               fbetac(ibeta,iii,icrit) = fbeta(ibeta,iii,ie)
  300       continue
  310    continue
  320 continue

      return
      end
      subroutine quinn (x, rs, wp, ef, ei)
      implicit double precision (a-h, o-z)

c     input  x, rs, wp, ef
c     output ei

c***********************************************************************
c
c     quinn: calculates low energy gamma (approx. proportional to e**2)
c             formula taken from john j. quinn, phys. rev. 126,
c             1453 (1962); equation (7).
c             a cut-off is set up at quinn's cutoff + ef = ekc; it is a
c             rounded inverted step function (a fermi function)
c             theta = 1/( 1 + exp((e-ekc)/gam)) )
c             where the rounding factor gam is set to be about 0.3 ekc.
c     modified by j. rehr (oct 1991) based on coding of r. albers
c     subroutines quinn.f and quinnc.f
c
c     variables:
c        x  = p/pf
c        rs = ws density parameter
c        ei = imaginary self energy
c        pfqryd = quinn's prefactor in atomic-rydberg units
c        wkc = quinn's plasmon threshold
c
c***********************************************************************

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

      parameter (alphaq = 1/ fa)

c     calculate quinn prefactor in atomin Hartree units
      pisqrt = sqrt(pi)
      pfq = pisqrt / (32 * (alphaq*rs)**1.5)
      temp1 = atan (sqrt (pi / (alphaq*rs)))
      temp2 = sqrt(alphaq*rs/pi) / (1 + alphaq*rs/pi)
      pfq = pfq * (temp1 + temp2)

c     calculate quinn cutoff
c     wkc = quinn's plasmon threshold
c     wkc is cut-off of quinn, pr126, 1453, 1962, eq. (11)
c     in formulae below wp=omegap/ef
      wkc = (sqrt(1+wp) - 1)**2
      wkc = (1 + (6./5.) * wkc / wp**2) * wp * ef

c     we add fermi energy to get correct energy for
c     plasma excitations to turn on
      ekc = wkc + ef

c     calculate gamma
c     gamryd = 2 * (pfqryd/x) * (x**2-1)**2
      gam = (pfq/x) * (x**2-1)**2

c     put in fermi function cutoff
      eabs = ef * x**2
      arg = (eabs-ekc) / (0.3*ekc)
      f = 0
      if (arg .lt. 80)  f = 1 / (1 + exp(arg))

      ei = -gam * f / 2

      return
      end
      subroutine rdhead (io, nhead, head, lhead)
      implicit double precision (a-h, o-z)

c     Reads title line(s) from unit io.  Returns number of lines
c     read.  If more than nheadx lines, skips over them.  End-of-header
c     marker is a line of 1 blank, 71 '-'s.
c     lhead is length of each line w/o trailing blanks.
c     header lines returned will have 1st space on line blank for
c     carriage control

      character*(*) head(nhead)
      dimension lhead(nhead)
      character*80  line

      n = 0
      nheadx = nhead
      nhead = 0
   10 read(io,20)  line
   20    format(a)
         if (line(4:11) .eq. '--------')  goto 100
         n = n+1
         if (n .le. nheadx)  then
            head(n) = line
            lhead(n) = istrln(head(n))
            nhead = n
         endif
      goto 10
  100 continue
      return
      end
      subroutine rdinp (mphase, mpath, mfeff, mchi, ms,
     1                  ntitle, title, ltit,
     2                  critcw,
     1                  ipr2, ipr3, ipr4,
     1                  s02, mbconv, tk, thetad, alphat, sig2g,
     1                  nlegxx,
     1                  rmax, critpw, pcritk, pcrith, nncrit,
     2                  icsig, iorder, vrcorr, vicorr, xloss,
     1                  rgrd, lreal, nohole, zzcrit, zzkmin, zzkmax,
     1                  wnstar)

c     Read input for multiple scattering feff
      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola

c     Following passed to pathfinder, which is single precision.
c     Be careful to always declare these!
      real rmax, critpw, pcritk, pcrith

c     Data for potph (see arrays.h for comments)
      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)
      dimension ifrph(0:nphx)
      dimension xnatph(0:nphx)
      dimension folp(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)
      dimension xion(0:nfrx)
      dimension iz(0:nfrx)

      character*6  potlbl(0:nphx)

c     false for normal use, true to use only real phase shifts
      logical lreal, nohole, wnstar

c     Local stuff
      character*150  line
      parameter (nwordx = 12)
      character*15 words(nwordx)

      parameter (ntitx = 10)
      character*71  title(ntitx)
      dimension ltit(ntitx)
      dimension xionph(0:nphx), izph(0:nphx)
      logical iscomm
      parameter (nssx = 16)
      dimension indss(nssx), iphss(nssx)
      dimension degss(nssx), rss(nssx)
      logical nogeom

      parameter (big = 1.0e5)
      character*512 slog

   10 format (a)
   20 format (bn, i15)
   30 format (bn, f15.0)

c     initialize things

      ihole = 1
      ntitle = 0
      ixc = 0
      vr0 = 0
      vi0 = 0
      rs0 = 0
      rmax = -1
      tk = 0
      thetad = 0
      alphat = 0
      sig2g = 0
      rmult = 1
      s02 = 1
      mphase = 1
      mpath = 1
      mfeff = 1
      mchi = 1
      ms = 0
      ipr1 = 0
      ipr2 = 0
      ipr3 = 0
      ipr4 = 0
      nlegxx = 10
      xkmin = 0
      xkmax = 20
      critcw = 4.0
      critpw = 2.5
      pcritk = 0
      pcrith = 0
      nogeom = .false.
      icsig = 1
      iorder = 2
      ixanes = 0
      methat = 0
      methfs = 0
      jumprm = 0
      mbconv = 0
      vrcorr = 0
      vicorr = 0
      iafolp = 0
      intclc = 0
      nemax = nex
      zzcrit = -1
      zzkmin = 0
      zzkmax = 10

      rgrd = 0.05d0
      lreal = .false.
      nohole = .false.
      wnstar = .false.

c     average over polarization by default
      pola =  0
      elpty = 0
      do 50 i = 1, 3
         evec(i) = 0
         xivec(i) = 0
  50  continue

c     nncrit is number of necrit points to use.  necrit is
c     currently 9, this was at once an input used for testing.
      nncrit = 9

      nat = 0
      do 100  iat = 1, natx
         iphat(iat) = -1
  100 continue

      nss = 0
      do 102  iss = 1, nssx
         indss(iss) = 0
         iphss(iss) = 0
         degss(iss) = 0
         rss(iss) = 0
  102 continue

      nph = 0
      do 110  iph = 0, nphx
         iatph(iph) = 0
         ifrph(iph) = -1
         xnatph(iph) = 0
         folp(iph) = 1
         novr(iph) = 0
         xionph(iph) = 0
         izph(iph) = 0
         potlbl(iph) = ' '
  110 continue

      nfr = 0
      do 120  ifr = 0, nfrx
         xion(ifr) = 0
         iz(ifr) = 0
  120 continue

c     Open feff.inp, the input file we're going to read
      open (unit=1, file='feff.inp', status='old', iostat=ios)
      call chopen (ios, 'feff.inp', 'rdinp')

c     tokens  0 if not a token
c             1 if ATOM (ATOMS)
c             2 if HOLE
c             3 if OVER (OVERLAP)
c             4 if CONT (CONTROL)
c             5 if EXCH (EXCHANGE)
c             6 if ION
c             7 if TITL (TITLE)
c             8 if FOLP
c             9 if RMAX
c            10 if DEBY (DEBYE)
c            11 if RMUL (RMULTIPLIER)
c            12 if SS
c            13 if PRIN (PRINT)
c            14 if POTE (POTENTIALS)
c            15 if NLEG
c            16 if REQU (REQUIRE), now dead
c            17 if KLIM (KLIMIT), now dead
c            18 if CRIT (CRITERIA)
c            19 if NOGEOM
c            20 if CSIG
c            21 if IORDER
c            22 if PCRI (PCRITERIA)
c            23 if SIG2
c            24 if XANE (XANES)
c            25 if CORR (CORRECTIONS)
c            26 if AFOL (AFOLP)
c            27 if NEMA (NEMAX)
c            28 if INTCALC
c            29 if POLA (POLARIZATION)
c            30 if ELLI (ELLIPTICITY)
c            31 if CUST (CUSTOMCRIT)
c            32 if RGRI (RGRID)
c            33 if RPHA (RPHASES), real phase shifts
c            34 if NSTA (NSTAR), n* for co-linear polarization
c            35 if NOHO (NOHOLE), use no hole for potentials
c            36 if SIG3 third and first cumulants for ss paths
c            37 if JUMP (JUMPRM), remove jumps of potential
c            38 if MBCO (MBCONV), do convolution with exitation spectrum
c            39 if SPIN do calculation for spin-up(down) photoelectron
c            -1 if END  (end)
c     mode flag  0 ready to read a keyword card
c                1 reading atom positions
c                2 reading overlap instructions for unique pot
c                3 reading unique potential definitions

      mode = 0
  200 read(1,10,iostat=ios)  line
         if (ios .lt. 0)  line='END'
         call triml (line)
         if (iscomm(line))  goto 200
         nwords = nwordx
         call bwords (line, nwords, words)
         itok = itoken (words(1))

c        process the card using current mode
  210    continue

         if (mode .eq. 0)  then
            if (itok .eq. 1)  then
c              ATOM
c              Following lines are atom postions, one per line
               mode = 1
            elseif (itok .eq. 2)  then
c              HOLE     1  1.0
c                   holecode s02
               read(words(2),20,err=900)  ihole
               read(words(3),30,err=900)  s02
               mode = 0
            elseif (itok .eq. 3)  then
c              OVERLAP iph
c                  iph  n  r
               read(words(2),20,err=900)  iph
               call phstop(iph,line)
               call warnex(' OVERLAP:')
               mode = 2
            elseif (itok .eq. 4)  then
c              CONTROL  mphase, mpath, mfeff, mchi
c               0 - do not run modules, 1 - run module
               read(words(2),20,err=900)  mphase
               read(words(3),20,err=900)  mpath
               read(words(4),20,err=900)  mfeff
               read(words(5),20,err=900)  mchi
               mode = 0
            elseif (itok .eq. 5)  then
c              EXCHANGE  ixc  vr0  vi0
c              ixc=0  Hedin-Lunqvist + const real & imag part
c              ixc=1  Dirac-Hara + const real & imag part
c              ixc=2  ground state + const real & imag part
c              ixc=3  Dirac-Hara + HL imag part + const real & imag part
c              ixc=4  DH below rs0 + HL above rs0 + const real
c                     & imag part, form is
c                     EXCHANGE  4  vr0  vi0  rs0
c              ixc=5  partially nonlocal: Dirac-Fock for core + HL for
c                     valence electrons, + const real & imag part
c              ixc=10 same as ixc=0 with broadened plasmon HL selfenergy
c              ixc=13 same as ixc=3 with broadened plasmon HL selfenergy
c              ixc=15 same as ixc=5 with broadened plasmon HL selfenergy
c              vr0 is const imag part of potential
c              vi0 is const imag part of potential
c              Default is HL. (ixc=0, vr0=0, vi0=0)
               read(words(2),20,err=900)  ixc
               read(words(3),30,err=900)  vr0
               read(words(4),30,err=900)  vi0
               if (ixc .eq. 4) read(words(5),30,err=900)  rs0
               if (ixc .ge. 3)  call warnex(' EXCHANGE >= 3:')
               mode = 0
            elseif (itok .eq. 6)  then
c              ION  iph xionph(iph)
               read(words(2),20,err=900)  iph
               call phstop(iph,line)
               read(words(3),30,err=900)  xionph(iph)
               call warnex(' ION:')
               mode = 0
            elseif (itok .eq. 7)  then
c              TITLE title...
               ntitle = ntitle + 1
               if (ntitle .le. ntitx)  then
                  title(ntitle) = line(6:)
                  call triml (title(ntitle))
               else
                  call wlog(' Too many title lines, title ignored')
                  call wlog(' ' // line(1:71))
               endif
               mode = 0
            elseif (itok .eq. 8)  then
c              FOLP iph folp (overlap factor, default 1)
               read(words(2),20,err=900)  iph
               call phstop(iph,line)
               read(words(3),30,err=900)  folp(iph)
               call warnex(' FOLP:')
               mode = 0
            elseif (itok .eq. 9)  then
c              RMAX  rmax (max r for ss and pathfinder)
               read(words(2),30,err=900)  rmax
               mode = 0
            elseif (itok .eq. 10)  then
c              DEBYE  temp debye-temp
c                   temps in kelvin
c                   These add to any sig2 from SIG2 card or files.dat
               read(words(2),30,err=900)  tk
               read(words(3),30,err=900)  thetad
               mode = 0
            elseif (itok .eq. 11)  then
c              RMULTIPLIER  rmult
c              Multiples atom coord, rss, overlap and rmax distances by
c              rmult (default 1).  DOES NOT modify sig2g
               read(words(2),30,err=900)  rmult
               mode = 0
            elseif (itok .eq. 12)  then
c              SS index ipot deg rss
               nss = nss + 1
               if (nss .gt. nssx)  then
                  write(slog,'(a,i8)')
     1               ' Too many ss paths requested, max is ', nssx
                  call wlog(slog)
                  stop 'RDINP'
               endif
               read(words(2),20,err=900)  indss(nss)
               read(words(3),20,err=900)  iphss(nss)
               read(words(4),30,err=900)  degss(nss)
               read(words(5),30,err=900)  rss(nss)
               mode = 0
            elseif (itok .eq. 13)  then
c              PRINT  ipr1  ipr2  ipr3  ipr4
c              print flags for various modules
c              ipr1 potph  0 phase.bin only
c                          1 add misc.dat
c                          2 add pot.dat, phase.dat
c                          5 add atom.dat
c                          6 add central atom dirac stuff
c                          7 stop after doing central atom dirac stuff
c              ipr2 pathfinder  0 paths.dat only
c                               1 add crit.dat
c                               2 keep geom.dat
c                               3 add fbeta files
c                               5 special magic code, crit&geom only
c                                 not paths.dat.  Use for path studies
c              ipr3 genfmt 0 files.dat, feff.dats that pass 2/3 of
c                            curved wave importance ratio
c                          1 keep all feff.dats
c              ipr4 ff2chi 0 chi.dat
c                          1 add sig2.dat with debye waller factors
c                          2 add chipnnnn.dat for each path
c                          3 add feffnnnn.dat for each path, and
c                            do not add chipnnnn.dat for each path
c                          4 add both feffnnnn.dat and chipnnnn.dat
c                            for each path
               read(words(2),20,err=900)  ipr1
               read(words(3),20,err=900)  ipr2
               read(words(4),20,err=900)  ipr3
               read(words(5),20,err=900)  ipr4
               mode = 0
            elseif (itok .eq. 14)  then
c              POTENTIALS
c              Following lines are unique potential defs, 1 per line
               mode = 3
            elseif (itok .eq. 15)  then
c              NLEG nlegmax (for pathfinder)
               read(words(2),20,err=900)  nlegxx
               mode = 0
            elseif (itok .eq. 16)  then
c              REQUIRE rreq, ipot (for pathfinder, require than ms paths
c                            length >rreq contain atom ipot)
               call wlog(' REQUIRE no longer available')
               stop
            elseif (itok .eq. 17)  then
c              KLIMIT xkmin, xkmax
               call wlog(' KLIMIT no longer available, run continues.')
               call wlog(' Use NEMAX instead')
               mode = 0
            elseif (itok .eq. 18)  then
c              CRIT critcw critpw
               read(words(2),30,err=900)  critcw
               read(words(3),30,err=900)  critpw
               mode = 0
            elseif (itok .eq. 19)  then
c              NOGEOM (do not write geom.dat)
               nogeom = .true.
               mode = 0
            elseif (itok .eq. 20)  then
c              CSIG (use complex momentum with debye waller factor)
c              note: this is always on anyway, so this card unnecessary
               icsig = 1
               mode = 0
            elseif (itok .eq. 21)  then
c              IORDER  iorder (used in genfmt, see setlam for meaning)
               read(words(2),20,err=900)  iorder
               call warnex(' IORDER:')
               mode = 0
            elseif (itok .eq. 22)  then
c              PCRIT  pcritk pcrith
c                     (keep and heap criteria for pathfinder)
               read(words(2),30,err=900)  pcritk
               read(words(3),30,err=900)  pcrith
               mode = 0
            elseif (itok .eq. 23)  then
c              SIG2  sig2g   global sig2 used by ff2chi, summed with
c              correlated debye model if DEBYE card used, and with
c              sig2 from files.dat if non-zero.
c              Units are Ang**2
               read(words(2),30,err=900)  sig2g
               mode = 0
            elseif (itok .eq. 24)  then
c              XANES
c              Use extended k range for xanes
               ixanes = 1
               methat = 0
               methfs = 2
c              to avoid problems with debye waller factors below the
c              edge, always use complex p for debye waller
               icsig = 1
               call warnex(' XANES:')
               call wlog(' CORRECTIONS and other cards may be' //
     1                   ' needed.  See FEFF7 document for')
               call wlog(' details and a discussion of approximations.')
               mode = 0
            elseif (itok .eq. 25)  then
c              CORRECTIONS  e0-shift, lambda correction
c              e0 shift is in eV, edge will be edge-e0
c              lambda corr is a const imag energy in eV
c              e0 and lambda corr same as vr0 and vi0 in EXCH card
               read(words(2),30,err=900)  vrcorr
               read(words(3),30,err=900)  vicorr
               mode = 0
            elseif (itok .eq. 26)  then
c              AFOLP use generalized automatic folp
               iafolp = 1
               mode =0
            elseif (itok .eq. 27)  then
c              NEMAX  nemax for energy grid
               read(words(2),20,err=900)  nemax
               if (nemax .gt. nex)  then
                  write(slog,'(a, 2i8)')
     1              ' nemax too big, nemax, nex, ', nemax, nex
                  nemax = nex
                  write(slog,'(a,i8)') 'nemax reset to ', nemax
               endif
               mode = 0
            elseif (itok .eq. 28)  then
c              INTCALC  intclc
c              0  use average over all atoms
c              1  use current experimental method 1
c              2  use current experimental method 2
c              read(words(2),20,err=900)  intclc
               call wlog(' INTCALC not implemented -- card ignored.')
               mode = 0
            elseif (itok .eq. 29)  then
c              POLARIZATION  X Y Z
               pola = 1
c              run polarization code if 'pola' is true
c              run usual feff otherwise
               read(words(2),30,err=900)  evec(1)
               read(words(3),30,err=900)  evec(2)
               read(words(4),30,err=900)  evec(3)
               mode = 0
            elseif (itok .eq. 30)  then
c              ELLIPTICITY  E incident direction
               read(words(2),30,err=900)  elpty
               read(words(3),30,err=900)  xivec(1)
               read(words(4),30,err=900)  xivec(2)
               read(words(5),30,err=900)  xivec(3)
               mode = 0
            elseif (itok .eq. 31)  then
c              CUSTOMCRIT  zzcrit  zzkmin  zzkmax
c              zzcrit is percent of most important path so far
c              zzkmin and zzkmax in invA
               read(words(2),30,err=900)  zzcrit
               read(words(3),30,err=900)  zzkmin
               read(words(4),30,err=900)  zzkmax
               call warnex(' CUSTOMCRITERIA:')
c              ff2chi uses code units, so convert k here
               zzkmin = zzkmin * bohr
               zzkmax = zzkmax * bohr
               mode = 0
            elseif (itok .eq. 32)  then
c              RGRID  rgrd
c              rgrd will be dpas, default is 0.03 in feff7
               read(words(2),30,err=900)  rgrd
               call warnex(' RGRID:')
               write(slog,'(a,1pe13.5)') ' RGRID, rgrd; ', rgrd
               call wlog(slog)
               mode = 0
            elseif (itok .eq. 33)  then
c              RPHASES (real phase shifts only)
               call warnex(' RPHASES:')
               call wlog(' Real phase shifts only will be used.  ' //
     1                   'FEFF results will be unreliable.')
               lreal = .true.
               mode = 0
            elseif (itok .eq. 34)  then
c              NSTAR, write out n* for colinear polarization
               wnstar = .true.
               mode = 0
            elseif (itok .eq. 35)  then
c              NOHOLE
               nohole = .true.
               call warnex(' NOHOLE:')
            elseif (itok .eq. 36)  then
c              SIG3 alphat   first and third cumulants for ss paths
               read(words(2),30,err=900)  alphat
               call warnex(' SIG3:')
               write(slog,'(a,1pe13.5)') ' SIG3, alphat ; ', alphat
               call wlog(slog)
               mode = 0
            elseif (itok .eq. 37)  then
c              JUMPRM remove potential jumps at muffin tin radii
               jumprm = 1
            elseif (itok .eq. 38)  then
c              MBCONV do many body convolution with excitation spectrum
               mbconv = 1
            elseif (itok .eq. 39)  then
c              SPIN  specifies spin direction on central atom
               read(words(2),20,err=900)  ispin
               if (ispin.eq.0) stop 'specify SPIN'
               if (ispin .gt. 0) then
                  pola = 2*ispin
               else
                  pola = -2*ispin + 1
               endif
            elseif (itok .eq. 40)  then
c              EDGE     L3  1.0
c                   holecode s02
               call setedg (words(2), ihole)
               read(words(3),30,err=900)  s02
               mode = 0
            elseif (itok .eq. -1)  then
c              END
               goto 220
            else
               write(slog,'(1x,a)') line(1:70)
               call wlog(slog)
               write(slog,'(1x,a)') words(1)
               call wlog(slog)
               write(slog,'(a,i8)') ' Token ', itok
               call wlog(slog)
               call wlog(' Keyword unrecognized.')
               call wlog(' See FEFF document -- some old features')
               call wlog(' are no longer available.')
               stop 'RDINP-2'
            endif
         elseif (mode .eq. 1)  then
            if (itok .ne. 0)  then
c              We're done reading atoms.
c              Change mode and process current card.
               mode = 0
               goto 210
            endif
            nat = nat+1
            if (nat .gt. natx)  then
               write(slog,'(a,i8)') 'Too many atoms, max is ', natx
               call wlog(slog)
               stop 'RDINP-3'
            endif
            read(words(1),30,err=900)  rat(1,nat)
            read(words(2),30,err=900)  rat(2,nat)
            read(words(3),30,err=900)  rat(3,nat)
            read(words(4),20,err=900)  iphat(nat)
         elseif (mode .eq. 2)  then
            if (itok .ne. 0)  then
c              We're done reading these overlap instructions.
c              Change mode and process current card.
               mode = 0
               goto 210
            endif
            novr(iph) = novr(iph)+1
            iovr = novr(iph)
            if (iovr .gt. novrx)  then
               write(slog,'(a,i8)') 'Too many overlap shells, max is ',
     1                               novrx
               call wlog(slog)
               stop 'RDINP-5'
            endif
            read(words(1),20,err=900) iphovr(iovr,iph)
            read(words(2),20,err=900) nnovr(iovr,iph)
            read(words(3),30,err=900) rovr(iovr,iph)
         elseif (mode .eq. 3)  then
            if (itok .ne. 0)  then
c              We're done reading unique potential definitions
c              Change mode and process current card.
               mode = 0
               goto 210
            endif
            read(words(1),20,err=900)  iph
            if (iph .lt. 0  .or.  iph .gt. nphx)  then
               write(slog,'(a,i8)')
     1             'Unique potentials must be between 0 and ',
     1             nphx
               call wlog(slog)
               write(slog,'(i8,a)') iph, ' not allowed'
               call wlog(slog)
               write(slog,'(1x,a)') line(1:71)
               call wlog(slog)
               stop 'RDINP'
            endif
            read(words(2),20,err=900)  izph(iph)
c           No potential label if user didn't give us one
c           Default set above is potlbl=' '
            if (nwords .ge. 3)  potlbl(iph) = words(3)
         else
            write(slog,'(a,i8)') 'Mode unrecognized, mode ', mode
            call wlog(slog)
            stop 'RDINP-6'
         endif
      goto 200
  220 continue

c     We're done reading the input file, close it.
      close (unit=1)

c     Fix up defaults, error check limits, figure out free atoms, etc.

c     need smaller rgrid for nonlocal exchange
      if (mod(ixc,10).ge.5 .and. rgrd.gt.0.03) rgrd=0.03d0
      if (pola.eq.1) then
c        make polarization tensor
         call mkptz
      endif
c     must use linear polarization to use nstar
      if (wnstar)  then
         if (pola.ne.1  .or.  elpty .ne. 0)  then
            call wlog(' Must have linear polarization to use NSTAR.')
            call wlog(' NSTAR will be turned off.')
            wnstar = .false.
         endif
      endif

c     Find out how many unique potentials we have
      nph = 0
      do 300  iph = nphx, 0, -1
         if (izph(iph) .gt. 0)  then
            nph = iph
            goto 301
         endif
  300 continue
  301 continue
c     Must have central atom
      if (izph(0) .le. 0)  then
         call wlog(' No absorbing atom (unique pot 0) was defined.')
         stop 'RDINP'
      endif
c     Find central atom (only 1 permitted)
      iatabs = -1
      do 400  iat = 1, nat
         if (iphat(iat) .eq. 0)  then
            if (iatabs .lt. 0)  then
               iatabs = iat
            else
               call wlog(' More than one absorbing atom (potential 0)')
               call wlog(' Only one absorbing atom allowed')
               stop 'RDINP'
            endif
         endif
  400 continue

c     Then find model atoms for unique pots that have them
c     Use atom closest to absorber for model
      do 330  iph = 0, nphx
         rabs = big
         do 320  iat = 1, nat
            if (iph .eq. iphat(iat))  then
               tmp = dist (rat(1,iat), rat(1,iatabs))
               if (tmp .lt. rabs)  then
c                 this is the closest so far
                  rabs = tmp
                  iatph(iph) = iat
               endif
            endif
  320    continue
  330 continue
c     if iatph > 0, a model atom has been found.

c     No gaps allowed in unique pots.  Make sure we have enough
c     to overlap all unique pots 0 to nph.
      do 340  iph = 0, nph
         if (iatph(iph) .le. 0  .and.  novr(iph) .le. 0)  then
c           No model atom, no overlap cards, can't do this unique pot
            write(slog,'(a,i8)')
     1       ' No atoms or overlap cards for unique pot ', iph
            call wlog(slog)
            call wlog(' Cannot calculate potentials, etc.')
            stop 'RDINP-'
         endif
  340 continue

c     Need number of atoms of each unique pot, count them.  If none,
c     set to one.
      do 350  iph = 0, nph
         xnatph(iph) = 0
         do 346  iat = 1, nat
            if (iphat(iat) .eq. iph)  xnatph(iph) = xnatph(iph)+1
  346    continue
         if (xnatph(iph) .le. 0)  xnatph(iph) = 1
  350 continue

c     Do the free atom shuffling, do central atom as special case
      iz(0) = izph(0)
      xion(0) = xionph(0)
      ifrph(0) = 0
      nfr = 0
      do 390  iph = 1, nph
         ifrph(iph) = -1
         do 380  ifr = 1, nfr
           if (iz(ifr).eq.izph(iph) .and. xion(ifr).eq.xionph(iph)) then
              ifrph(iph) = ifr
              goto 381
           endif
  380    continue
  381    continue
c        add free atom type if necessary
         if (ifrph(iph) .lt. 0)  then
            nfr = nfr+1
            if (nfr .gt. nfrx)  then
               write(slog,'(a,i8)')' Too many free atoms, max is', nfrx
               call wlog(slog)
               stop 'RDINP10'
            endif
            xion(nfr) = xionph(iph)
            iz(nfr) = izph(iph)
            ifrph(iph) = nfr
         endif
  390 continue


c     Find distance to nearest and most distant atom (use overlap card
c     if no atoms specified.)
      if (iatabs .lt. 0  .or.  nat .lt. 2)  then
         ratmin = rovr(1,0)
         ratmax = rovr(novr(0),0)
      else
         ratmax = 0
         ratmin = 1.0e10
         do 412  iat = 1, nat
c           skip absorbing atom
            if (iat .eq. iatabs)  goto 412
            tmp = dist (rat(1,iat), rat(1,iatabs))
            if (tmp .gt. ratmax)  ratmax = tmp
            if (tmp .lt. ratmin)  ratmin = tmp
  412    continue
      endif

c     Set rmax if necessary
      if (rmax.le.0 .and. nss.le.0)  then
c        set to min (2+ times ratmin, ratmax) (magic numbers to
c        avoid roundoff, note that rmax is single precision).
         rmax = min (2.2 * ratmin, 1.01 * ratmax)
      endif

c     Set core hole lifetime (central atom quantity)
      ifr = ifrph(0)
      call setgam (iz(ifr), ihole, gamach)

c     Convert everything to code units, and use rmult factor
c     rmax is for pathfinder, so leave it in Ang.
      rmax = rmax * rmult
      vr0 = vr0 / ryd
      vi0 = vi0 / ryd
      vrcorr = vrcorr / ryd
      vicorr = vicorr / ryd
      xloss = gamach/2 + vi0
      xkmin = xkmin * bohr
      xkmax = xkmax * bohr
      do 430  iat = 1, nat
         do 420  i = 1, 3
            rat(i,iat) = rat(i,iat) * rmult / bohr
  420    continue
  430 continue
      do 460  iph = 0, nph
         do 450  iovr = 1, novr(iph)
            rovr(iovr,iph) = rovr(iovr,iph) * rmult / bohr
  450    continue
  460 continue
      do 462  iss = 1, nss
c        rss used only to make paths.dat, so leave it in Angstroms.
         rss(iss) = rss(iss) * rmult
  462 continue

c     Check if 2 atoms are closer together than 1.75 ryd (~.93 Ang)
      ratmin = 1.0e20
      do 480  iat = 1, nat
         do 470  jat = iat+1, nat
            rtmp = dist(rat(1,iat),rat(1,jat))
            if (rtmp .lt. ratmin)  ratmin = rtmp
            if (rtmp .lt. 1.75)  then
c           if (dist(rat(1,iat),rat(1,jat)) .lt. 1.5)  then
               call wlog(' WARNING:  TWO ATOMS VERY CLOSE TOGETHER.' //
     1                   '  CHECK INPUT.')
               write(slog,'(a,2i8)') ' atoms ', iat, jat
               call wlog(slog)
               write(slog,'(i5,1p,3e13.5)') iat, (rat(i,iat)*bohr,i=1,3)
               call wlog(slog)
               write(slog,'(i5,1p,3e13.5)') jat, (rat(i,jat)*bohr,i=1,3)
               call wlog(slog)
               call wlog(' Run continues in case you really meant it.')
            endif
  470    continue
  480 continue

c     Clean up control flags
      if (mphase .ne. 0)  mphase = 1
      if (mpath  .ne. 0)  mpath = 1
      if (mfeff  .ne. 0)  mfeff = 1
      if (mchi   .ne. 0)  mchi = 1
      if (nss    .le. 0)  ms = 1

      if (ntitle .le. 0)  then
         ntitle = 1
         title(1) = 'Null title'
      endif
      do 490  i = 1, ntitle
         ltit(i) = istrln (title(i))
  490 continue

c     Write output files

c     For potph...
      if (mphase .eq. 1)  then
         open (unit=1, file='potph.dat', status='unknown', iostat=ios)
         call chopen (ios, 'potph.dat', 'rdinp')
         do 705  i = 1, ntitle
            write(1,700)  title(i)(1:ltit(i))
  700       format (1x, a)
  705    continue
         write(1,706)
  706    format (1x, 71('-'))
         write(1,709) ihole, gamach, ipr1, iafolp, intclc
  709    format(i5, 1p, e14.6, 3i4,
     1         ' ihole, gamach, iprint, iafolp, intclc')
         write(1,702)  ixc, vr0, vi0, rs0
  702    format (i5, 1p, 3e14.6, ' ixc, vr0, vi0, rs0')
         write(1,701)  ixanes, nemax, xkmin, xkmax
  701    format (2i5, 1p, 2e14.6,
     1           ' ixanes, nemax, xkmin, xkmax (inv bohr)')
         write(1,703)  methat, methfs, jumprm, mbconv
  703    format (4i5,  ' methat, methfs, jumprm, mbconv')
         write(1,707) nfr, '  nfr'
  707    format (i5, a)
         do 710  ifr = 0, nfr
            write(1,708)  ifr, iz(ifr), xion(ifr)
  708       format (2i5,f7.3, ' ifr, iz, ion')
  710    continue
         write(1,707) nat, '  nat.   iat, iph, x, y, z'
         do 720  iat = 1, nat
            write(1,715) iat, iphat(iat), (rat(j,iat),j=1,3)
  715       format (2i5, 3f12.6)
  720    continue
         write(1,707) nph, '  nph'
         do 740  iph = 0, nph
            write(1,722) iph, iatph(iph), ifrph(iph), xnatph(iph),
     1                   folp(iph), novr(iph),
     2                   ' iph, iat, ifr, xnat, folp, novr'
  722       format (3i5, 2f12.6, i5, a)
            write(1,723) potlbl(iph)
  723       format (' ''', a6, '''  potlbl')
            do 730  iovr = 1, novr(iph)
               write(1,724) iphovr(iovr,iph), nnovr(iovr,iph),
     1                      rovr(iovr,iph),
     2                      ' ovr...  iph, n, r'
  724       format (2i5, f12.6, a)
  730       continue
  740    continue
         close (unit=1)
      endif

c     Single scattering paths for genfmt
      if (nss .gt. 0  .and.  mpath .eq. 1)  then
         open (unit=1, file='paths.dat', status='unknown', iostat=ios)
         call chopen (ios, 'paths.dat', 'rdinp')
         do 750  i = 1, ntitle
            write(1,748)  title(i)(1:ltit(i))
  748       format (1x, a)
  750    continue
         write(1,751)
  751    format (' Single scattering paths from ss lines cards',
     1           ' in feff input')
         write(1,706)
         do 760  iss = 1, nss
            if (rmax.le.0  .or.  rss(iss).le.rmax)  then
c              NB, rmax and rss are in angstroms
               write(1,752) indss(iss), 2, degss(iss),
     2              rss(iss)
  752          format ( 2i4, f8.3,
     1             '  index,nleg,degeneracy,r=', f8.4)
               write(1,766)
  766          format (' single scattering')
               write(1,754) rss(iss), zero, zero, iphss(iss),
     1                      potlbl(iphss(iss))
               write(1,753) zero, zero, zero, 0, potlbl(0)
  753          format (3f12.6, i4,  1x, '''', a6, '''', '  x,y,z,ipot')
  754          format (3f12.6, i4,  1x, '''', a6, '''')
            endif
  760    continue
         close (unit=1)
      endif

c     Atoms for the pathfinder
      if (nss.le.0  .and.  mpath.eq.1  .and.  nat.gt.0)  then
         if (iatabs .le. 0)  then
            call wlog(' Absorbing atom coords not specified.')
            call wlog(' Cannot find multiple scattering paths.')
            stop 'RDINP'
         endif
c        if user doesn't want geom.dat, don't do it
         if (nogeom)  then
c           don't delete geom.dat when done with it either...
            if (ipr2 .lt. 2)  ipr2 = 2
         else
            open (unit=1, file='geom.dat', status='unknown', iostat=ios)
            call chopen (ios, 'geom.dat', 'rdinp')
c           Echo title cards to geom.dat
            do 770  i = 1, ntitle
               write(1,700)  title(i)(1:ltit(i))
  770       continue
            write(1,706)
c           Central atom first
            ii = 0
            write(1,780)  ii, (rat(j,iatabs)*bohr,j=1,3), 0, 1
c           Rest of the atoms (skip central atom)
            do 790   iat = 1, nat
               if (iat .eq. iatabs)  goto 790
               ii = ii+1
               write(1,780)  ii, (rat(j,iat)*bohr,j=1,3), iphat(iat), 1
  780       format (i4, 3f12.6, 2i4)
  790       continue
            close (unit=1)
         endif
      endif

      return

  900 continue
      call wlog(' Error reading input, bad line follows:')
      write(slog,'(1x,a)') line(1:71)
      call wlog(slog)
      stop 'RDINP fatal error.'

      end

      function itoken (word)
c     chars in word assumed upper case, left justified
c     returns 0 if not a token, otherwise returns token

      character*(*) word
      character*4   w

      w = word(1:4)
      call upper(w)
      if     (w .eq. 'ATOM')  then
         itoken = 1
      elseif (w .eq. 'HOLE')  then
         itoken = 2
      elseif (w .eq. 'OVER')  then
         itoken = 3
      elseif (w .eq. 'CONT')  then
         itoken = 4
      elseif (w .eq. 'EXCH')  then
         itoken = 5
      elseif (w .eq. 'ION ')  then
         itoken = 6
      elseif (w .eq. 'TITL')  then
         itoken = 7
      elseif (w .eq. 'FOLP')  then
         itoken = 8
      elseif (w .eq. 'RMAX')  then
         itoken = 9
      elseif (w .eq. 'DEBY')  then
         itoken = 10
      elseif (w .eq. 'RMUL')  then
         itoken = 11
      elseif (w .eq. 'SS  ')  then
         itoken = 12
      elseif (w .eq. 'PRIN')  then
         itoken = 13
      elseif (w .eq. 'POTE')  then
         itoken = 14
      elseif (w .eq. 'NLEG')  then
         itoken = 15
      elseif (w .eq. 'REQU')  then
         itoken = 16
      elseif (w .eq. 'KLIM')  then
         itoken = 17
      elseif (w .eq. 'CRIT')  then
         itoken = 18
      elseif (w .eq. 'NOGE')  then
         itoken = 19
      elseif (w .eq. 'CSIG')  then
         itoken = 20
      elseif (w .eq. 'IORD')  then
         itoken = 21
      elseif (w .eq. 'PCRI')  then
         itoken = 22
      elseif (w .eq. 'SIG2')  then
         itoken = 23
      elseif (w .eq. 'XANE')  then
         itoken = 24
      elseif (w .eq. 'CORR')  then
         itoken = 25
      elseif (w .eq. 'AFOL')  then
         itoken = 26
      elseif (w .eq. 'NEMA')  then
         itoken = 27
      elseif (w .eq. 'INTC')  then
         itoken = 28
      elseif (w .eq. 'POLA')  then
         itoken = 29
      elseif (w .eq. 'ELLI')  then
         itoken = 30
      elseif (w .eq. 'CUST')  then
         itoken = 31
      elseif (w .eq. 'END ')  then
         itoken = -1
      elseif (w .eq. 'RGRI')  then
         itoken = 32
      elseif (w .eq. 'RPHA')  then
         itoken = 33
      elseif (w .eq. 'NSTA')  then
         itoken = 34
      elseif (w .eq. 'NOHO')  then
         itoken = 35
      elseif (w .eq. 'SIG3')  then
         itoken = 36
      elseif (w .eq. 'JUMP')  then
         itoken = 37
      elseif (w .eq. 'MBCO')  then
         itoken = 38
      elseif (w .eq. 'SPIN')  then
         itoken = 39
      elseif (w .eq. 'EDGE')  then
         itoken = 40
      else
         itoken = 0
      endif
      return
      end
      logical function iscomm (line)
c     returns true if line is a comment or blank line, false otherwise
      character*(*) line
      iscomm = .false.
      if (istrln(line).le.0  .or.  line(1:1).eq.'*')  iscomm = .true.
      return
      end
      subroutine phstop (iph,line)
      implicit double precision (a-h, o-z)
      character*(*) line
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      character*512 slog
      if (iph .lt. 0  .or.  iph .gt. nphx)  then
         write(slog,10) iph, nphx, line
         call wlog(slog)
   10    format (' Unique potential index', i5, ' out of range.',
     1           ' Must be between 0 and', i5, '.  Input line:',
     2           1x, a)
         stop 'RDINP - PHSTOP'
      endif
      return
      end
      subroutine warnex (string)
      implicit double precision (a-h, o-z)
c     This prints a warning message if the user is using an
c     expert option.
      character*(*) string

      call wlog(string)
      call wlog(' Expert option, please read documentation ' //
     1          'carefully and check your results.')
      return
      end
      subroutine rdpath (in, done)
      implicit double precision (a-h, o-z)
      logical done

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola

      complex*16  alph, gamm
      dimension  alpha(0:legtot), gamma(legtot)
      character*512 slog

      read(in,*,end=200)  ipath, nleg, deg
      if (nleg .gt. legtot)  then
         write(slog,'(a,2i6)')
     1         ' nleg .gt. legtot, nleg, legtot ', nleg, legtot
         call wlog(slog)
         call wlog(' ERROR')
         goto 200
      endif
c     skip label (x y z ipot rleg beta eta)
      read(in,*)
      do 20  ileg = 1, nleg
         read(in,*,end=999)  (rat(j,ileg),j=1,3), ipot(ileg),
     1                       potlbl(ipot(ileg))
c        convert to code units
         do 10  j = 1, 3
            rat(j,ileg) = rat(j,ileg)/bohr
   10    continue
         if (ipot(ileg) .gt. npot)  then
            write(slog,'(a,3i8)')
     1              ' ipot(ileg) too big, ipot, ileg, npot ',
     1               ipot(ileg), ileg, npot
            call wlog(' ERROR')
            goto 200
         endif
   20 continue
      nsc = nleg-1

c     We need the 'z' atom so we can use it below.  Put
c     it in rat(nleg+1).  No physical significance, just a handy
c     place to put it.
      if (pola.eq.1) then
         rat(1,nleg+1) = rat(1,nleg)
         rat(2,nleg+1) = rat(2,nleg)
         rat(3,nleg+1) = rat(3,nleg) + 1.0
      endif

c     add rat(0) and ipot(0) (makes writing output easier)
      do 22 j = 1, 3
         rat(j,0) = rat(j,nleg)
   22 continue
      ipot(0) = ipot(nleg)

      nangle = nleg
      if (pola.eq.1) then
c        in polarization case we need one more rotation
         nangle = nleg + 1
      endif
      do 100  j = 1, nangle

c        for euler angles at point i, need th and ph (theta and phi)
c        from rat(i+1)-rat(i)  and  thp and php
c        (theta prime and phi prime) from rat(i)-rat(i-1)
c
c        Actually, we need cos(th), sin(th), cos(phi), sin(phi) and
c        also for angles prime.  Call these  ct,  st,  cp,  sp

c        i = (j)
c        ip1 = (j+1)
c        im1 = (j-1)
c        except for special cases...
         ifix = 0
         if (j .eq. nsc+1)  then
c           j+1 'z' atom, j central atom, j-1 last path atom
            i = 0
            ip1 = 1
            if (pola.eq.1) then
               ip1 = nleg+1
            endif
            im1 = nsc

         elseif (j .eq. nsc+2)  then
c           j central atom, j+1 first path atom, j-1 'z' atom
            i = 0
            ip1 = 1
            im1 = nleg+1
            ifix = 1
         else
            i = j
            ip1 = j+1
            im1 = j-1
         endif

         x = rat(1,ip1) - rat(1,i)
         y = rat(2,ip1) - rat(2,i)
         z = rat(3,ip1) - rat(3,i)
         call trig (x, y, z, ctp, stp, cpp, spp)
         x = rat(1,i) - rat(1,im1)
         y = rat(2,i) - rat(2,im1)
         z = rat(3,i) - rat(3,im1)
         call trig (x, y, z, ct, st, cp, sp)

c        Handle special case, j=central atom, j+1 first
c        path atom, j-1 is 'z' atom.  Need minus sign
c        for location of 'z' atom to get signs right.
         if (ifix .eq. 1)  then
            x = 0
            y = 0
            z = 1.0
            call trig (x, y, z, ct, st, cp, sp)
            ifix = 0
         endif

c        cppp = cos (phi prime - phi)
c        sppp = sin (phi prime - phi)
         cppp = cp*cpp + sp*spp
         sppp = spp*cp - cpp*sp
         phi  = atan2(sp,cp)
         phip = atan2(spp,cpp)

c        alph = exp(i alpha)  in ref eqs 18
c        beta = cos (beta)
c        gamm = exp(i gamma)
         alph = -(st*ctp - ct*stp*cppp - coni*stp*sppp)
         beta(j) = ct*ctp + st*stp*cppp
c        watch out for roundoff errors
         if (beta(j) .lt. -1) beta(j) = -1
         if (beta(j) .gt.  1) beta(j) =  1
         gamm = -(st*ctp*cppp - ct*stp + coni*st*sppp)
         call arg(alph,phip-phi,alpha(j))
         beta(j) = acos(beta(j))
         call arg(gamm,phi-phi,gamma(j))
c       Convert from the rotation of FRAME used before to the rotation
c       of VECTORS used in ref.
         dumm = alpha(j)
         alpha(j) =  pi- gamma(j)
         gamma(j) =  pi- dumm

         if (j .le. nleg)  then
            ri(j) = dist (rat(1,i), rat(1,im1))
         endif
  100 continue

c     Make eta(i) = alpha(i-1) + gamma(i).
c     We'll need alph(nangle)=alph(0)
      alpha(0) = alpha(nangle)
      do 150  j = 1, nleg
         eta(j) = alpha(j-1) + gamma(j)
  150 continue
      if (pola.eq.1) then
         eta(0) = gamma(nleg+1)
         eta(nleg+1) = alpha(nleg)
      endif

c     eta and beta in radians at this point.
      done = .false.
      return

c     If no more data, tell genfmt we're done
  200 continue
      done = .true.
      return

c     If unexpected end of file, die
  999 continue
      call wlog(' Unexpected end of file')
      stop 'ERROR'
      end
      subroutine trig (x, y, z, ct, st, cp, sp)
      implicit double precision (a-h, o-z)
c     returns cos(theta), sin(theta), cos(phi), sin(ph) for (x,y,z)
c     convention - if x=y=0 and z>0, phi=0, cp=1, sp=0
c                  if x=y=0 and z<0, phi=180, cp=-1,sp=0
c                - if x=y=z=0, theta=0, ct=1, st=0
      parameter (eps = 1.0e-6)
      r = sqrt (x**2 + y**2 + z**2)
      rxy = sqrt (x**2 + y**2)
      if (r .lt. eps)  then
         ct = 1
         st = 0
      else
         ct = z/r
         st = rxy/r
      endif
      if (rxy .lt. eps)  then
         cp = 1
         if (ct .lt. 0) cp = -1
         sp = 0
      else
         cp = x / rxy
         sp = y / rxy
      endif
      return
      end
      subroutine arg(c,fi,th)
      implicit double precision (a-h, o-z)
      complex*16  c
      parameter (eps = 1.0e-6)
      x = dble(c)
      y = dimag(c)
      if (abs(x) .lt. eps) x = 0
      if (abs(y) .lt. eps) y = 0
      if (abs(x) .lt. eps  .and.  abs(y) .lt. eps) then
        th = fi
      else
        th = atan2(y,x)
      endif
      return
      end
      subroutine rhlbp (rs, xk, erl, eim)
c     This is a new broadened plasmon hl subroutine,
c     using interpolation for the real and imaginary part.
c     test of multi-pole pole model
c     input:
c        rs - r_s
c        xk - k in a.u.
c     output:
c        erl, eim - Re and Im part of self energy normalized to k_f**2/2

      implicit double precision (a-h,o-z)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      parameter (hart = 2*ryd)
      parameter (nrs=21, nx=51 )
      dimension rsmesh(nrs), xmesh(nx), sigma(nrs,nx,2)
      save ifirst, rsmesh, xmesh, sigma
      data  ifirst /0/

      xf = fa / rs
      ef = xf *xf / 2.
      wp = sqrt (3 / rs**3) / ef
      xk0 = xk / xf
      xx = (xk0 ** 2  - 1) / sqrt(rs)

      if (ifirst .eq. 0) then
c        read self energy for grid points from bphl.dat
         open (unit=2, file='bphl.dat', status='old', iostat=ios)
         call chopen (ios, 'bphl.dat', 'rhlbp')
         xmesh(1) = 0.0
         do 200 irs = 1, nrs
            sigma (irs, 1, 1) = 0.0
            sigma (irs, 1, 2) = 0.0
c           irs correspond to grid in r_s: rs = 10.0**(0.1 * irs)
            do  100 ik = 2, nx
c              xmesh define grid in k-space as follows:
c              xmesh = ((ik-1) / 20.0) * (1.0 + ((ik-1) / 20.0)**4.0)
c              xmesh = (xk**2 - 1) / sqrt (rs)
c              xk = sqrt (xmesh * sqrt(rs) + 1.0)
c              xk = k / k_f
               read(2, *) rsmesh(irs), xmesh(ik),
     1              sigma(irs, ik, 1), sigma(irs, ik, 2)
 100        continue
 200     continue
         ifirst = 1
         close (unit=2)
      endif

c     delev = xdel * ef * hart * rs
      call terp2d (rsmesh, xmesh, sigma(1, 1, 1), nrs, nx, rs, xx, erl)
      call terp2d (rsmesh, xmesh, sigma(1, 1, 2), nrs, nx, rs, xx, eim)
c     transfer to atomic units
      erl = erl / rs / hart
      eim = eim / rs / hart

      call quinn (xk0, rs, wp, ef, ei)
      if (eim .ge. ei)  eim = ei

      return
      end

      subroutine terp2d (x, y, z, nx, ny, x0, y0, z0)
c     Linear interpolation and extrapolation.
c     2d analog of terp.f
      implicit double precision (a-h, o-z)

      dimension x(nx), y(ny), z(nx,ny)

c     Find out between which x points x0 lies
      ix = locat (x0, nx, x)
c     if i < 1, set i=1, if i > n-1, set i=n-1
      ix = max (ix, 1)
      ix = min (ix, nx-1)
      if (x(ix+1) - x(ix) .eq. 0)  stop 'TERP-1'
c     Find out between which y points y0 lies
      iy = locat (y0, ny, y)
c     if i < 1, set i=1, if i > n-1, set i=n-1
      iy = max (iy, 1)
      iy = min (iy, ny-1)
      if (y(iy+1) - y(iy) .eq. 0)  stop 'TERP-1'

      dx = (x0 - x(ix)) / (x(ix+1) - x(ix))
      dy = (y0 - y(iy)) / (y(iy+1) - y(iy))
      z1 = z(ix,iy) +  dx * (z(ix+1,iy) - z(ix,iy))
      z2 = z(ix,iy) +  dx * (z(ix+1,iy) - z(ix,iy))
      z0 = z1 + dy * (z2 - z1)

      return
      end
      subroutine rhl (rs, xk, erl, eim)
      implicit double precision (a-h, o-z)

c     input:  rs, xk
c     output: erl, eim

c     This is a new hl subroutine, using interpolation for the
c     real part while the imaginary part is calculated analytically.
c     It uses hl to calculate values at the mesh points for the inter-
c     polation of the real part. The imaginary part is calculated
c     using subroutine imhl.
c
c     written by jose mustre
c     polynomial in rs has a 3/2 power term. j.m.


c     for the right branch the interpolation has the form:
c     hl(rs,x) = e/x + f/x**2 + g/x**3
c     where e is known and
c        f = sum (i=1,3) ff(i) rs**(i+1)/2
c        g = sum (i=1,3) gg(i) rs**(i+1)/2
c
c
c     lrs=number of rs panels, in this case one has 4 panels
c     nrs=number of standard rs values, also order of rs expansion
c     if you change nrs you need to change the expansion of hl
c     in powers of rs that only has 3 terms!
c     nleft=number of coefficients for x<x0
c     nright=number of coefficients for x>x0

      parameter (lrs=4, nrs=3, nleft=4, nright=2)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

      dimension cleft(nleft), cright(nright)

      dimension rcfl(lrs,nrs,nleft), rcfr(lrs,nrs,nright)
      data rcfr/-0.173963d+00,-0.173678d+00,-0.142040d+00,-0.101030d+00,
     1     -0.838843d-01,-0.807046d-01,-0.135577d+00,-0.177556d+00,
     2     -0.645803d-01,-0.731172d-01,-0.498823d-01,-0.393108d-01,
     3     -0.116431d+00,-0.909300d-01,-0.886979d-01,-0.702319d-01,
     4      0.791051d-01,-0.359401d-01,-0.379584d-01,-0.419807d-01,
     5     -0.628162d-01, 0.669257d-01, 0.667119d-01, 0.648175d-01/
      data rcfl/ 0.590195d+02, 0.478860d+01, 0.812813d+00, 0.191145d+00,
     1     -0.291180d+03,-0.926539d+01,-0.858348d+00,-0.246947d+00,
     2      0.363830d+03, 0.460433d+01, 0.173067d+00, 0.239738d-01,
     3     -0.181726d+03,-0.169709d+02,-0.409425d+01,-0.173077d+01,
     4      0.886023d+03, 0.301808d+02, 0.305836d+01, 0.743167d+00,
     5     -0.110486d+04,-0.149086d+02,-0.662794d+00,-0.100106d+00,
     6      0.184417d+03, 0.180204d+02, 0.450425d+01, 0.184349d+01,
     7     -0.895807d+03,-0.318696d+02,-0.345827d+01,-0.855367d+00,
     8      0.111549d+04, 0.156448d+02, 0.749582d+00, 0.117680d+00,
     9     -0.620411d+02,-0.616427d+01,-0.153874d+01,-0.609114d+00,
     1      0.300946d+03, 0.109158d+02, 0.120028d+01, 0.290985d+00,
     2      -0.374494d+03,-0.535127d+01,-0.261260d+00,-0.405337d-01/

c
c     calculate hl using interpolation coefficients
      rkf = fa/rs
      ef  = rkf**2/2
      wp  = sqrt (3/rs**3)
c    quick fix to remove jump at wp in rhl. ala 08.01.95
c    use smooth transition between 2 curves in energy range dwp
      dwp = wp/3.0

      call imhl (rs, xk, eim, icusp)

c     eim already has a factor of ef in it j.m.
c     eim also gives the position of the cusp

      xx = xk / rkf
c     set to fermi level if below fermi level
      if (xx .lt. 1.00001) then
          xx = 1.00001
      endif
c    quick fix to remove jump at wp in rhl. ala 08.01.95
      deltae = ((xx**2-1.0)*ef - wp-dwp)/dwp

c     calculate right hand side coefficients
      if (rs .lt. 0.2) then
         mrs=1
      elseif (rs .lt. 1.0) then
         mrs=2
      elseif (rs .lt. 5.0) then
         mrs=3
      else
         mrs=4
      endif

      do 210 j=1,nright
         cright(j) = rcfr(mrs,1,j)*rs + rcfr(mrs,2,j)*rs*sqrt(rs)
     1               + rcfr(mrs,3,j)*rs**2
  210 continue
      eee=-pi*wp/(4*rkf*ef)

c     if (icusp .ne. 1) then
c    quick fix to remove jump at wp in rhl. ala 08.01.95
      if (icusp .ne. 1 .or. abs(deltae).lt.1.0) then

         do 230 j=1,nleft
            cleft(j) = rcfl(mrs,1,j)*rs + rcfl(mrs,2,j)*rs**1.5
     1                 + rcfl(mrs,3,j)*rs**2
  230    continue
         erl=cleft(1)
         do 250 j=2,nleft
            erl=erl+cleft(j)*xx**(j-1)
  250    continue

c     else
c    quick fix to remove jump at wp in rhl. ala 08.01.95
      endif
      if(icusp .eq. 1 .or. abs(deltae).lt.1.0) then
c        right branch
         erlr=eee/xx
         do 280 j=1,nright
            erlr=erlr+cright(j)/xx**(j+1)
  280    continue
         if (abs(deltae).lt.1.0) then
            if (deltae.lt.0) then
               wr = (1.0 + deltae)**2/2.0
            else
               wr = 1.0 - (1.0-deltae)**2/2.0
            endif
            erl=wr*erlr + (1.0-wr)*erl
         else
            erl= erlr
         endif
      endif

      erl = erl * ef

      return
      end
      subroutine rot3i (lxp1, mxp1, ileg)
      implicit double precision (a-h,o-z)

c     input:  lxp1, mxp1, ileg (lmax+1, mmax+1)
c             also beta(ileg) used from common /pdata/
c     output: dri(...ileg) in common /rotmat/

c     subroutine rot3 calculates rotation matrices for l = 0,lxp1-1

c     subroutine rot3 calculates the beta dependence of rotation
c     matrix elements using recursion of an iterated version of
c     formula (4.4.1) in edmonds.
c
c     first written:(september 17,1986) by j. mustre
c     version 2  (17 sep 86)
c     version 3  (22 feb 87) modified by j. rehr
c     version for genfmt, modified by s. zabinsky, Sept 1991
c     Initialized dri0.  Some elements may be used before being
c        initialized elsewhere -- rot3i needs to be carefully
c        checked.  S. Zabinsky, April 1993
c
c******************** warning******************************************
c     ltot must be at least lxp1 or overwriting will occur
c     nmax must be at least nm or overwriting will occur
c----------------------------------------------------------------------
c     notation dri0(l,m,n) =  drot_i(l'm'n')
c     l = l'+1, n' = n-l, m' = m-l, primes denoting subscripts
c     thus dri0(1,1,1) corresponds to the rotation matrix with
c     l' = 0, and n' and m' = 0; dri0(3,5,5) : l' = 2,n' = 2,m' = 2.
c--------------------------------------------------------------------

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'rotmat.h'
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle
c     dri0 is larger than needed for genfmt, but necessary for
c     this calculation algorithm.  Copy result into smaller
c     dri arrays (in common) at end of this routine.
      dimension  dri0 (ltot+1, 2*ltot+1, 2*ltot+1)

c     initialize dri0
      do 200 il = 1, ltot+1
         do 200 im = 1, 2*ltot+1
            do 200 in = 1, 2*ltot+1
               dri0(il,im,in) = 0
  200 continue

      nm = mxp1
      ndm = lxp1+nm-1
      xc = cos(beta(ileg)/2)
      xs = sin(beta(ileg)/2)
      s = sin(beta(ileg))
      dri0(1,1,1) = 1
      dri0(2,1,1) = xc**2
      dri0(2,1,2) = s/sqrt(2.0d0)
      dri0(2,1,3) = xs**2
      dri0(2,2,1) = -dri0(2,1,2)
      dri0(2,2,2) = cos(beta(ileg))
      dri0(2,2,3) = dri0(2,1,2)
      dri0(2,3,1) = dri0(2,1,3)
      dri0(2,3,2) = -dri0(2,2,3)
      dri0(2,3,3) = dri0(2,1,1)
      do 30  l = 3, lxp1
         ln = 2*l - 1
         lm = 2*l - 3
         if (ln .gt. ndm)  ln = ndm
         if (lm .gt. ndm)  lm = ndm
         do 20  n = 1, ln
            do 10  m = 1, lm
               t1 = (2*l-1-n) * (2*l-2-n)
               t = (2*l-1-m) * (2*l-2-m)
               f1 = sqrt (t1/t)
               f2 = sqrt ((2*l-1-n) * (n-1) / t)
               t3 = (n-2) * (n-1)
               f3 = sqrt(t3/t)
               dlnm = f1 * xc**2 * dri0(l-1,n,m)
               if (n-1 .gt. 0) dlnm = dlnm - f2*s*dri0(l-1,n-1,m)
               if (n-2 .gt. 0) dlnm = dlnm + f3*xs**2*dri0(l-1,n-2,m)
               dri0(l,n,m) = dlnm
               if (n .gt. (2*l-3))
     1            dri0(l,m,n) = (-1)**(n-m) * dri0(l,n,m)
   10       continue
            if (n .gt. (2*l-3)) then
               dri0(l,2*l-2,2*l-2) = dri0(l,2,2)
               dri0(l,2*l-1,2*l-2) = -dri0(l,1,2)
               dri0(l,2*l-2,2*l-1) = -dri0(l,2,1)
               dri0(l,2*l-1,2*l-1) = dri0(l,1,1)
            endif
   20    continue
   30 continue
   40 continue

c-----test sum rule on d
c     open (19,file='rotmat.dat',status='new',carriagecontrol='list')
c     write(19,*)  ' l, m, sum'
c     write(19,*) ' (dri0(il,im,in),in = 1,ln)'
c     do 70 il = 1,lxp1
c        l = il-1
c        ln = 2*l+1
c        if(ln.gt.ndm) ln = ndm
c        do 37 im = 1,ln
c           sum = 0
c           do 50 in = 1,ln
c              m = im-il
c              term = dri0(il,im,in)
c  50       sum = sum+term**2
c           write(19,60) l,m,sum
c           write(19,62) (dri0(il,im,in),in = 1,ln)
c  60       format(2i3,e30.20)
c  62       format(5e14.6)
c  70 continue
c     close(19)
c-----end test------------------------

c     Copy result into dri(...ileg) in /rotmat/ (zero it first...)
      do 90  il = 1, ltot+1
         do 90  m1 = 1, 2*mtot+1
            do 90  m2 = 1, 2*mtot+1
               dri(il,m1,m2,ileg) = 0
   90 continue

      do 120  il = 1, lxp1
         mx = min (il-1, mxp1-1)
         do 110  m1 = -mx, mx
            do 100  m2 = -mx, mx
               dri(il,m1+mtot+1,m2+mtot+1,ileg)=dri0(il,m1+il,m2+il)
  100       continue
  110    continue
  120 continue

      return
      end
      subroutine rphbin (in)
      implicit double precision (a-h, o-z)

c     Reads input from unit in.  Returns (via /pdata/)
c       energy mesh (ne, em and eref),
c       ph (npot, lmax, lmaxp1, ph),
c
c     phmin is min value to use for |phase shift|

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle

      parameter (phmin = 1.0e-8)

c     These header lines do not include carriage control
      read(in) ntext
      do 62  i = 1, ntext
         read(in) text(i)
         read(in) ltext(i)
   62 continue
      read(in) ne, npot, ihole, rnrmav, xmu, edge, ik0, methfs
      read(in) (em(ie),ie=1,ne)
      read(in) (eref(ie),ie=1,ne)
      lmaxp1 = 0
      do 80  iph = 0, npot
         read(in) lmax0, iz(iph)
         read(in) potlbl(iph)
         do 70  ie = 1, ne
            read(in)  (ph(ie,ll,iph), ll=1,lmax0+1)
            lmax(ie,iph) = 0
c           Set lmax to include only non-zero phases
            do 60  il = 1, lmax0+1
               if (abs(ph(ie,il,iph)) .lt. phmin)  goto 61
               lmax(ie,iph) = il-1
   60       continue
   61       continue
            if (lmax(ie,iph)+1 .gt. lmaxp1)  lmaxp1 = lmax(ie,iph)+1
   70    continue
   80 continue

      call setkap( ihole,kinit,linit)
      ilinit = linit + 1
      do 90 k=-1,1
         kp=kinit+k
         if (k.eq.0) kp=-kp
         jkap(k)=abs(kp)
         lkap(k)=kp
         if (kp.le.0) lkap(k)=abs(kp) -1
         ilk(k)=lkap(k)+1
   90 continue

      return
      end
      subroutine rpotph (io, nhead0, head0, lhead0,
     1             nat, nph, nfr, ihole, gamach, iafolp, intclc,
     1             ixc, vr0, vi0, rs0, iphat, rat, iatph, ifrph,
     1             xnatph, novr,
     2             iphovr, nnovr, rovr, folp, xion, iz, iprint,
     2             ixanes, nemax, xkmin, xkmax,
     3             methat, methfs, jumprm, mbcorr, potlbl)
      implicit double precision (a-h, o-z)

c     Notes:
c        nat   number of atoms in problem
c        nph   number of unique potentials
c        nfr   number of unique free atoms
c        ihole hole code of absorbing atom
c        iph=0 for central atom
c        ifr=0 for central atom
c        xkmin, xkmax  min and max energy mesh points to consider

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      character*(*) head0(nhead0)
      dimension lhead0(nhead0)

c     End of line comments removed -- see include file arrays.h for
c     comments.
c     Specific atom input data
      dimension iphat(natx)
      dimension rat(3,natx)

c     Unique potential input data
      dimension iatph(0:nphx)
      dimension ifrph(0:nphx)
      dimension xnatph(0:nphx)
      character*6  potlbl(0:nphx)

      dimension folp(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)

c     Free atom data
      dimension xion(0:nfrx)
      dimension iz(0:nfrx)

c     read and save header from old file, has carriage control char
      head0(1) = ' '
      call rdhead (io, nhead0, head0, lhead0)
      read(io,*) ihole, gamach, iprint, iafolp, intclc
      read(io,*) ixc, vr0, vi0, rs0
      read(io,*) ixanes, nemax, xkmin, xkmax
      read(io,*) methat, methfs, jumprm, mbcorr
      read(io,*) nfr
      do 710  ifr = 0, nfr
         read(io,*)  index, iz(ifr), xion(ifr)
  710 continue
      read(io,*) nat
      do 720  iat = 1, nat
         read(io,*) index, iphat(iat), (rat(j,iat),j=1,3)
  720 continue
      read(io,*) nph
      do 740  iph = 0, nph
         read(io,*) index, iatph(iph), ifrph(iph), xnatph(iph),
     1                folp(iph), novr(iph)
         read(io,*) potlbl(iph)
         do 730  iovr = 1, novr(iph)
            read(io,*) iphovr(iovr,iph), nnovr(iovr,iph),
     1                   rovr(iovr,iph)
  730    continue
  740 continue

      return
      end
      subroutine sclmz (rho, lmaxp1, mmaxp1, ileg)
      implicit double precision (a-h, o-z)

c     Set CLM(Z) for current leg.
c     Makes clm(z) (eq B11).  Fills array clmi in /clmz/ for ileg,
c     elements clm(0,0) -> clm(lmax+1,mmax+1).
c     If mmaxp1 > lmaxp1, fills m only to lmaxp1.

c     calculates energy dependent factors
c     c(il,im) = c_l^(m)z**m/m! = c_lm    by recursion
c     c_l+1,m = c_l-1,m-(2l+1)z(c_l,m-c_l,m-1, l ne m
c     c_m,m = (-z)**m (2m)!/(2**m m!) with z = 1/i rho
c
c     To test pw approx, set z = 0

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'clmz.h'
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)

      complex*16 rho(legtot)
      complex*16 z, cmm

      cmm = 1
      z = -coni / rho(ileg)

      clmi(1,1,ileg) = (1,0)
      clmi(2,1,ileg) = clmi(1,1,ileg) - z

      lmax = lmaxp1-1

      do 10  il = 2, lmax
         clmi(il+1,1,ileg) =
     1           clmi(il-1,1,ileg) - z*(2*il-1)*clmi(il,1,ileg)
   10 continue
      mmxp1 = min (mmaxp1, lmaxp1)
      do 20  im = 2, mmxp1
         m = im-1
         imp1 = im+1
         cmm = -cmm * (2*m-1) * z
         clmi(im,im,ileg) = cmm
         clmi(imp1,im,ileg) = cmm * (2*m+1) * (1-im*z)
         do 20  il = imp1, lmax
            l = il-1
            clmi(il+1,im,ileg) = clmi(l,im,ileg) -
     1          (2*l+1) * z * (clmi(il,im,ileg) + clmi(il,m,ileg))
   20 continue

      return
      end
      function sdist (r0, r1)
c     find distance squared between cartesian points r0 and r1
c     single precision
      dimension r0(3), r1(3)
      sdist = 0
      do 10  i = 1, 3
         sdist = sdist + (r0(i) - r1(i))**2
   10 continue
      sdist = sqrt(sdist)
      return
      end
      subroutine setedg (a2, ihole)
      integer i, ihole
      character*2 a2, edglbl
      dimension edglbl(0:29)

      data edglbl / 'NO', 'K ', 'L1', 'L2', 'L3',
     3            'M1','M2','M3','M4','M5',
     4            'N1','N2','N3','N4','N5','N6','N7',
     5            'O1','O2','O3','O4','O5','O6','O7',
     6            'P1','P2','P3','P4','P5',
     7            'R1' /

      ihole  = -1
      do 10 i = 0,29
  10     if (a2 .eq. edglbl(i) ) ihole  = i
      if (ihole  .lt. 0) stop 'unknown EDGE'

      return
      end
      subroutine setgam (iz, ihole, gamach)

c     Sets gamach, core hole lifetime.  Data comes from graphs in
c     K. Rahkonen and K. Krause,
c     Atomic Data and Nuclear Data Tables, Vol 14, Number 2, 1974.

      implicit double precision (a-h, o-z)

      dimension gamk(6), zk(6)
      dimension gaml1(6), zl1(6)
      dimension gaml2(6), zl2(6)
      parameter (ryd  = 13.6058)
      character*512 slog

      save ienter

c     Note that 0.99 replaces 1.0, 95.1 replaces 95.0 to avoid roundoff
c     trouble.
c     Gam arrays contain the gamma values.
c     We will take log10 of the gamma values so we can do linear
c     interpolation from a log plot.

      data  zk   / 0.99,  10.0, 20.0,  40.0,  60.0,   95.1/
      data  gamk / 0.07,   0.3,  0.75,  5.0,  20.0,  100.0/

      data  zl1   / 0.99,  20.0, 35.0, 50.0,  75.0,  95.1/
      data  gaml1 / 0.07,   4.0,  7.0,  4.0,   8.0,  19.0/

      data  zl2   / 0.99,  26.0, 31.0, 60.0,  80.0,  95.1/
      data  gaml2 / 0.001,  1.7,  0.8,  3.5,   5.0,  10.0/

      data ienter /0/

c     Call this only once, if it gets called a second time the gamma
c     values will be messed up by repeated taking of log10

      if (ienter .gt. 0)  then
         call wlog(' Re-entered SETGAM')
         stop 'SETGAM-1'
      endif
      ienter = 1

      if (ihole .le. 0)  then
         gamach = 0
         write(slog,'(a,1pe13.5)') ' No hole in SETGAM, gamach = ',
     1                             gamach
         call wlog(slog)
         return
      endif
      if (ihole .gt. 4)  then
         call wlog(' This version of FEFF will set gamach = 0.1 eV ' //
     1             ' for M1 and higher hole')
         call wlog(' You can use CORRECTIONS card  to set ' //
     1   ' gamach = 0.1 + 2*vicorr ')
c        stop 'SETGAM-2'
      endif

      zz = iz
      if (ihole .le. 1)  then
         do 10  i = 1, 6
            gamk(i) = log10 (gamk(i))
   10    continue
         call terp (zk, gamk, 6, 1, zz, gamach)
      else if (ihole .le. 2)  then
         do 20  i = 1, 6
            gaml1(i) = log10 (gaml1(i))
   20    continue
         call terp (zl1, gaml1, 6, 1, zz, gamach)
      else if (ihole .le. 4)  then
c        note that LII and LIII have almost exactly the same
c        core hole lifetimes
         do 30  i = 1, 6
            gaml2(i) = log10 (gaml2(i))
   30    continue
         call terp (zl2, gaml2, 6, 1, zz, gamach)
      else
c     include data from the tables later.
c     Now gamach=0.1eV for any M-hole for any element.
         gamach = -1.0
      endif

c     Change from log10 (gamma) to gamma
      gamach = 10.0 ** gamach

c     Table values are in eV, code requires atomic units
      gamach = gamach / ryd

      return
      end
      subroutine setkap(ihole, kinit, linit)
      implicit double precision (a-h, o-z)

c     Set initial state ang mom and quantum number kappa
c     ihole  initial state from ihole
c     1      K    1s      L=0 -> linit=0
c     2      LI   2s      L=0 -> linit=0
c     3      LII  2p 1/2  L=1 -> linit=1
c     4      LIII 2p 3/2  L=1 -> linit=1
c     5+     etc.
      if (ihole.le. 2 .or. ihole.eq. 5 .or. ihole.eq.10 .or.
     1    ihole.eq.17 .or. ihole.eq.24 .or. ihole.eq.27)  then
c        hole in s state
         linit = 0
         kinit = -1
      elseif (ihole.eq. 3 .or. ihole.eq. 6 .or. ihole.eq.11 .or.
     1        ihole.eq.18 .or. ihole.eq.25 .or. ihole.eq.30)  then
c        hole in p 1/2 state
         linit = 1
         kinit = 1
      elseif (ihole.eq. 4 .or. ihole.eq. 7 .or. ihole.eq.12 .or.
     1        ihole.eq.19 .or. ihole.eq.26)  then
c        hole in p 3/2 state
         linit = 1
         kinit = -2
      elseif (ihole.eq. 8 .or. ihole.eq.13 .or.
     1        ihole.eq.20 .or. ihole.eq.27)  then
c        hole in d 3/2 state
         linit = 2
         kinit = 2
      elseif (ihole.eq. 9 .or. ihole.eq.14 .or.
     1        ihole.eq.21 .or. ihole.eq.28)  then
c        hole in d 5/2 state
         linit = 2
         kinit = -3
      elseif (ihole.eq.15 .or. ihole.eq.22)  then
c        hole in  f 5/2 state
         linit = 3
         kinit = 3
      elseif (ihole.eq.16 .or. ihole.eq.23)  then
c        hole in  f 7/2 state
         linit = 3
         kinit = -4
      else
c        some unknown hole
         stop 'invalid hole number in setkap'
      endif

      return
      end
      subroutine setlam (icalc, ie)
      implicit double precision (a-h, o-z)

c     Set lambda array based on icalc and ie
c     icalc  what to do
c      0     i0, ss exact
c      1     i1, ss exact
c      2     i2, ss exact
c     10     cute algorithm
c     <0     do exactly as told, decode as:
c               icalc = -(nmax + 100*mmax + 10 000*(iord+1))
c               Note that iord=0 <=> nmax=mmax=0, so use
c                  icalc = -10 000 for this case.
c               iord = 2*nmax + mmax, so if you want iord to control,
c               set nmax and mmax large enough-- if you want nmax and
c               mmax to control, set iord = 2*nmax + mmax...

c     inputs: ie used for cute algorithm
c             nsc used from /pdata/ to recognize ss paths
c     output: variables in /lambda/ set

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'lambda.h'
      common /lambda/
     4   mlam(lamtot),
     5   nlam(lamtot),
     1   lamx,
     2   laml0x,
     3   mmaxp1, nmax
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle
      dimension mlam0(lamtot), nlam0(lamtot)

c     one degree in radians
      parameter (onedeg = .01745329252)
      character*512 slog

c     Set iord, nmax and mmax based on icalc
      if (icalc .lt. 0)  then
c        decode it and do what user wants
         icode = -icalc
         nmax = mod(icode,100)
         mmax = mod(icode,10000)/100
         iord = icode/10000 -1
      elseif (nsc .eq. 1)  then
         mmax = ilinit
         nmax = ilinit
         iord = 2*nmax + mmax
      elseif (icalc .lt. 10)  then
         iord = icalc
         mmax = iord
         nmax = iord/2
      elseif (icalc .eq. 10)  then
c        do cute algorithm
c        set mmax = L0 if straight line path, otherwise set mmax = 3
         mmax = ilinit
         do 10  ileg = 1, nleg
            mag1 = abs(beta(ileg))
            mag2 = abs(mag1 - pi)
c           if beta is not 0 or pi, path is non-linear
            if (mag1.gt.onedeg .and. mag2.gt.onedeg) mmax = 3
   10    continue
c        Set nmax based on ie and l0.
c        k <= 12 invA (ie=41)  nmax = L0
c        k >= 13 invA (ie=42)  nmax =  9
         nmax = ilinit
         if (ie .ge. 42)  nmax = 9
         iord = 2*nmax + mmax
      else
         write(slog,'(a,i8)') ' undefined icalc ', icalc
         call wlog(slog)
         stop 'setlam'
      endif

c-----construct index lambda (lam), (mu, nu) = mlam(lam), nlam(lam)
c     lamtot, ntot, mtot are maximum lambda, mu and nu to consider
c     Use ...0 for making indices, then sort into arrays with no
c     trailing 0 so laml0x is minimimized. (note: this is a crude
c     n**2 sort -- can 'improve' to nlog_2(n) if necessary)
      lam = 0
      do 20 in = 1, nmax+1
         n = in - 1
         do 20  im = 1, mmax+1
            m = im-1
            jord = 2*n+m
            if (jord .gt. iord)  goto 20
            if (lam .ge. lamtot)  then
               call wlog(' Lambda array filled, some order lost')
               goto 21
            endif
            lam = lam+1
            mlam0(lam) = -m
            nlam0(lam) = n
            if (m .eq. 0)  goto 20
            if (lam .ge. lamtot)  then
               call wlog(' Lambda array filled, some order lost')
               goto 21
            endif
            lam = lam+1
            mlam0(lam) = m
            nlam0(lam) = n
   20 continue
   21 continue
      lamx=lam
c     lamx must be less than lamtot
      if (lamx .gt. lamtot) stop 'SETLAM lamx > lamtot'

c     laml0x is biggest lam for non-zero fmatrix, also set mmax and nmax
c     Sort mlam0 and nlam0 to use min possible laml0x
      lam = 0
      do 30  lam0 = 1, lamx
         if ((nlam0(lam0).le.ilinit) .and.
     1       (iabs(mlam0(lam0)).le.ilinit)) then
            lam = lam+1
            nlam(lam) = nlam0(lam0)
            mlam(lam) = mlam0(lam0)
            nlam0(lam0) = -1
         endif
   30 continue
      laml0x = lam
      do 40  lam0 = 1, lamx
         if (nlam0(lam0) .ge. 0)  then
            lam = lam+1
            nlam(lam) = nlam0(lam0)
            mlam(lam) = mlam0(lam0)
         endif
   40 continue

      mmaxp1 = 0
      nmax = 0
      do 50  lam = 1, lamx
         if (mlam(lam)+1 .gt. mmaxp1)  mmaxp1 = mlam(lam)+1
         if (nlam(lam) .gt. nmax)  nmax = nlam(lam)
   50 continue

      if (nmax.gt.ntot .or. mmaxp1.gt.mtot+1)  then
   52    format (a, 4i8)
         write(slog,52) ' mmaxp1, nmax, mtot, ntot ',
     1                    mmaxp1, nmax, mtot, ntot
         call wlog(slog)
         write(slog,52) ' icalc ', icalc
         call wlog(slog)
         stop 'setlam'
      endif

      return
      end
      subroutine sidx (rholap, npts, rmt, rnrm, imax, imt, inrm)

      implicit double precision (a-h, o-z)
      dimension rholap (npts)
      character*512 slog

      imt = ii (rmt)
      inrm = ii (rnrm)

c     Set imax (last non-zero rholap data)
      do 220  i = 1, npts
         if (rholap(i) .le. 1.0e-5)  goto 230
         imax = i
  220 continue
  230 continue

c     We need data up to the norman radius, so move norman
c     radius if density is zero inside rnrm.
      if (inrm .gt. imax)  then
         inrm = imax
         rnrm = rr (inrm)
  232    format(a,1pe13.5)
         write(slog,232) ' Moved rnrm.  New rnrm (au) ', rnrm
         call wlog(slog)
      endif
      if (imt .gt. imax)  then
         imt = imax
         rmt = rr (imt)
         write(slog,232) ' Moved rmt.  New rmt (au) ', rmt
         call wlog(slog)
      endif
      return
      end
c---------------------------------------------------------------------
c     program sigms.f
c
c     calculates debye-waller factors for each multiple
c     scattering path using Debye-Model correlations
c
c     files:  input  pathd_all.dat  multiple scattering path data
c             output fort.3  sig**2 vs path
c                    fort.2  long output
c
c     version 1  (29 july 91)
c
c     coded by j. rehr
c     path data from s. zabinsky
c
c     modified to use pdata.inp, Dec 1991, siz
c     Subroutine version, Dec 1991, siz
c
c---------------------------------------------------------------------

      subroutine sigms (tk, thetad, rs, nlegx, nleg, rat, iz, sig2)
c               tk temperature in degrees K
c               thetad debye temp in degrees K
c               rs=wigner seitz or norman radius in bohr, averaged
c                  over entire problem
c                  (4pi/3)*rs**3 = sum( (4pi/3)rnrm**3 ) / N
c                  (sum is over all atoms in the problem)
c               nlegx used in dimensions of rat and iz
c               nleg nlegs in path
c               rat positions of each atom in path
c               iz atomic number of each atom in path
c               NB Units of distance in this routine
c                  are angstroms, including sig**2.  rs is in bohr.
c               sig2 is output debye waller factor

      implicit double precision (a-h,o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

c     nlegx is max number of atoms in any one path
      dimension rat(3,0:nlegx)
      dimension iz(0:nlegx)

c      parameters
c               x = k_d*R   (distance parameter)
c               R distance in angstroms
c               y = hbar omegad/kT = thetad/t
c               thetad debye temp in degrees K
c               tk temperature in degrees K
c               k_d = (6*pi**2 N/V) = debye wave number
c               N/V=1/(4pi/3rs**3)
c               rs=wigner seitz or norman radius in bohr
c               ami, amj masses at sites i and j in amu
c               I = int_0^1 (y/x) dw sin(wx)coth(wy/2)

c     Note:  There are nleg atoms including the central atom
c            index 0 and index nleg both refer to central atom,
c            which makes special code unnecessary later.
      sum = 0
      ntot = 0

      sigtot=0
      do 800 il=1,nleg
      do 800 jl=il,nleg

c        calculate r_i-r_i-1 and r_j-r_j-1

         rij = dist (rat(1,il), rat(1,jl))
         call corrfn (rij, cij, thetad, tk, iz(il), iz(jl), rs)
         sig2ij=cij

         rimjm = dist (rat(1,il-1), rat(1,jl-1))
         call corrfn (rimjm, cimjm, thetad, tk, iz(il-1), iz(jl-1), rs)
         sig2ij=sig2ij+cimjm

         rijm = dist (rat(1,il), rat(1,jl-1))
         call corrfn (rijm, cijm, thetad, tk, iz(il), iz(jl-1), rs)
         sig2ij=sig2ij-cijm

         rimj = dist (rat(1,il-1), rat(1,jl))
         call corrfn (rimj, cimj, thetad, tk, iz(il-1), iz(jl), rs)
         sig2ij=sig2ij-cimj

         riim = dist (rat(1,il), rat(1,il-1))
         rjjm = dist (rat(1,jl), rat(1,jl-1))

         ridotj=(rat(1,il)-rat(1,il-1))*(rat(1,jl)-rat(1,jl-1))+
     1          (rat(2,il)-rat(2,il-1))*(rat(2,jl)-rat(2,jl-1))+
     2          (rat(3,il)-rat(3,il-1))*(rat(3,jl)-rat(3,jl-1))
         ridotj=ridotj/(riim*rjjm)

c        double count i .ne. j  terms
         if(jl.ne.il) sig2ij=2*sig2ij
         sig2ij=sig2ij*ridotj
         sigtot=sigtot+sig2ij

  800 continue
      sig2=sigtot/4

c     sig2 is in bohr**2, just as we wanted for ff2chi
      return
      end



      subroutine corrfn(rij,cij,thetad,tk,iz1,iz2,rsavg)
c     subroutine calculates correlation function
c     c(ri,rj)=<xi xj> in the Debye approximation
c
c             =(1/N)sum_k exp(ik.(Ri-Rj))(1/sqrt(mi*mj))*
c              (hbar/2w_k)*coth(beta hbar w_k/2)
c             = (3kT/mu w_d**2)*sqrt(mu**2/mi*mj)*I
c
c      parameters
c               x = k_d*R   (distance parameter)
c               R distance in angstroms
c               y = hbar omegad/kT = thetad/t
c               thetad debye temp in degrees K
c               tk temperature in degrees K
c               k_d = (6*pi**2 N/V) = debye wave number
c               N/V=1/(4pi/3rs**3)
c               rs=wigner seitz or norman radius in bohr
c               ami, amj masses at sites i and j in amu
c               I = int_0^1 (y/x) dw sin(wx)coth(wy/2)
c
c      solution by numerical integration
c
      implicit double precision (a-h, o-z)
      common /xy/ x, yinv

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)

c     con=hbar**2/kB*amu)*10**20   in ang**2 units
c     hbar = 1.054 572 666 e-34, amu = 1.660 540 e-27,
c     kB = 1.380 6581 d-23
      parameter (con = 48.508 459 393 094)

c     external fn
c     rij=2.55
c     tk=295
c     thetad=315
c     ami=amj=63.55 at wt for Cu
c     rs=2.7

      ami=atwtd(iz1)
      amj=atwtd(iz2)
      rs=rsavg
c     thetad in degrees K, t temperature in degrees K
c     y=thetad/tk
      yinv=tk/thetad
      xkd=(9*pi/2)**(third)/(rs*bohr)
      fac=(3/2.)*con/(thetad*sqrt(ami*amj))
      rj=rij
      x=xkd*rj
c     call numerical integration
      call bingrt (grater, eps, nx)
      cij=fac*grater
      return
      end
      double precision function fn(w)
      implicit double precision (a-h,o-z)
      common/xy/x,yinv
c     fn=(sin(wx)/x)*coth(wy/2)
c     change code to allow t=0 without bombing
c     fn=2/y
      fn=2*yinv
      if(w.lt.1.e-20) return
      fac=w
      if(x.gt.0.) fac=sin(w*x)/x
      emwy=0.
      if(yinv.gt.0.0125) emwy=exp(-w/yinv)
      emwy=exp(-w/yinv)
      fn=fac*(1+emwy)/(1-emwy)
      return
      end
c-----------------------------------------------
      subroutine bingrt (b, eps, n)
c     subroutine calculates integrals between [0,1]
c      b = int_0^1 f(z) dz
c     by trapezoidal rule and binary refinement
c     (romberg integration)
c     coded by j rehr (10 Feb 92)
c     see, e.g., numerical recipes for discussion
c     and a much fancier version
c-----------------------------------------------
c     del=dz  itn=2**n tol=1.e-5
c     starting values
      implicit double precision (a-h,o-z)
      common /xy/x,yinv
      character*512 slog
c     external fn
c     error is approximately 2**(-2n) ~ 10**(-.6n)
c     so nmax=10 implies an error of 1.e-6
      parameter(nmax = 10, tol = 1.e-5)
      parameter(zero=0, one=1)
      n=0
      itn=1
      del=1.
      bn=(fn(zero)+fn(one))/2
      bo=bn
 10   continue
c     nth iteration
c     b_n+1=(b_n)/2+deln*sum_0^2**n f([2n-1]deln)
      n=n+1
      if(n.gt.nmax) go to 40
      del=del/2
      sum=0.
      do 20 i=1, itn
      zi=(2*i-1)*del
 20   sum=sum+fn(zi)
c     bnp1=b_n+1 is current value of integral
      bnp1=bn/2+del*sum
c     cancel leading error terms b=[4b-bn]/3
c     note: this is the first term in the
c     neville table - remaining errors were
c     found too small to justify the added code
      b=(4*bnp1-bn)/3
      eps=abs((b-bo)/b)
      if(eps.lt.tol) goto 60
      bn=bnp1
      bo=b
      itn=itn*2
      goto 10
 40   write(slog,50) n,itn, b,eps
      call wlog(slog)
 50   format(' not converged, n,itn,b,eps=',
     1  2i4,2e14.6)
      return
 60   continue
      return
      end
      subroutine snlm (lmaxp1, mmaxp1)
      implicit double precision(a-h,o-z)

c     Set nlm, legendre normalization factors, xnlm in common /nlm/
c     Calculates legendre norm factors
c     xnlm= sqrt ((2l+1)(l-m)!/(l+m)!)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'nlm.h'
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)

c     flg(i) = i! * afac**i, set in factst
      dimension flg(0:210)

      call factst (afac, flg)

c     initialize xnlm explicitly
      do 5  il = 1, ltot+1
      do 5  im = 1, mtot+1
         xnlm(il,im) = 0
    5 continue

      do 10  il = 1, lmaxp1
         mmxp1 = min (mmaxp1, il)
         do 10  im = 1, mmxp1
            l = il-1
            m = im-1
            cnlm = (2*l+1) * flg(l-m) / flg(l+m)
            cnlm = sqrt(cnlm) * afac**m
            xnlm(il,im) = cnlm
   10 continue

      return
      end
      subroutine factst (afac, flg)
      implicit double precision (a-h,o-z)

c     FACTorial SeT, flg(i) = i! * afac**i
      dimension flg(0:210)

c     afac = 1/64 works with double precision on a VAX
      afac = 1./64.

      flzero = 1
      flg(0) = 1
      flg(1) = afac

      do 10  i = 2, 210
   10 flg(i) = flg(i-1) * i * afac

      return
      end
      subroutine somm (dr,dp,dq,dpas,da,m,np)
c
c integration by the method of simpson of (dp+dq)*dr**m from
c 0 to r=dr(np)
c dpas=exponential step;
c for r in the neighborhood of zero (dp+dq)=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(np), dp(np), dq(np)
      mm=m+1
      d1=da+mm
      da=0.0
      db=0.0
      do 70 i=1,np
      dl=dr(i)**mm
      if (i.eq.1.or.i.eq.np) go to 10
      dl=dl+dl
      if ((i-2*(i/2)).eq.0) dl=dl+dl
   10 dc=dp(i)*dl
      if (dc) 20,40,30
   20 db=db+dc
      go to 40
   30 da=da+dc
   40 dc=dq(i)*dl
      if (dc) 50,70,60
   50 db=db+dc
      go to 70
   60 da=da+dc
   70 continue
      da = dpas * (da + db) / 3.0
      dc=exp(dpas)-1.0
      db=d1*(d1+1.0)*dc*exp((d1-1.0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dc=(dr(1)**mm)*(1.0+1.0/(dc*(d1+1.0)))/d1
      da=da+dc*(dp(1)+dq(1))-db*(dp(2)+dq(2))
      return
      end
      subroutine sortir (n, index, r)

c     SORT by rearranges Indices, keys are Real numbers
c     Heap sort, following algorithm in Knuth using r as key
c     Knuth, The Art of Computer Programming,
c     Vol 3 / Sorting and Searching, pp 146-7
c     Array r is not modified, instead array index is returned
c     ordered so that r(index(1)) is smallest, etc.
c     rr is temporary r storage (Knuth's R), irr is index of stored r

      dimension r(n), index(n)

c     Initialize index array
      do 10  i = 1, n
         index(i) = i
   10 continue
c     only 1 element is already sorted
      if (n .eq. 1)  return

c     H1: initialize
      l = n/2 + 1
      ir = n

c     H2: Decrease l or ir
   20 continue
      if (l .gt. 1)  then
         l = l-1
         irr = index(l)
         rr = r(irr)
      else
         irr = index(ir)
         rr = r(irr)
         index(ir) = index(1)
         ir = ir-1
         if (ir .eq. 1) then
            index(1) = irr
            return
         endif
      endif

c     H3: Prepare for sift-up
      j = l

c     H4: Advance downward
   40 continue
      i = j
      j = 2 * j
      if (j .eq. ir)  goto 60
      if (j .gt. ir)  goto 80

c     H5: Find larger son of i
      if (r(index(j)) .lt. r(index(j+1)))  j = j+1

c     H6: Son larger than rr?
   60 continue
      if (rr .ge. r(index(j)))  goto 80

c     H7: Move son up
      index(i) = index(j)
      goto 40

c     H8: Store rr in it's proper place
   80 continue
      index(i) = irr
      goto 20

      end
      subroutine sortii (n, index, k)

c     SORT by rearranges Indices, keys are Integers
c     Heap sort, following algorithm in Knuth using r as key
c     Knuth, The Art of Computer Programming,
c     Vol 3 / Sorting and Searching, pp 146-7
c     Array r is not modified, instead array index is returned
c     ordered so that r(index(1)) is smallest, etc.
c     rr is temporary r storage (Knuth's R), irr is index of stored r

      dimension k(n)
      dimension index(n)

c     Initialize index array
      do 10  i = 1, n
         index(i) = i
   10 continue
c     only 1 element is already sorted
      if (n .eq. 1)  return

c     H1: initialize
      l = n/2 + 1
      ir = n

c     H2: Decrease l or ir
   20 continue
      if (l .gt. 1)  then
         l = l-1
         irr = index(l)
         kk = k(irr)
      else
         irr = index(ir)
         kk = k(irr)
         index(ir) = index(1)
         ir = ir-1
         if (ir .eq. 1) then
            index(1) = irr
            return
         endif
      endif

c     H3: Prepare for sift-up
      j = l

c     H4: Advance downward
   40 continue
      i = j
      j = 2 * j
      if (j .eq. ir)  goto 60
      if (j .gt. ir)  goto 80

c     H5: Find larger son of i
      if (k(index(j)) .lt. k(index(j+1)))  j = j+1

c     H6: Son larger than kk?
   60 continue
      if (kk .ge. k(index(j)))  goto 80

c     H7: Move son up
      index(i) = index(j)
      goto 40

c     H8: Store kk in it's proper place
   80 continue
      index(i) = irr
      goto 20

      end
      subroutine sortid (n, index, r)

c     SORT by rearranges Indices, keys are Double precision numbers
c     Heap sort, following algorithm in Knuth using r as key
c     Knuth, The Art of Computer Programming,
c     Vol 3 / Sorting and Searching, pp 146-7
c     Array r is not modified, instead array index is returned
c     ordered so that r(index(1)) is smallest, etc.
c     rr is temporary r storage (Knuth's R), irr is index of stored r

      implicit double precision (a-h, o-z)
      dimension r(n), index(n)

c     Initialize index array
      do 10  i = 1, n
         index(i) = i
   10 continue
c     only 1 element is already sorted
      if (n .eq. 1)  return

c     H1: initialize
      l = n/2 + 1
      ir = n

c     H2: Decrease l or ir
   20 continue
      if (l .gt. 1)  then
         l = l-1
         irr = index(l)
         rr = r(irr)
      else
         irr = index(ir)
         rr = r(irr)
         index(ir) = index(1)
         ir = ir-1
         if (ir .eq. 1) then
            index(1) = irr
            return
         endif
      endif

c     H3: Prepare for sift-up
      j = l

c     H4: Advance downward
   40 continue
      i = j
      j = 2 * j
      if (j .eq. ir)  goto 60
      if (j .gt. ir)  goto 80

c     H5: Find larger son of i
      if (r(index(j)) .lt. r(index(j+1)))  j = j+1

c     H6: Son larger than rr?
   60 continue
      if (rr .ge. r(index(j)))  goto 80

c     H7: Move son up
      index(i) = index(j)
      goto 40

c     H8: Store rr in it's proper place
   80 continue
      index(i) = irr
      goto 20

      end
C FUNCTION ISTRLN (STRING)  Returns index of last non-blank
C                           character.  Returns zero if string is
C                           null or all blank.

      FUNCTION ISTRLN (STRING)
      CHARACTER*(*)  STRING
      CHARACTER BLANK, TAB
      PARAMETER (BLANK = ' ', TAB = '	')
C     there is a tab character here  ^

C  -- If null string or blank string, return length zero.
      ISTRLN = 0
      IF (STRING (1:1) .EQ. CHAR(0))  RETURN
      IF (STRING .EQ. ' ')  RETURN

C  -- Find rightmost non-blank character.
      ILEN = LEN (STRING)
      DO 20  I = ILEN, 1, -1
         IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB)  GOTO 30
   20 CONTINUE
   30 ISTRLN = I

      RETURN
      END
C SUBROUTINE TRIML (STRING)  Removes leading blanks.

      SUBROUTINE TRIML (STRING)
      CHARACTER*(*)  STRING
      CHARACTER*200  TMP
      CHARACTER BLANK, TAB
      PARAMETER (BLANK = ' ', TAB = '	')
C     there is a tab character here  ^

      JLEN = ISTRLN (STRING)

C  -- All blank and null strings are special cases.
      IF (JLEN .EQ. 0)  RETURN

C  -- FInd first non-blank char
      DO 10  I = 1, JLEN
         IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB)  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.
      TMP = STRING (I:)
      STRING = TMP
      RETURN
      END
C SUBROUTINE UPPER (STRING)  Changes a-z to upper case.

      SUBROUTINE UPPER (STRING)
      CHARACTER*(*)  STRING

      JLEN = ISTRLN (STRING)

      DO 10  I = 1, JLEN
         IC = ICHAR (STRING (I:I))
         IF ((IC .LT. 97)  .OR.  (IC .GT. 122))  GOTO 10
         STRING (I:I) = CHAR (IC - 32)
   10 CONTINUE

      RETURN
      END
C SUBROUTINE LOWER (STRING)  Changes A-Z to lower case.

      SUBROUTINE LOWER (STRING)
      CHARACTER*(*)  STRING

      JLEN = ISTRLN (STRING)

      DO 10  I = 1, JLEN
         IC = ICHAR (STRING (I:I))
         IF ((IC .LT. 65) .OR.  (IC .GT. 90))  GOTO 10
         STRING (I:I) = CHAR (IC + 32)
   10 CONTINUE

      RETURN
      END
C***********************************************************************
C
      SUBROUTINE BWORDS (S, NWORDS, WORDS)
C
C     Breaks string into words.  Words are seperated by one or more
C     blanks or tabs, or a comma and zero or more blanks.
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      Tab char added July 1994.
C
C**************************  Deo Soli Gloria  **************************

C  -- No floating point numbers in this routine.
      IMPLICIT INTEGER (A-Z)

      CHARACTER*(*) S, WORDS(NWORDS)

      CHARACTER BLANK, COMMA, TAB
      PARAMETER (BLANK = ' ', COMMA = ',', TAB = '	')
C     there is a tab character here               ^.

C  -- BETW    .TRUE. if between words
C     COMFND  .TRUE. if between words and a comma has already been found
      LOGICAL BETW, COMFND

C  -- Maximum number of words allowed
      WORDSX = NWORDS

C  -- SLEN is last non-blank character in string
      SLEN = ISTRLN (S)

C  -- All blank string is special case
      IF (SLEN .EQ. 0)  THEN
         NWORDS = 0
         RETURN
      ENDIF

C  -- BEGC is beginning character of a word
      BEGC = 1
      NWORDS = 0

      BETW   = .TRUE.
      COMFND = .TRUE.

      DO 10  I = 1, SLEN
         IF (S(I:I) .EQ. BLANK .OR. S(I:I) .EQ. TAB)  THEN
            IF (.NOT. BETW)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = S (BEGC : I-1)
               BETW = .TRUE.
               COMFND = .FALSE.
            ENDIF
         ELSEIF (S(I:I) .EQ. COMMA)  THEN
            IF (.NOT. BETW)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = S(BEGC : I-1)
               BETW = .TRUE.
            ELSEIF (COMFND)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = BLANK
            ENDIF
            COMFND = .TRUE.
         ELSE
            IF (BETW)  THEN
               BETW = .FALSE.
               BEGC = I
            ENDIF
         ENDIF

         IF (NWORDS .GE. WORDSX)  RETURN

   10 CONTINUE

      IF (.NOT. BETW  .AND.  NWORDS .LT. WORDSX)  THEN
         NWORDS = NWORDS + 1
         WORDS (NWORDS) = S (BEGC :SLEN)
      ENDIF

      RETURN
      END
      subroutine strap (x, y, n, sum)

c     Trapeziodal integration of y(x), result in sum
c     SINGLE PRECISION

      dimension x(n), y(n)

      sum = y(1) * (x(2) - x(1))
      do 10  i = 2, n-1
         sum = sum + y(i) * (x(i+1) - x(i-1))
   10 continue
      sum = sum + y(n) * (x(n) - x(n-1))
      sum = sum/2

      return
      end
c SUBROUTINE SUMAX (NPTS, RN, ANN, AA2, AASUM)
c This is a version of the subroutine sumax found on page 110 of
c Louck's book.  It performs eq 3.22, using simpson's rule and
c taking advantage of the logarithmic grid so that sum f(r)*dr becomes
c sum over f(r)*r*(0.05).  Linear interpolation is used at the end
c caps.  This version does not sum over 14 shells of identical
c atoms, instead it averages the contribution of one or more atoms
c of type 2 at the location of atom 1.  Louck's description (except
c for his integration algorithm) is very clear.
c
c input:  npts      number of points to consider
c         rn        distance from atom 1 to atom 2 in au
c         ann       number of type 2 atoms to add to atom 1, can
c                   be fractional
c         aa2(i)    potential or density at atom 2
c output: aasum(i)  spherically summed contribution added into this
c                   array so that sumax can be called repeatedly
c                   and the overlapped values summed into aasum
c
c Note that this routine requires that all position data be on a
c grid  rr(j) = exp (-8.8d0 + (j-1)*0.05d0), which is the grid
c used by Louck, and also used by ATOM if nuclear options not used.
c
c Coded by Steven Zabinsky, December 1989
c Modified for FEFF cluster code, August 1990, siz
c Bug fixed, May 1991, SIZ
c Another bug fixed, Mar 1992, SIZ
c
c T.L.Louck, "Augmented Plane Wave Method", W.A.Benjamin, Inc., 1967

      subroutine sumax (npts, rn, ann, aa2, aasum)
      implicit double precision (a-h, o-z)
      parameter (nptx=250)
      dimension aa2(nptx), aasum(nptx)
      dimension stor(nptx)

c     jjchi     index beyond which aa2 is zero
c     jtop      index just below distance to neighbor
c               aasum is calculated only up to index jtop

c     Wigner-Seitz radius is set to 15 in ATOM.
      rws = 15
      jjchi = ii(rws)
      jtop  = ii(rn)

      topx = xx(jjchi)

      do 120  i = 1, jtop
         x = xx(i)
         xint = 0.0
         et = exp(x)
         blx = log(rn-et)
         if (blx .ge. topx)  goto 119
         jbl = 2.0+20.0*(blx+8.8)
         if (jbl .lt. 1)  jbl=1
         if (jbl .ge. 2)  then
c           use linear interp to make end cap near center of neighbor
            xjbl = jbl
            xbl = 0.05 * (xjbl-1.0) - 8.8
            g = xbl-blx
            xint = xint+0.5*g*(aa2(jbl)*(2.0-20.0*g)*exp(2.0*xbl)
     1             +20.0*g*aa2(jbl-1)*exp(2.0*(xbl-0.05)))
         endif
         tlx = log(rn+et)
         if (tlx .ge. topx)  then
            jtl = jjchi
            go to 90
         endif
         jtl = 1.0 + 20.0*(tlx+8.8)
         if (jtl .lt. jbl)  then
c           handle peculiar special case at center of atom 1
            fzn = aa2(jtl)*exp(2.0*(xbl-0.05))
            fz3 = aa2(jbl)*exp(2.0*xbl)
            fz2 = fzn+20.0*(fz3-fzn)*(tlx-xbl+0.05)
            fz1 = fzn+20.0*(fz3-fzn)*(blx-xbl+0.05)
            xint = 0.5*(fz1+fz2)*(tlx-blx)
            go to 119
         endif
         xjtl = jtl
         xtl = 0.05*(xjtl-1.0)-8.8
         c = tlx-xtl
         xint = xint+0.5*c*(aa2(jtl)*(2.0-20.0*c)
     1         *exp(2.0*xtl)+aa2(jtl+1)*20.0*c
     2         *exp(2.0*(xtl+0.05)))

   90    if (jtl .gt. jbl)  then
  100       xint = xint+0.5*(aa2(jbl)*exp(2.0*xbl)+aa2(jbl+1)
     1             *exp(2.0*(xbl+0.05)))*0.05
            jbl = jbl+1
            if (jbl .lt. jtl) then
               xbl = xbl+0.05
               go to 100
            endif
         endif
  119    stor(i) = 0.5*xint*ann/(rn*et)
  120 continue

      do 190  i = 1, jtop
         aasum(i) = aasum(i) + stor(i)
  190 continue

      return
      end
c     interpolation and extrapolation by m-th order polynomial
c     maximum m = 3. Change nmax if needed.
c     Input x and y arrays, returns y value y0 at requested x value x0.
c     Dies on error.

      subroutine terp (x, y, n, m, x0, y0)
      implicit double precision (a-h, o-z)

      dimension x(n), y(n)

c     Find out between which x points x0 lies
      i = locat (x0, n, x)
      k = min( max(i-m/2,1) , n-m )
      call polint( x(k), y(k), m+1, x0, y0, dy)

      return
      end

      function locat (x, n, xx)
      double precision x, xx(n)
      integer  u, m, n

c     Binary search for index of grid point immediately below x.
c     Array xx required to be monotonic increasing.
c     Returns
c     0            x <  xx(1)
c     1            x =  xx(1)
c     i            x =  xx(i)
c     n            x >= xx(n)

      locat = 0
      u = n+1

   10 if (u-locat .gt. 1)  then
         m = (u + locat) / 2
         if (x .lt. xx(m))  then
            u = m
         else
            locat = m
         endif
         goto 10
      endif

      return
      end

      subroutine polint( xa, ya, n, x, y, dy)
c     draws a polynimial P(x) of order (n-1) through n points.
c     returns y = P(x) and dy - estimate of the error
c     borrowed from numerical recipies in fortran by Press et al.

      implicit double precision (a-h,o-z)
      integer n, nmax
      parameter (nmax=4)
      dimension xa(n), ya(n), c(nmax), d (nmax)

      ns = 1
      dif = abs (x-xa(1))
      do 11 i=1,n
         dift = abs(x-xa(i))
         if (dift.lt.dif) then
            ns = i
            dif = dift
         endif
         c(i) = ya(i)
         d(i) = ya(i)
  11  continue
      y = ya(ns)
      ns = ns-1
      do 13 m=1,n-1
         do 12 i=1,n-m
            ho = xa(i)-x
            hp = xa(i+m)-x
            w = c(i+1) - d(i)
            den = ho-hp
            if (den.eq.0) pause 'failure in polint'
            den = w/den
            d(i) = hp*den
            c(i) = ho*den
  12     continue
         if (2*ns .lt. n-m) then
            dy = c(ns+1)
         else
            dy = d(ns)
            ns = ns-1
         endif
         y = y + dy
  13  continue

      return
      end
c     interpolation and extrapolation by m-th order polynomial
c     maximum m = 3. Change nmax if needed.
c     Input x and y arrays, returns y value y0 at requested x value x0.
c     Dies on error.

      subroutine terpc (x, y, n, m, x0, y0)
      implicit double precision (a-h, o-z)

      complex*16 y, y0
      dimension x(n), y(n)

c     Find out between which x points x0 lies
      i = locat (x0, n, x)
      k = min( max(i-m/2,1) , n-m )
      call polinc( x(k), y(k), m+1, x0, y0, dy)

      return
      end

      subroutine polinc( xa, ya, n, x, y, dy)
c     draws a polynimial P(x) of order (n-1) through n points.
c     returns y = P(x) and dy - estimate of the error
c     borrowed from numerical recipies in fortran by Press et al.

      implicit double precision (a-h,o-z)
      complex*16 ya,y,dy,c,d,w,den
      integer n, nmax
      parameter (nmax=4)
      dimension xa(n), ya(n), c(nmax), d (nmax)

      ns = 1
      dif = abs (x-xa(1))
      do 11 i=1,n
         dift = abs(x-xa(i))
         if (dift.lt.dif) then
            ns = i
            dif = dift
         endif
         c(i) = ya(i)
         d(i) = ya(i)
  11  continue
      y = ya(ns)
      ns = ns-1
      do 13 m=1,n-1
         do 12 i=1,n-m
            ho = xa(i)-x
            hp = xa(i+m)-x
            w = c(i+1) - d(i)
            den = ho-hp
            if (den.eq.0) pause 'failure in polint'
            den = w/den
            d(i) = hp*den
            c(i) = ho*den
  12     continue
         if (2*ns .lt. n-m) then
            dy = c(ns+1)
         else
            dy = d(ns)
            ns = ns-1
         endif
         y = y + dy
  13  continue

      return
      end
      subroutine timrep (npat, ipat, rx, ry, rz, dhash)

c     subroutine timrev(...) is modified for polarization case
c     Time-orders path and returns path in standard order,
c     standard order defined below.
c     Input:  npat, ipat
c     Output: ipat in standard order (time reversed if necessary)
c             rx, ry, rz   contain x,y,z coordinates of the path atoms,
c             where z-axis is along polarization vector or first leg, if
c               running usual feff,
c             x-axis is chosen so that first atom, which does not lie on
c               z-axis, lies in xz-plane,
c               for elliptically polarized light, x-axis is along the
c               incidence direction
c             y-axis is cross product of two previos unit vectors
c             Standarrd order is defined so that first nonzero x,y and z
c             coords are positive.(Otherwise we use the inversion of
c             the corresponding unit vector)
c             dhash double precision hash key for path in standard
c                order

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      common /atoms/ rat(3,0:natx), ipot(0:natx), ilb(0:natx)
      dimension ipat(npatx+1), rx(npatx), ry(npatx), rz(npatx)
      dimension ipat0(npatx+1), rx0(npatx), ry0(npatx), rz0(npatx)

      double precision dhash, dhash0

c     Time reverses path if time reversing it will put it
c     in standard order.  Standard order is defined by min hash
c     number, using path hash algorithm developed for the path
c     degeneracy checker.  See subroutine phash for details.
c     Symmetrical paths are, of course, always standard ordered.
c     Also returns hash number for standard ordered path.

c     Use suffix 0 for (') in variable names

c     If no time-reversal standard ordering needed, make hash number
c     and return.  No timrev needed if 2 leg path (symmetrical).
      nleg = npat + 1
      ipat(nleg) = 0
      do 10 i = 1, npatx
         rx(i)   = 0
         ry(i)   = 0
         rz(i)   = 0
         rx0(i)   = 0
         ry0(i)   = 0
         rz0(i)   = 0
   10 continue
      call mpprmp(npat, ipat, rx, ry, rz)
      call phash (npat, ipat, rx, ry, rz, dhash)

      if (npat .le. 1)  then
         return
      endif

c     Make time reversed path

      ipat0(nleg) = ipat(nleg)
      do 210  i = 1, npat
         ipat0(i) = ipat(nleg-i)
  210 continue
      call mpprmp(npat, ipat0, rx0, ry0, rz0)
      call phash (npat, ipat0, rx0, ry0, rz0, dhash0)

c     Do the comparison using hash numbers
c     Want representation with smallest hash number
      if (dhash0 .lt. dhash)  then
c        time reversed representation is smaller, so return
c        that version of the path
         dhash = dhash0
         do 300  i = 1, npat
            ipat(i) = ipat0(i)
            rx(i)   = rx0(i)
            ry(i)   = ry0(i)
            rz(i)   = rz0(i)
  300    continue
      endif

      return
      end
      subroutine trap (x, y, n, sum)
      implicit double precision (a-h, o-z)

c     Trapeziodal integration of y(x), result in sum

      dimension x(n), y(n)

      sum = y(1) * (x(2) - x(1))
      do 10  i = 2, n-1
         sum = sum + y(i) * (x(i+1) - x(i-1))
   10 continue
      sum = sum + y(n) * (x(n) - x(n-1))
      sum = sum/2

      return
      end
      subroutine vbh(rs,xmag,vxc)

      implicit double precision (a-h, o-z)

c   INPUT: density parameter rs, 2* fraction of given spin orientation.
c   OUTPUT: xc potential for given spin orientation.
c   Reference: Von Barth, Hedin, J.Phys.C, 5, 1629, (1972). eq.6.2
c   xmag is twice larger than 'x' in their paper
c   effect of tau was also found to be small. thus tau is not used

c     parameter (asm = 2.0**(-1.0/3.0) )
c     parameter (gamma = 4.0/3.0*asm/(1-asm) )
      parameter (gamma = 5.129762496709890 )

      vxc = 0.0
      if (rs.gt.1000) goto 999
      epc = -0.0504 * flarge(rs/30)
      efc = -0.0254 * flarge(rs/75)
      xmup = -0.0504*log(1.0+30.0/rs)
c     xmuf = -0.0254*log(1.0+75.0/rs)
      vu = gamma*(efc - epc)
c     tau = xmuf-xmup-(efc-epc)*4.0/3.0

      alg = -1.22177412/rs + vu
      blg = xmup - vu
      vxc = alg*xmag**(1.0/3.0) + blg
c     vxc = alg*xmag**(1.0/3.0) + blg +tau*fsmall(xmag/2.0)

 999  continue
      return
      end

      function flarge(x)
      implicit double precision (a-h, o-z)
        flarge = (1+x**3)*log(1+1/x) + x/2 - x**2 - 1.0/3.0
      return
      end

c     function fsmall(x)
c     implicit double precision (a-h, o-z)
c     parameter (a = 2.0**(-1.0/3.0) )
c       fsmall = ( x**(4/3) + (1.0-x)**(4/3) - a ) / (1.0-a)
c     return
c     end
      subroutine wlog (string)
      character*(*) string

c     This output routine is ued to replace the PRINT statement
c     for output that "goes to the terminal", or to the log file.
c     If you use a window based system, you can modify this routine
c     to handle the running output elegantly.
c     Handle carriage control in the string you pass to wlog.
c
c     The log file is also written here, hard coded here.

c     The log file is unit 11.  The log file is opened in the
c     main program, program feff.

c     make sure not to write trailing blanks


   10 format (a)

      il = istrln (string)
      if (il .eq. 0)  then
         print10
         write(11,10)
      else
         print10, string(1:il)
         write(11,10) string(1:il)
      endif
      return
      end
      subroutine lblank (string)
      character*(*) string
c     add a leading blank, useful for carriage control
      string = ' ' // string
      return
      end
      subroutine wphase (nph, em, eref, lmax, ne, ph)

c     Writes phase data to file PHASExx.DAT for each shell

      implicit double precision (a-h, o-z)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      complex*16 eref(nex)
      complex*16 ph(nex,ltot+1,0:nphx)
      dimension em(nex)
      dimension lmax(0:nphx)
      character*30  fname

c     Dump phase data, eref and complex phase for each shell
      do 260  iph = 0, nph
         linit = 0
         if (linit .ge. lmax(iph)-1) linit = lmax(iph)-2
         if (linit .lt. 0) linit = 0

c        prepare files for shell's phase data

         write(fname,242)  iph
  242    format('phase', i2.2, '.dat')
         open (unit=1, file=fname, status='unknown', iostat=ios)
         call chopen (ios, fname, 'wphase')

         write(fname,342)  iph
  342    format('phmin', i2.2, '.dat')
         open (unit=2, file=fname, status='unknown', iostat=ios)
         call chopen (ios, fname, 'wphase')

         call wthead  (1)
         call wthead  (2)
c        write out unique pot and lmax
         write(1,244)   iph, lmax(iph), ne
         write(2,244)   iph, lmax(iph), ne
  244    format (1x, 3i4, '   unique pot,  lmax, ne')
         write(2,346) linit,linit+1,linit+2
  346    format ('      energy      re(eref)     re(p)    phase( ',i2,
     1         ')  phase(',i2,') phase(',i2,')' )

c        for each energy
c        ie, em, eref, p=sqrt(em-eref)
c        ph array to ltot+1, 5 values per line
         do 250  ie = 1, ne
            xp = sqrt(em(ie) - eref(ie))
            write(1,246)  ie, em(ie), eref(ie), sqrt(em(ie)-eref(ie))
  246       format ('   ie        energy      re(eref)',
     1              '      im(eref)',
     2              '         re(p)         im(p)', /,
     3              1x, i4, 1p, 5e14.6)
            write(1,248)  (ph(ie,ll,iph), ll=1,lmax(iph)+1)
  248       format (1x, 1p, 4e14.6)
        write(2,348) em(ie),real(eref(ie)),real(sqrt(em(ie)-eref(ie))),
     1            (real(ph(ie,ll,iph)), ll=linit+1,linit+3)
  348       format (1p, 6e13.5)
  250    continue
         close(unit=1)
         close(unit=2)
  260 continue

      return
      end
      subroutine wpot (nph, edens, ifrph, imt, inrm,
     1                 rho, vclap, vcoul, vtot)

c     Writes potentials to file name POTxx.DAT for each unique pot.

      implicit double precision (a-h, o-z)

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      dimension ifrph(0:nphx)
      dimension rho(251,0:nfrx)
      dimension vcoul(251,0:nfrx)
      dimension edens(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension vtot (251,0:nphx)
      dimension imt(0:nphx)
      dimension inrm(0:nphx)

      character*30 fname

c     note units --
c     potentials in rydbergs, so that v * 13.6 -> eV
c     density in #/(bohr)**3, so rho * e / (.529)**3 -> e/(Ang)**3

      do 180  iph = 0, nph
         ifr = ifrph(iph)
c        prepare file for unique potential data
         write(fname,172)  iph
  172    format('pot', i2.2, '.dat')
         open (unit=1, file=fname, status='unknown', iostat=ios)
         call chopen (ios, fname, 'wpot')
         call wthead(1)
         write(1,173)  iph, imt(iph), inrm(iph)
  173    format (1x, 3i4, '  Unique potential, I_mt, I_norman.',
     1          '    Following data in atomic units.')
         write(1,*) ' ifr ', ifr
         write(1,174)
  174    format ('   i      r         vcoul        rho',
     1           '     ovrlp vcoul  ovrlp vtot  ovrlp rho')
c        need some limit here, 1250 points is silly.  Use
c        r <= 38, which gives 249 points with usual rgrid
         do 178  i = 1, 251
            if (rr(i) .gt. 38)  goto 179
            write(1,176) i, rr(i), vcoul(i,ifr), rho(i,ifr)/(4*pi),
     1                vclap(i,iph), vtot(i,iph), edens(i,iph)/(4*pi)
  176       format (1x, i4, 1p, 6e12.4)
  178    continue
  179    continue
         close(unit=1)
  180 continue

      return
      end
      subroutine xcpot (iph, ie, index, lreal, ifirst, jri,
     1                  em, xmu, xmuval, vi0, rs0, gamach,
     2                 vtot, vvalgs, densty, dmag, denval, sigmd, pgrid,
     3                  eref, erefvl, v, vval, emp,
     4                  vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim)

      implicit double precision (a-h, o-z)

c     INPUT
c     iph, ie used only for debug and labels.
c     index       0  Hedin-Lunqvist + const real & imag part
c                 1  Dirac-Hara + const real & imag part
c                 2  ground state + const real & imag part
c                 3  Dirac-Hara + HL imag part + const real & imag part
c                 4  See rdinp for comment
c     lreal       logical, true for real phase shifts only
c     ifirst      first entry flag, set to zero before first call for
c                 each unique potential, see vxcrmu and vxcimu below
c     jri         index of first interstitial point in current
c                 Loucks r grid
c     em          current energy grid point
c     xmu         fermi level
c     xmuval      fermi level for valence-core model
c     vi0         const imag part to subtract from potential
c     rs0         user input density cutoff, index=4 only
c     gamach      core hole lifetime
c     vtot(nr)    total potential (coulomb and gs exchange corr)
c     vvalgs(nr)  total coulomb + gs xc potential from valence electrons
c     densty(nr)  electron density
c     dmag(nr)    density magnetization
c     denval(nr)  valence electron density
c     sigmd(51)   average contribution to self-energy from d-electrons
c                 at r>r_mt
c     pgrid(51)   tabulation points on p-grid for sigma_d
c
c     OUTPUT
c     eref        complex energy reference for current energy
c     erefvl     as above for valence-core models (ixc=5,6,7)
c     v(nr)       complex potential including energy dep xc
c     vval(nr)    as above,but xc from valence electrons only
c     em          current energy
c     emp         energy' for first iteration w.f. (valence-core model)
c
c     WORKSPACE
c     vxcrmu and vxcimu are calculated only on first entry for a
c     particular unique potential, re-used on subsequent entries.
c     vxcrmu(nr)  real part of xc at fermi level
c     vxcimu(nr)  imag part of xc at fermi level
c     gsrel(nr) ratio of gs xc potentials with and without magnetization
c     vvxcrm(nr)  real part of xc at fermi level from valence electrons
c     vvxcim(nr)  imag part of xc at fermi level from valence electrons
c
c     This subroutine uses atomic (hartree) units for energy,
c     phase uses rydbergs.  All inputs to and outputs from xcpot are
c     in rydbergs.  (Factor of 2 to convert from one to the other.)


c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)

      dimension   vtot(nrptx), vvalgs(nrptx), densty(nrptx)
      dimension   dmag(nrptx), denval(nrptx)
      complex*16  eref, erefvl, v(nrptx), vval(nrptx)
      dimension   vxcrmu(nrptx), vxcimu(nrptx), sigmd(51), pgrid(51)
      dimension   vvxcrm(nrptx), vvxcim(nrptx), gsrel(nrptx)
      logical lreal

      complex*16  delta, deltav
      character*512 slog
      parameter (tol=0.0004)

c     First calculate vxc to correct the local momentum dispersion
c     relation, delta = vxc(e,k) - vxc(mu,k), and
c               p^2 = k^2 -mu + kf^2 - delta.
c     In jr theory, v(e,r) = vcoul(r) + vxc(e,r) =
c                          = vcoul(r) + vxcgs(r) + delta(e,r).

c    at jri potential is smooth continuation of potential to r(jri)
c    at this point potential jumps to interstitial value at jri+1
      jri1 = jri + 1
      nmax=1
      nul=0
      ibp = index / 10
      ixc = mod(index,10)
      emp = em-xmuval+xmu
c     only for ixc=5,7 xmuval not equal to xmu

      if (ixc .eq. 2 .or. emp.le.xmu)  then
         do 10  i = 1, jri1
            v(i) = vtot(i)
            vval(i) = vvalgs(i)
   10    continue
c        Ground state exchange, no self energy calculation
         goto 888
      endif

c     Add the self energy correction
      do 20  i =  jri1,1,-1
         niter = 0
         rs = (3 / (4*pi*densty(i))) ** third
c        xf = 1.9191.../rs
         xf = fa / rs
         rsm = (3 / (4*pi*densty(i)+dmag(i))) ** third
         xfm = fa / rsm

         if (ixc.eq.5) then
            if ( denval(i) .gt. 0.00001) then
               rsval = (3 / (4*pi*denval(i))) ** third
               if (rsval.gt.10.0) rsval=10.0
            else
               rsval = 10.0
            endif
            xfval = fa / rsval
         elseif (ixc.ge.6) then
            if (densty(i) .le. denval(i) ) then
               rscore = 101.0
            else
               rscore = (3 / (4*pi*(densty(i)-denval(i)))) ** third
            endif
         endif

         if (ifirst .eq. 0)  then
c           vxc_mu indep of energy, calc only once
c           Calculate vxc at fermi level e = mu, j.m. 1/12/89
            xk = xf * 1.00001
            gsrel(i) = 1.0d0
            if (ixc .lt. 5) then
              call sigma(ixc, ibp, rs, rscore, xk, vxcrmu(i), vxcimu(i))
              if (index .eq. 0) then
c  do not need 4 following lines for gs difference in potential
c                xmag = 1.0d0+ dmag(i)/(4*pi*densty(i))
c                call vbh(rs,xmag,v1)
c                call vbh(rs, 1.0d0,v0)
c                if (v0 .ne. 0) gsrel(i) = v1/v0
              endif
            else
              call sigma(nul, ibp, rs, rscore, xk, vxcrmu(i), vxcimu(i))
            endif
            if (ixc.eq.5 ) then
               xkpp = xfval * 1.00001
               call sigma
     1           (ixc, ibp, rsval, rscore, xkpp, vvxcrm(i), vvxcim(i))
            elseif (ixc .ge. 6) then
               call sigma
     1           (ixc, ibp, rs, rscore, xk, vvxcrm(i), vvxcim(i))
               if (ixc.eq.6 .and. i.eq.jri1) then
                  vvxcrm(jri1) =  vxcrmu(jri1)
                  vvxcim(jri1) =  vxcimu(jri1)
               endif
            else
               vvxcrm(i) = 0.0d0
               vvxcim(i) = 0.0d0
            endif
         endif

c        xk2 is the local momentum squared, p^2 = k^2 - mu + kf^2,
c        k^2 represents energy measured from vacuum.
c        See formula 2.15 in Lee and Beni's paper with the last 2
c        terms neglected.  (complete reference?)
c        em is used for valence model, emp - for sigma_total
         xk2 = emp + xf**2 - xmu
         xk = sqrt(xk2)
         xkm2 = em + xfm**2 - xmu
c        quick fix
         if (xkm2.lt.0) xkm2=xk2
         xkm = sqrt(xkm2)

         del0r = 0.0
c        find \delta_1
         if (ixc .lt. 5) then
            call sigma (ixc, ibp, rs, rscore, xk, vxcr, vxci)
         else
            call sigma (nul, ibp, rs, rscore, xk, vxcr, vxci)
         endif
         del1r = gsrel(i) * (vxcr - vxcrmu(i))

c        find \delta_v,1 and \delta_d,1
c        they are special only in interstitial region
         if (i .eq. jri1) then
            if (ixc .eq. 5) then
               xkpp = sqrt(em+xfval**2-xmuval)
               call sigma (ixc, ibp, rsval, rscore, xkpp, vxcvr, vxcvi)
               delv1r = vxcvr-vvxcrm(i)
            elseif (ixc .eq. 6) then
               delv1r = del1r
            elseif (ixc.eq.7) then
               call sigma (ixc, ibp, rs, rscore, xk, vxcvr, vxcvi)
               delv1r = vxcvr-vvxcrm(i)
               call terp (sigmd,pgrid,100,1,xk,sigd1)
c              rhl,edp in a.u., but sigmd in Ry
               delv1r = delv1r + (sigd1 - sigmd(1))/2.0
            endif
         endif

c        Correct local momentum according to the formula
c        p^2 = k^2 - mu + kf^2 - delta.  Note that imag part
c        of delta is ignored, since xk2 is a real quantity.

c        find xk(em) by iterative solution of dyson equation
  50     continue
         xk2 = emp + xf**2 - xmu - 2*del1r
         if (xk2 .lt. 0)  then
            write(slog,'(1pe13.5, 3i8, a)')
     1         xk2, i, ie, iph, ' xk2, i, ie, iph'
            call wlog(slog)
            call wlog(' em, xf**2, xmu, delta')
            write(slog,'(1p, 5e13.5)') em, xf**2, xmu, delta
            call wlog(slog)
            stop 'XCPOT-2'
         endif
         xk = sqrt (xk2)

c        calculate \delta_2 and \delta_v,2 with the corrected
c        local momentum
         call sigma (ixc, ibp, rs, rscore, xk, vxcr, vxci)
c        delta corrected calculated with new local momentum
         delr = gsrel(i) * (vxcr - vxcrmu(i))
         deli = vxci-vxcimu(i)

         if (ixc.ge.5 .and. i.eq.jri1 .and. xk.gt.xf) then
            if (ixc.eq.5) then
               xkpp = sqrt(em-xmuval+xfval**2-delv1r*2)
               call sigma (ixc, ibp, rsval, rscore, xkpp, vxcvr, vxcvi)
               delvr = vxcvr-vvxcrm(i)
               delvi = vxcvi-vvxcim(i)
            elseif (ixc.eq.6) then
               delvr = delr
               delvi = deli
            elseif (xk .gt. xf .and. ixc.eq.7) then
               xkpp = sqrt(em-xmuval+xf**2-delv1r*2)
               call sigma (ixc, ibp, rs, rscore, xkpp, vxcvr, vxcvi)
               delvr = vxcvr-vvxcrm(i)
               delvi = vxcvi-vvxcim(i)
               call terp (sigmd,pgrid,100,1,xkpp,sigd1)
c              rhl,edp in a.u., but sigmd in Ry
               delvr = delvr + (sigd1 - sigmd(1))/2.0
            endif
         endif

         if (niter.lt.nmax) then
            del0r=del1r
            del1r=delr
            del1i=deli
            delv1r=delvr
            delv1i=delvi
            niter=niter+1
            go to 50
         endif

         if (ixc .ge. 5 .and. i.lt.jri1 .and. xk.gt.xf) then
            if (ixc.eq.5) then
               xkpp=sqrt(xk**2-xf**2+xfval**2)
               call sigma (ixc, ibp, rsval, rscore, xkpp, vxcvr, vxcvi)
            else
               call sigma (ixc, ibp, rs, rscore, xk, vxcvr, vxcvi)
            endif
            delvr = vxcvr-vvxcrm(i)
            delvi = vxcvi-vvxcim(i)
         endif

c        Note multiplication by 2 in the exchange correlation part to
c        to convert it to rydberg units.
         delta = dcmplx(delr,deli)
         if (ixc .eq. 5) delta = dcmplx(delr,delvi)
         v(i) = vtot(i) + 2*delta
         if (ixc .ge. 5) then
            deltav = dcmplx(delvr,delvi)
            vval(i) = vvalgs(i) + 2*deltav
         endif
   20 continue
      ifirst = 1

c     Reference the potential with respect to mt potential, ie,
c     first interstitial point.  v(jri1) = 0

c     Note that the reference does not contain the core hole lifetime
c     since the total atomic potential should have it. However in the
c     perturbation  deltav = v - vmt it cancels out.
c     ( deltav = vat - igamma - (vatmt-igamma) ).

 888  eref = v(jri1)
      do 910 i = 1, jri1
  910 v(i) = v(i) - eref
      if (ixc.ge.5) then
         erefvl = vval(jri1)
         do 920 i = 1, jri1
  920    vval(i) = vval(i) - erefvl
      else
         erefvl = eref
         do 930 i = 1, jri1
  930    vval(i) = v(i)
      endif

c     igamma added to the reference so that k^2 = E - Eref, where
c     Eref = Vat(mt) - igamma / 2
      eref = eref - coni * gamach / 2
      if (ixc.gt.4)  erefvl = erefvl - coni * gamach / 2

c     Add const imag part
      eref = eref - coni * vi0
      if (ixc.gt.4)  erefvl = erefvl - coni * vi0


c     Real phase shifts, zero imag part
      if (lreal)  then
         do 950  i = 1, jri1
            v(i) = dble(v(i))
            if (ixc.gt.4)  vval(i) = dble(vval(i))
  950    continue
         eref = dble(eref)
         if (ixc.gt.4)  erefvl = dble(erefvl)
      endif

      return
      end

      subroutine sigma (ixc, ibp, rs, rscore, xk, vr, vi)
      implicit double precision (a-h, o-z)

      if ((ixc.eq.0 .or. ixc.ge.5) .and. ibp .eq. 0) then
         call rhl (rs, xk, vr, vi)
      elseif ((ixc.eq.0.or. ixc.ge.5) .and. ibp .eq. 1) then
         call rhlbp (rs, xk, vr, vi)
      elseif (ixc .eq. 1) then
          vi0 =0.0
         call edp(rs,xk,vi0,vr,vi)
      elseif (ixc .eq. 3) then
          vi0 =0.0
         call edp(rs,xk,vi0,vr,vi)
         call imhl (rs,xk,vi,icusp)
      elseif (ixc .eq. 4)  then
         rstmp = (1/rs**3 - 1/rs0**3) ** (-1./3.)
         call edp(rstmp,xk,vi0,vxcr1,vxci1)
         call rhl(rs0,xk,vxcr2,vxci2)
         vr = vxcr1 + vxcr2
         vi = vxci1 + vxci2
      endif

      if (ixc .ge. 6) then
         vi0 = 0.
         call edp(rscore,xk,vi0,vrp,vip)
         vr = vr - vrp
      endif

      return
      end

      subroutine xsect (dx, x0, ri, ne, em, edge,
     1                  ihole, emu, dgc0, dpc0,
     2                  ixc, lreal, rmt, rcore, xmu, xmuval,
     2                  vi0, rs0, gamach,
     3                  vtot, vvalgs, edens, dmag, edenvl,
     4                  dgcn, dpcn, adgc, adpc, xsec, xsnorm, rkk,
     5                  methat, ifr, iz, xion, sigmd, pgrid)

      implicit double precision (a-h, o-z)

c     INPUT
c     dx, x0, ri(nr)
c                  Loucks r-grid, ri=exp((i-1)*dx-x0)
c     ne, em(ne)   number of energy points, real energy grid
c     edge         chemical potential (energy for k=0)
c     ihole        hole code
c     emu          position of chemical potential in absorption specrum
c     dgc0(nr)     dirac upper component, ground state hole orbital
c     dpc0(nr)     dirac lower component, ground state hole orbital
c     ixc          0  Hedin-Lunqist + const real & imag part
c                  1  Dirac-Hara + const real & imag part
c                  2  ground state + const real & imag part
c                  3  Dirac-Hara + HL imag part + const real & imag part
c                  5  Dirac-Fock exchange with core electrons +
c                     ixc=0 for valence electron density
c     lreal        logical, true for real phase shifts only
c     rmt          r muffin tin
c     xmu          fermi level
c     vi0          const imag part to add to complex potential
c     rs0          user input density cutoff, used only with ixc=4
c     gamach       core hole lifetime
c     vtot(nr)     total potential, including gsxc, final state
c     edens(nr)    density, hole orbital, final state
c     dmag(251)     density magnetization
c     edenvl      valence charge density
c     dgcn(dpcn)   large (small) dirac components for central atom
c     adgc(adpc)   their development coefficients
c     methat       method to calculate atomic cross section
c                  0 - ground state self-energy (index=2)
c                      0 is equivalent to 1 now. ALA 12/96
c                  1 - real part of selfenergy + convolution with
c                      lorentzian with constant width \Gamma
c                  2 - complex selfenergy (need irregular solution)
c                     +conv. with lorentzian with constant width \Gamma
c                  3 - complex selfenergy (need irregular solution) with
c                      arctan correction for Fermi level (in ff2chi)
c
c     OUTPUT
c     xsec(ne)    atomic absorption cross section to multiply \chi
c                 (atomic background for XMCD)
c     xsnorm(ne)  atomic  absorption cross section (norm for XMCD)
c     rkk(ne,-1:1) normalized reduced matrix elements for construction
c                  of termination matrix in genfmt.

c  THIS PROGRAM MAY NEED ADJUSTMENT FOR COMPLEX POTENTIAL (methat=2,3)
c      see comments below

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola

c     max number allowed in xsect r-grid
      parameter (nrx = nrptx, harryd = 2.0d0 )

      dimension ri(nrptx), em(ne), vtot(nrptx), edens(nrptx),dmag(nrptx)
      dimension dgc0(nrptx), dpc0(nrptx), vvalgs(nrptx), edenvl(nrptx)
      dimension sigmd(51), pgrid(51)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30,0:nfrx), adpc(10,30,0:nfrx)
      complex*16 rkk(nex,-1:1)
      dimension bmat(-1:1,-1:1)
c     complex*16 qkk(nex,-2:2)
      dimension xsnorm(ne), xsec(ne)

      dimension xp(nrx), xq(nrx)

c     work space for xcpot
      dimension vxcrmu(nrx), vxcimu(nrx), gsrel(nrx)
      dimension vvxcrm(nrx), vvxcim(nrx)

c     work space for fovrg
      complex*16 p(nrx), q(nrx)

      complex*16  p2, p2val, ck, xkmt
      complex*16  dny, pu, qu
      complex*16  xfnorm, xirf
      complex*16  temp
      complex*16  phx(-1:1)
      complex*16  eref, erefvl, eref1, eref1v

      complex*16 jl,jlp1,nl,nlp1
      complex*16  v(nrx), vval(nrx)
      complex*16  xpc(nrx), xqc(nrx)
      logical lreal, lrealx
      character*512 slog

      call setkap(ihole, kinit, linit)

c     set imt and jri (use general Loucks grid)
c     rmt is between imt and jri (see function ii(r) in file xx.f)
      imt = (log(rmt) + x0) / dx  +  1
      jri = imt+1
      jri1 = jri+1
      if (jri1 .gt. nrptx)  stop 'jri .gt. nrptx in phase'

c     We'll need <i|i> later to normalize dipole matrix elements
c     <i|r|f>.  NB, dgc and dpc are r*wave_fn, so use '0' in somm to
c     get integral  psi**2 r**2 dr.
c     Square the dgc0 and dpc0 arrays before integrating.
c     <i|i> == xinorm.
c     dgc and dpc should be normalized <i|i>=1, check this here
      do 120  i = 1, nrptx
         xp(i) = dpc0(i)**2
         xq(i) = dgc0(i)**2
  120 continue
c     nb, xinorm is used for exponent on input to somm
      xinorm = 2*linit + 2
      call somm (ri, xp, xq, dx, xinorm, 0, jri)
      del = abs (abs(xinorm) - 1)
      if (del .gt. 1.e-2) then
         write(slog,'(a,i8,1p2e13.5)') ' ihole, xinorm ', ihole , xinorm
         call wlog(slog)
c        if using real phase shifts, don't expect great results
         if (.not. lreal)  then
           call wlog(' There may be convergence problems.')
           call wlog(' Xinorm should be 1. If you set the RGRID, '//
     1               'minor interpolation errors ')
           call wlog(' that will not affect final results may occur')
         endif
      endif

      do 230  ireal = 0,1
c     do first calcualtion with real potential to get atomic xsec
c     and second time do calculations with complex potential for
c     reduced matrix elements and central atom phase shifts.
      if (ireal.eq.0) then
         lrealx = .true.
      else
         lrealx = lreal
      endif

c     use ixc for testing
      index = ixc
c     if (methat .eq. 0 .and. ireal.eq.0) then
c       Always use ground state self energy for xsection, quick fix
c       JJR, Jan 93
c       change for testing broadened plasmon pole 6/93
c       index = 2
c   ALA found that it is better to use index=ixc and real part of
c   self-energy for atomic xsection. 12/96
c     endif
      if (pola.eq.2 .or. pola.eq.3) call bcoef(pola,kinit,bmat)

      ifirst = 0
      do 220 ie = 1, ne

         iph = 0
         call xcpot (iph, ie, index, lrealx, ifirst, jri,
     1               em(ie), xmu, xmuval, vi0, rs0, gamach,
     2               vtot, vvalgs, edens, dmag, edenvl, sigmd, pgrid,
     3               eref, erefvl, v, vval, emp,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim)
         if (ie.eq.1) then
            eref1 = eref
            eref1v = erefvl
         endif

c        set the method to calculate atomic cross section
c        p2 is (complex momentum)**2 referenced to energy dep xc
         p2 = emp - eref
         if (mod(index,10) .lt. 5) then
            xkmt = rmt * sqrt (p2+(p2/clight)**2)
         else
c           p2val is for core-valence model. It has the same real part
c           as p2 by construction in xcpot.
            p2val = em(ie) - erefvl
            xkmt = rmt * sqrt (p2val+(p2val/clight)**2)
         endif

         if (mod(index,10) .lt. 5) then
             ncycle = 0
             p2val = p2
         else
c            fix later . may be ncycle can be less
             ncycle = 2
         endif
c        need hartree units for dfovrg
         do 115 i =1, jri1
            v(i) = v(i) / harryd
            vval(i) = vval(i) / harryd
  115    continue
         p2 = p2 / harryd
         p2val = p2val / harryd
         omega = (em(ie) - edge) + emu
         xk0 = omega / clight

         if (ireal.eq.0) xsnorm(ie) = 0.0d0
         do 200 kdif = -1, 1
            rkk(ie,kdif) = 0.0d0
            phx(kdif) = 0.0d0
            if (omega.le.0.0) goto 200
            ikap = kinit + kdif
            if (kdif .eq. 0) ikap = -ikap
            if (ikap .eq. 0) goto 200

            irr = -1
            ic3=0
            call dfovrg ( ncycle, ikap, rmt, jri, jri, p2, p2val, dx,
     1      ri, v, vval, dny, dgcn, dpcn, adgc, adpc,
     2               pu, qu, p, q,
     3               ifr, iz, ihole, xion, irr, ic3)

            lfin = ikap
            if (ikap .lt. 0) lfin = - ikap - 1
            call exjlnl (xkmt, lfin, jl, nl)
            call exjlnl (xkmt, lfin+1, jlp1, nlp1)

            temp = (jl*(dny-lfin) + xkmt*jlp1)  /
     1             (nl*(dny-lfin) + xkmt*nlp1)
            xx = dble (temp)
            yy = dimag(temp)
            if (xx .ne. 0)  then
               alph = (1 - xx**2 - yy**2)
               alph = sqrt(alph**2 + 4*xx**2) - alph
               alph = alph / (2 * xx)
               alph = atan (alph)
            else
               alph = 0
            endif
            beta = (xx**2 + (yy+1)**2) /
     1             (xx**2 + (yy-1)**2)
            beta = log(beta) / 4

            phx(kdif) = dcmplx (alph, beta)

c           ATOM,  dgc0 is large component, ground state hole orbital
c                  dpc0 is small component, ground state hole orbital
c           FOVRG, p   is large component, final state photo electron
c                  q   is small component, final state photo electron

c           Normalize final state by
c           xfnorm = rmt*(jl*cos(delta) - nl*sin(delta))/ Rl(rmt)
c           Rl(rmt) = Re (p (rmt))
c           Messiah's nl = - Abramowitz's yl.
c           fix later : pu can be zero!
            xfnorm = rmt * (jl*cos(phx(kdif))-nl*sin(phx(kdif))) /pu
c           \pi jumps in phases affect only cross terms (k1.ne.k2)
c           imp. for cross terms in MCD. need phases with 2\pi precision
c           quick fix by ala 05.07.96
            if ( dble(xfnorm) .lt. 0.0d0) then
               xfnorm = - xfnorm
               phx(kdif) = phx(kdif) + pi
            endif

c           xirf = <i |p| f> relativistic version of dipole m.e.
c           from Grant,Advan.Phys.,v.19,747(1970) eq. 6.30, using
c           Messiah's "Q.M." appendices to reduce 9j,3j symbols
c           to simple coefficients xmult1,2. ala 12.12.95
            twoj = 2.0d0*abs(kinit) - 1.0d0
            if (kdif.eq.-1 .and. kinit.gt.0) then
               xmult1 = 0.0d0
               xmult2 = sqrt(2.0d0 * (twoj+1)*(twoj-1)/twoj )
            elseif (kdif.eq.-1 .and. kinit.lt.0) then
               xmult1 = 0.0d0
               xmult2 = - sqrt(2.0d0 * (twoj+1)*(twoj+3)/(twoj+2) )
            elseif (kdif.eq. 0 .and. kinit.gt.0) then
               xmult1 = - sqrt( (twoj+1)*twoj/(twoj+2) )
               xmult2 = - sqrt( (twoj+1)*(twoj+2)/twoj )
            elseif (kdif.eq. 0 .and. kinit.lt.0) then
               xmult1 = sqrt( (twoj+1)*(twoj+2)/twoj )
               xmult2 = sqrt( (twoj+1)*twoj/(twoj+2) )
            elseif (kdif.eq. 1 .and. kinit.gt.0) then
               xmult1 = sqrt(2.0d0 * (twoj+1)*(twoj+3)/(twoj+2) )
               xmult2 = 0.0d0
            elseif (kdif.eq. 1 .and. kinit.lt.0) then
               xmult1 = - sqrt(2.0d0 * (twoj+1)*(twoj-1)/twoj )
               xmult2 = 0.0d0
            endif
c           do 190  i = 1, nrptx : fix later for outer shells
            do 190  i = 1, jri
c              xj0 = 1.0d0
               xj0 = sin(xk0*ri(i))/(xk0*ri(i))
               xpc(i) = (xmult1*dgc0(i)*q(i)+xmult2*dpc0(i)*p(i)) * xj0
c              for nonrelativistic test
c              xpc(i) = dgc0(i)*ri(i)*p(i)
               xqc(i) = 0.0d0
  190       continue
            xirf=lfin+linit+2
            call csomm (ri, xpc, xqc, dx, xirf, 0, jri)
            xirf= xirf * xfnorm
c           note that for real potential  xirf is real or reduced matrix
c           element for dipole transition is pure imaginary.
            rkk(ie,kdif)=coni*xirf
            if (ireal.eq.0) xsnorm(ie)=xsnorm(ie) + dble(xirf**2)/3.0d0
  200    continue

c        quadrupole transition
c        do 300 jdif= -2, 2
c           qkk(ie,jdif)=0.0d0
c           jfin=abs(kinit)+jdif
c           if (jfin.le.0) goto 300
c           ikap= jfin
c           if (kinit.lt.0 .and. abs(jdif).ne.1) ikap=-jfin
c           if (kinit.gt.0 .and. abs(jdif).eq.1) ikap=-jfin
c
c           irr = -1
c           ic3 = 0
c           call dfovrg ( ncycle, ikap, rmt, jri, jri, p2, p2val, dx,
c    1      ri, v, vval, dny, dgcn, dpcn, adgc, adpc,
c    2               pu, qu, p, q,
c    3               ifr,iz,ihole,xion,irr,ic3)

c           lfin=ikap
c           if(ikap.lt.0) lfin=-ikap-1
c           call exjlnl (xkmt, lfin, jl, nl)
c           call exjlnl (xkmt, lfin+1, jlp1, nlp1)

c           temp = (jl*(dny-lfin) + xkmt*jlp1)  /
c    1             (nl*(dny-lfin) + xkmt*nlp1)
c           xx = dble (temp)
c           yy = dimag(temp)
c           if (xx .ne. 0)  then
c              alph = (1 - xx**2 - yy**2)
c              alph = sqrt(alph**2 + 4*xx**2) - alph
c              alph = alph / (2 * xx)
c              alph = atan (alph)
c           else
c              alph = 0
c           endif
c           beta = (xx**2 + (yy+1)**2) /
c    1             (xx**2 + (yy-1)**2)
c           beta = log(beta) / 4

c           phx = dcmplx (alph, beta)

c           ATOM,  dgc0 is large component, ground state hole orbital
c                  dpc0 is small component, ground state hole orbital
c           FOVRG, p   is large component, final state photo electron
c                  q   is small component, final state photo electron

c           Normalize final state by
c           xfnorm=rmt*(jl*cos(delta)-nl*sin(delta))/Rl(rmt)/(2*lfin+1)
c           Rl(rmt) = Re (p (rmt))
c           Messiah's nl = - Abramowitz's yl.
c           fix later : pu can be zero!
c           xfnorm = ri(jri) * (jl*cos(phx) - nl*sin(phx)) / pu

c           xirf = <i |p| f> relativistic version of dipole m.e.
c           from Grant,Advan.Phys.,v.19,747(1970) eq. 6.30, using
c           Messiah's "Q.M." appendices to reduce 9j,3j symbols
c           to simple coefficients xmult1,2. ala 12.12.95
c           twoj = 2.0d0*abs(kinit) - 1.0d0
c           if (jdif.eq.2 .and. kinit.lt.0) then
c              xmult1 = 0.0d0
c              xmult2 = - sqrt(0.9d0 * (twoj+1)*(twoj+3)*(twoj+5)
c    1                                /(twoj+2)/(twoj+4) )
c           elseif (jdif.eq.1 .and. kinit.lt.0) then
c              xmult1 = sqrt(0.225d0 * (twoj+1)*(twoj+3)*(twoj+4)
c    1                                /twoj/(twoj+2))
c              xmult2 = sqrt(0.225d0 * twoj *(twoj+1)*(twoj+3)
c    1                                /(twoj+2)/(twoj+4))
c           elseif (jdif.eq.0 .and. kinit.lt.0) then
c              xmult1 = - sqrt(0.15d0 * (twoj-1)*(twoj+1)*(twoj+3)
c    1                                /twoj/(twoj+2))
c              xmult2 = sqrt(0.15d0 * (twoj-1)*(twoj+1)*(twoj+3)
c    1                                /twoj/(twoj+2))
c           elseif (jdif.eq.-1 .and. kinit.lt.0) then
c              xmult1 = - sqrt(0.225d0 * (twoj-1)*(twoj-1)*(twoj+2)
c    1                                /twoj/(twoj-2))
c              xmult2 = - sqrt(0.225d0 * (twoj-2) *(twoj-1)*(twoj+1)
c    1                                /twoj/(twoj+2))
c           else
c              xmult1=0.0
c              xmult2=0.0
c           endif
c           do 290  i = 1, jri
c              arg = xk0*ri(i)
c              xj1 = sin(arg)/arg**2 - cos(arg)/arg
c              xpc(i) = (xmult1*dgc0(i)*q(i)+xmult2*dpc0(i)*p(i)) * xj1
c              xqc(i) = 0.0d0
c 290       continue
c           xirf=lfin+linit+3
c           call csomm (ri, xpc, xqc, dx, xirf, 0, jri)
c           xirf= xirf * xfnorm
c           qkk(ie,jdif)=xirf * exp(coni * phx)
c 300    continue

c        fix later : normalization and atomic xsection for complex
c        potential may be xnorm = sum_{kdif} |rkk(kdif)|**2 /3.0
         if (omega.gt.0.0) then
            xnorm= sqrt( xsnorm(ie) )
            do 215 kdif = -1 , 1
  215       rkk(ie,kdif)= rkk(ie,kdif) / xnorm
         endif

c        do 216 jdif = -2 , 2
c 216    qkk(ie,jdif)= qkk(ie,jdif) / xnorm
c        print*,ie,real(abs(rkk(ie,-1))**2)/3.0
c    1     ,real(abs(rkk(ie,0))**2)/3.0,real(abs(rkk(ie,1))**2)/3.0
c    1     ,real(abs(qkk(ie,-1))**2)/5.0,real(abs(qkk(ie,0))**2)/5.0


c        prefac = (8 * pi / 3)  * alphfs * omega  -- nonrelativistic
c        relativistic is (for alpha form)
         if (omega.gt.0.0) then
            prefac = 4 * pi * clight / omega * bohr**2
            ck = xkmt / rmt
            if (ireal.eq.0) then
              xsnorm(ie) =  dble( xsnorm(ie) * prefac * (2*ck) )
            else
c             put complex prefactor into reduced matrix elements rkk
              ck = sqrt ( prefac * (2*ck))
              if (dimag(ck) .lt. 0) ck = -ck
c             guarantee that we have the right root
            endif
         endif

         if (ireal.eq.0) then
            if (pola .eq. 2 .or. pola .eq. 3) then
c              xsec(ie) is normalized (to xsnorm) atomic XMCD
               xsec(ie) = 0.0d0
               do 210 k1 = -1,1
               do 210 k2 = -1, 1
                 xsec(ie)=xsec(ie) -
     1           dble(rkk(ie,k1) * rkk(ie,k2)) * bmat(k1,k2)
  210          continue
               xsec(ie) = xsec(ie) * xsnorm(ie)
            else
               xsec(ie) = xsnorm(ie)
            endif
         else
c           add central atom phase shift here.
            do 211 kdif = -1,1
  211       rkk(ie,kdif) = rkk(ie,kdif) * exp(coni * phx(kdif)) * ck
         endif
  220 continue

  230 continue

      return
      end
      double precision function xstar (eps1, eps2, vec1, vec2, ndeg)
      implicit double precision (a-h, o-z)
c     calculating nstar=deg*cos(eps r1)*cos(eps rN)
c     written by alexei ankudinov 08.13.96
c     calculate the plane wave approximation for central atom
c     vec1 - direction to the first atom in path
c     vec2 - direction to the last atom in path
c     ndeg - may be not equal to 'deg' in diff. paths
c             subroutines
c     the rest of the data is passed through commons.

c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'pdata.h'
c     Note that leg nleg is the leg ending at the central atom, so that
c     ipot(nleg) is central atom potential, rat(nleg) position of
c     central atom.
c     Central atom has ipot=0
c     For later convience, rat(,0) and ipot(0) refer to the central
c     atom, and are the same as rat(,nleg), ipot(nleg).

c     text and title arrays include carriage control
      character*80 text, title
      character*6  potlbl
      common /str/ text(40),
     1             title(5),
     1             potlbl(0:npotx)

      complex*16 ph, eref
      common /pdata/ ph(nex,ltot+1,0:npotx),
     *               eref(nex),
     *               rat(3,0:legtot+1),
     *               em(nex),
     *               ri(legtot), beta(legtot+1), eta(0:legtot+1),
     *               deg, rnrmav, xmu, edge,
     *               lmax(nex,0:npotx),
     *               ipot(0:legtot),
     *               iz(0:npotx),
     *               ltext(40), ltitle(5),
     *               nsc, nleg,
     *               npot, ne,
     *               ik0,
     *               methfs,
     *               ipath,
     *               ihole,
     *               kinit, linit, ilinit,
     *               lkap(-1:1), ilk(-1:1), jkap(-1:1),
     *               lmaxp1,
     *               ntext, ntitle
c     include 'pola.h'
c     global polarization data
      integer  pola
      double precision evec,xivec,elpty
      complex*16 ptz
      common /pol/ ptz(-1:1,-1:1), evec(3), xivec(3), elpty, pola
      dimension eps1(3), eps2(3), vec1(3), vec2(3)

      lfin = ilinit
      x = xcos(vec1, vec2)
      if (pola .ne. 1) then
c       does polycrystalline average in case of xmcd or spxas. ala.
        iav = 0
        y = 0
        z = 0
        xstar = ndeg * ystar(lfin, x, y, z, iav)
      else
c       do not do polarization average only if POLARIZATION is used
        iav = 1
        y = xcos(eps1,vec1)
        z = xcos(eps1,vec2)
        xtemp = ystar(lfin, x, y, z, iav)
        if (elpty .ne. 0.0) then
          y = xcos(eps2,vec1)
          z = xcos(eps2,vec2)
          xtemp = xtemp + elpty**2 * ystar(lfin, x, y, z, iav)
        endif
        xstar = ndeg * xtemp /(1+elpty**2)
      endif
      return
      end

      double precision function xcos (veca, vecb)
      implicit double precision (a-h, o-z)
      dimension veca(3), vecb(3)

      x1 = 0
      do 23 j = 1,3
         x1 = x1 + veca(j) * vecb(j)
   23 continue
      xnorma = 0
      xnormb = 0
      do 24 j = 1,3
         xnorma = xnorma + veca(j)**2
         xnormb = xnormb + vecb(j)**2
   24 continue
      xcos = x1/sqrt(xnorma*xnormb)
      return
      end

      double precision function ystar (lfin, x , y, z, iav)
      implicit double precision (a-h, o-z)
c
      dimension pln (0:4,4)
      data pln /0.0  , 1.0, 0.0 , 0.0, 0.0,
     2         -0.5  , 0.0, 1.5 , 0.0, 0.0,
     3          0.0  ,-1.5, 0.0 , 2.5, 0.0,
     4          0.375, 0.0,-3.75, 0.0, 4.375/

      pln0  = pln(0,lfin)
      do 40 i = 1, lfin
         pln0  = pln0  + pln(i, lfin) * x**i
  40  continue
      if (iav.eq.0) then
         ystar = pln0/(2*lfin+1)
      else
         pln1  = pln(1,lfin)
         do 50 i = 2, lfin
            pln1  = pln1  + pln(i, lfin)*i*x**(i-1)
  50     continue
         pln2  = 2* pln(2,lfin)
         do 60 i = 3, lfin
            pln2  = pln2  + pln(i, lfin)*i*(i-1)*x**(i-2)
  60     continue
         ytemp = - lfin*pln0 + pln1*(x+y*z) - pln2*(y**2+z**2-2*x*y*z)
         ystar = ytemp * 3/lfin/(4*lfin**2-1)
      endif
      return
      end
      double precision function xx (j)
      implicit double precision (a-h, o-z)
c     x grid point at index j, x = log(r), r=exp(x)
      parameter (delta = 0.050 000 000 000 000)
      parameter (c88   = 8.800 000 000 000 000)
c     xx = -8.8 + (j-1)*0.05
      xx = -c88 + (j-1)*delta
      return
      end

      double precision function rr(j)
      implicit double precision (a-h, o-z)
c     r grid point at index j
      rr = exp (xx(j))
      return
      end

      function ii(r)
      implicit double precision (a-h, o-z)
c     index of grid point immediately below postion r
      parameter (delta = 0.050 000 000 000 000)
      parameter (c88   = 8.800 000 000 000 000)
c     ii = (log(r) + 8.8) / 0.05 + 1
      ii = (log(r) + c88) / delta + 1
      return
      end
      subroutine custom (nkx, achi, xk, zzkmin, zzkmax, zzport)
      implicit double precision (a-h, o-z)

      dimension xk(nkx)
      dimension achi(nkx)

c     does custom filtering for ff2chi

c     find integration limits
      do 100  i = 1, nkx
         if (xk(i) .ge. zzkmin)  then
            imin = i
            goto 110
         endif
  100 continue
  110 continue
      do 200  i = nkx, 1, -1
         if (xk(i) .le. zzkmax)  then
            imax = i
            goto 210
         endif
  200 continue
  210 continue
c     trap is not defined for one point
      if (imin .eq. imax)  imax = imax+1

c     integrate from imin to imax
      nnn = imax - imin + 1
      call trap (xk(imin), achi(imin), nnn, zzport)
      return
      end
      double precision function aprdev (a,b,l)
c     the result of this function is the coefficient for the term of
c     power (l-1) for the product of two polynomes, whose coefficients
c     are in rows a and b

      implicit double precision (a-h,o-z)
      dimension a(10),b(10)

      aprdev=0.0d 00
      do 11 m=1,l
 11      aprdev=aprdev+a(m)*b(l+1-m)
      return
      end
      complex*16  function aprdec(ala,bla,lla)
c     the result of this function is the coefficient for the term of
c     power (l-1) for the product of two polynomes, whose coefficients
c     are in rows a and b

      implicit double precision (a-h, o-z)
      complex*16 ala (10)
      integer lla
      dimension bla(10)

      aprdec = (0.0d0, 0.0d0)
      do 11 m = 1, lla
 11      aprdec = aprdec + ala(m) * bla(lla+1-m)
      return
      end
      double precision function akeato (i,j,k)
c     angular coefficient by the direct coulomb integral fk for orbitals
c     i and j
      implicit double precision (a-h,o-z)
      common/mulabk/afgk
      dimension afgk(30,30,0:3)

c     afgk angular coefficients by integrales fk and gk
c        coefficient of integral fk(i;j) is in  afgk(min,max)
c        and that of integral gk(i;j) is in  afgk(max,min)
c        max=max(i,j) min=min(i,j)

      if (i .le. j) then
         akeato=afgk(i,j,k/2)
      else
         akeato=afgk(j,i,k/2)
      endif
      return

      entry bkeato (i,j,k)
c     angular coefficient at the exchange coulomb integral gk

      bkeato=0.0d 00
      if (i .lt. j) then
         bkeato=afgk(j,i,k/2)
      elseif (i.gt.j) then
         bkeato=afgk(i,j,k/2)
      endif
      return
      end
      subroutine bkmrdf (i,j,k)
c     angular coefficients for the breit term. i and j are the numbers
c     of orbitals and  k is the value of k in uk(1,2)
c        this programm uses cwig3j
c     coefficients for magnetic interaction  are in cmag
c     and those for retarded term are in cret
c     the order correspond to -1 0 and +1

      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabre/cmag(3),cret(3)

      do 12 l=1,3
        cmag(l)=0.0d 00
 12     cret(l)=0.0d 00
      ji=2* abs(kap(i))-1
      jj=2* abs(kap(j))-1
      kam=kap(j)-kap(i)
      l=k-1
      do 51 m=1,3
         if (l.lt.0) go to 51
         a=cwig3j(ji,jj,l+l,-1,1,2)**2
         if (a.eq.0.0d 00) go to 51
         c=l+l+1
         if (m-2) 14,16,17
 14      cm=(kam+k)**2
         cz=kam*kam-k*k
         cp=(k-kam)**2
         n=k
 15      l1=l+1
         am=(kam-l)*(kam+l1)/c
         az=(kam*kam+l*l1)/c
         ap=(l+kam)*(kam-l1)/c
         d=n*(k+k+1)
         go to 31

 16      d=k*(k+1)
         cm=(kap(i)+kap(j))**2
         cz=cm
         cp=cm
         go to 41

 17      cm=(kam-l)**2
         cz=kam*kam-l*l
         cp=(kam+l)**2
         n=l
         c=-c
         go to 15

 31      c= abs(c)*d
         if (c.ne.0.0d 00) c=n/c
         cret(1)=cret(1)+a*(am-c*cm)
         cret(2)=cret(2)+(a+a)*(az-c*cz)
         cret(3)=cret(3)+a*(ap-c*cp)
 41      if (d.eq.0.0d 00) go to 51
         a=a/d
         cmag(1)=cmag(1)+cm*a
         cmag(2)=cmag(2)+cz*(a+a)
         cmag(3)=cmag(3)+cp*a
 51      l=l+1
      return
      end
      subroutine cofcon (a,b,p,q)
c     acceleration of the convergence in the iterative process
c     b is the part of final iteration n is a function of the error (p)
c     (p) at iteration n and the error (q) at the iteration n-1.
c     if the product p*q is positive  b is increased by 0.1
c                        zero b is unchanged
c                        negative b is decreased by 0.1
c     b is between 0.1 and 0.9
c                a = 1. - b
c     ** at the end makes q=p
c
      implicit double precision (a-h,o-z)

      if (p*q)  11,31,21
 11   if (b .ge. 0.2) b = b - 0.1
      go to 31

 21   if (b .le. 0.8) b = b + 0.1

 31   a = 1.0 - b
      q=p
      return
      end
      subroutine cofcoc (a,b,p,q)
c     acceleration of the convergence in the iterative process
c     b is the part of final iteration n is a function of the error (p)
c     (p) at iteration n and the error (q) at the iteration n-1.
c     if the product p*q is positive  b is increased by 0.1
c                        zero b is unchanged
c                        negative b is decreased by 0.1
c     b is between 0.1 and 0.9
c                a = 1. - b
c     ** at the end makes q=p
c
      implicit double precision (a-h,o-z)
      complex*16 p,q

      h=real( p*conjg(q))
      if (h)  11,31,21
 11   if (b .ge. 0.2) b = b - 0.1
      go to 31

 21   if (b .le. 0.8) b = b + 0.1

 31   a = 1.0 - b
      q=p
      return
      end
      double precision function cwig3j (j1,j2,j3,m1,m2,ient)
c     wigner 3j coefficient for integers  (ient=1)
c                         or semiintegers (ient=2)
c     other arguments should be multiplied by ient

      implicit double precision (a-h,o-z)
      parameter (idim = 58)
      character*512 slog
c     dimensions  modified for larger arguments by ala 12.12.94
      dimension al(idim+1),m(12)
      save ini, al
      data ini/1/
c     idim-1 is the largest argument of factorial to calculate

      m3=-m1-m2
      if (ini) 1,21,1
c        initialisation of the log's of the factorials
 1    ini=0
      al(1)=0.0d 00
      do 11 i=1,idim
         b=i
 11      al(i+1)=al(i)+ log(b)
 21   cwig3j=0.0d 00
      if (((ient-1)*(ient-2)).ne.0) go to 101
      ii=ient+ient
c        test triangular inequalities, parity and maximum values of m
      if (( abs(m1)+ abs(m2)).eq.0.and.mod(j1+j2+j3,ii).ne.0) go to 99
      m(1)=j1+j2-j3
      m(2)=j2+j3-j1
      m(3)=j3+j1-j2
      m(4)=j1+m1
      m(5)=j1-m1
      m(6)=j2+m2
      m(7)=j2-m2
      m(8)=j3+m3
      m(9)=j3-m3
      m(10)=j1+j2+j3+ient
      m(11)=j2-j3-m1
      m(12)=j1-j3+m2
      do 41 i=1,12
         if (i.gt.10) go to 31
         if (m(i).lt.0) go to 99
 31      if (mod(m(i),ient).ne.0) go to 101
         m(i)=m(i)/ient
         if (m(i).gt.idim) go to 101
 41   continue

c        calculate 3j coefficient
      max0= max(m(11),m(12),0)+1
      min0= min(m(1),m(5),m(6))+1
      isig=1
      if (mod(max0-1,2).ne.0) isig=-isig
      c=-al(m(10)+1)
      do 61 i=1,9
 61   c=c+al(m(i)+1)
      c=c/2.0d 00
      do 71 i=max0,min0
      j=2-i
      b=al(i)+al(j+m(1))+al(j+m(5))+al(j+m(6))+al(i-m(11))+al(i-m(12))
      cwig3j=cwig3j+isig* exp(c-b)
 71   isig=-isig
      if (mod(j1-j2-m3,ii).ne.0) cwig3j=-cwig3j
 99   return
 101     write(slog,'(a,6i5)') 'error in cwig3j ',j1,j2,j3,m1,m2,ient
         call wlog(slog)
      stop
      end
      double precision function dentfa (dr,dz,ch)
c     analitical approximation of potential is created for electrons in
c     thomas-fermi model for atom or free ion. dr distance from nucleus
c     with charge dz
c     ch=ionicity = number of electrons-dz-1
      implicit double precision (a-h,o-z)

      dentfa=0.0d 00
      if ((dz+ch).lt.1.0d-04) return
      w=dr*(dz+ch)**(1./3.)
      w=sqrt(w/0.8853)
      t=w*(0.60112*w+1.81061)+1.
      w=w*(w*(w*(w*(0.04793*w+0.21465)+0.77112)+1.39515)+1.81061)+1
      dentfa=(dz+ch)*(1.0d 00-(t/w)**2)/dr
      return
      end
      double precision function dsordf (i,j,n,jnd,a)
c              * calculation of diff. integrals*
c        integration by simpson method of the   hg*(r**n)
c        hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)  if jnd=1
c        hg=expression above multiplied by  dg  if jnd=-1
c        hg(l)=cg(l,i)*cp(l,j)                  if jnd=2
c        hg=expression above multiplied by  dg  if jnd=-2
c        hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j)      if jnd=3
c        hg(l)=dg(l)*dg(l)+dp(l)*dp(l)          if jnd=4
c        hg is constructed by calling program   if jnd>=5
c                  cg(l,i)  large component of the orbital i
c                  cp(l,j)  small component of the orbital j
c        a is such that dg,dp or hg following the case
c        behave at the origin as cte*r**a
c        the integration is made as far as dr(j) for jnd>3
c
c        the development limits at the origin (used for calculation
c        of integral form 0 to dr(1) ) of functions dg,dp and hg are
c        supposed to be in blocks ag,ap and chg respectively
c        this program uses  aprdev
c
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1         fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
      dimension hg(251),chg(10)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      dimension bgi(10),bgj(10),bpi(10),bpj(10)

c        construction of the array hg
      if (jnd.le.3) go to 11
      max0=j
      b=a
      go to 101

 11   max0= min(nmax(i),nmax(j))
      do  15 l= 1,ibgp
        bgi(l) = bg(l,i)
        bgj(l) = bg(l,j)
        bpi(l) = bp(l,i)
 15     bpj(l) = bp(l,j)
      if ( abs(jnd)-2) 21,55,101
 21   do 31 l=1,max0
 31      hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)
      do 45 l=1,ndor
 45   chg(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l)
      go to 81

 55   do 61 l=1,max0
 61      hg(l)=cg(l,i)*cp(l,j)
      do 71 l=1,ndor
 71      chg(l)=aprdev(bgi,bpj,l)
 81   b=fl(i)+fl(j)
      if (jnd.gt.0) go to 301

      do 85 l=1,max0
 85      hg(l)=hg(l)*dg(l)
      do 87 l=1,ndor
 87      ap(l)=chg(l)
      b=b+a
      do 95 l=1,ndor
 95      chg(l)=aprdev(ap,ag,l)
      go to 301

 101  if (jnd-4) 201,111,301
 111  do 121 l=1,max0
 121     hg(l)=dg(l)*dg(l)+dp(l)*dp(l)
      b=b+b
      do 131 l=1,ndor
 131     chg(l)=aprdev(ag,ag,l)+aprdev(ap,ap,l)
      go to 301

 201  do 221 l=1,max0
 221     hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j)
      b=a+fl(i)
      do 241 l=1,ndor
 241     chg(l)=aprdev(bgi,ag,l)+aprdev(bpj,ap,l)

c        integration of the hg
 301  dsordf=0.0d 00
      io=n+1
      do 305 l=1,max0
 305     hg(l)=hg(l)*(dr(l)**io)
      do 311 l=2,max0,2
 311     dsordf=dsordf+hg(l)+hg(l)+hg(l+1)
      dsordf=hx*(dsordf+dsordf+hg(1)-hg(max0))/3.0d 00
c        integral from 0 to dr(1)
      b=b+n
      do 331 l=1,ndor
         b=b+1.0d 00
 331     dsordf=dsordf+chg(l)*(dr(1)**b)/b
      return
      end
      complex*16 function dsordc(j,a,dg,dp,ag,ap)
c              * calculation of overlap integrals*
c        integration by simpson method of the   hg*(r**0)
c        hg(l)=dg(l)*cg(l,j)+dp(l)*cp(l,j)
c                cg,cp(l,j)  orbital j
c        a is such that dg,dp or hg following the case
c        behave at the origin as cte*r**a
c        the development limits at the origin (used for calculation
c        of integral form 0 to dr(1) ) of functions dg,dp and hg are
c        supposed to be in blocks ag,ap and chg respectively
c        this program uses   aprdec
c
      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      complex*16 aprdec
      common/dff/ cg(nrptx,30), cp(nrptx,30), bg(10,30), bp(10,30),
     1              fl(30), fix(30), ibgp
      complex*16 dg(nrptx),ag(10),dp(nrptx),ap(10)
      complex*16 hg(nrptx),chg(10)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1   nq(30),kap(30),nmax(30)
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)

c        construction of the array hg
      do  15 l= 1,ibgp
        bgj(l) = bg(l,j)
 15     bpj(l) = bp(l,j)

      do 221 l=1,idim
 221  hg(l)=dg(l)*cg(l,j)+dp(l)*cp(l,j)
      b=a+fl(j)
      do 241 l=1,ndor
 241     chg(l) = aprdec(ag,bgj,l) + aprdec(ap,bpj,l)

c        integration of the hg
 301  dsordc = (0.0d0, 0.0d0)
      do 305 l=1,idim
 305     hg(l)=hg(l)*dr(l)
      do 311 l=2,idim,2
 311     dsordc=dsordc+hg(l)+hg(l)+hg(l+1)
      dsordc=hx*(dsordc+dsordc+hg(1)-hg(idim))/3.0d0
c        integral from 0 to dr(1)
      do 331 l=1,ndor
         b=b+1.0d 00
 331     dsordc=dsordc+chg(l)*(dr(1)**b)/b
      return
      end
      subroutine etotal (io, kap, xnel, xnval, en, eatom)
c combined from original subroutines tabfgk,tabbre,tabrat.
c io  label for output file atomNN.dat
c kap quantum number "kappa"
c xnel occupation of  orbitals
c en one-electron energies
c fdrirk function calculating radial integrals rk
c akeato angular coefficient for integrals  fk, for the
c integrals fk(i;i) gives angular coefficients multiplied by 2
c bkeato angular coefficient for integrals  gk
c coul ener(1) direct coulomb interaction
c ech  ener(2) exchange coulomb interaction
c        * average value of the breit hamiltonian *
c fdrocc function of the orbitals' occupations.
c bkmrdf is a programm to calculate angular coefficients
c ema ener(3) magnetic energy
c ere ener(4) retardation term
c        this program uses akeato,bkeato
c        fdrocc fdrirk bkmrdf

      implicit double precision (a-h,o-z)
      dimension kap(30),xnel(30),en(30), xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      dimension mk(12),ener(4)
      dimension cer(17),mbi(9),mii(9),mjj(9)
      common/tabre/cmag(3),cret(3)
      common/inelma/nem
      common/print/iprint
      character*4 iner(4)
      data iner/'coul','ech.','mag.','ret.'/

      do 10 i = 1,4
 10   ener(i)=0.0d 00
      iv=0
c       fk  integrales
      do 40 i=1,norb
         l= abs(kap(i))-1
         do 40 j=1,i
            a=1.0d 00
            if (j.eq.i) a=a+a
            m= abs(kap(j))-1
            kmi=2* min(l,m)
            k=0
 20         iv=iv+1
            cer(iv)=fdrirk(i,i,j,j,k)
            ener(1) = ener(1) + cer(iv) * akeato(i,j,k) / a
            mk(iv)=k
            if (iv.lt.3) go to 30
            iv=0
 30         k=k+2
            if (k.le.kmi) go to 20
 40   continue
      iv=0
      if (norb.gt.1) then
c       gk  integrales
      do 70 i=2,norb
         a = 1.0d0
         if (xnval(i) .gt. 0.0d0) a=0.5d0
         i1=i-1
         do 70 j=1,i1
            if (xnval(j) .gt. 0.0d0) goto 70
            l= abs(kap(i))
            m= abs(kap(j))
            k= abs(l-m)
            if ((kap(i)*kap(j)).lt.0) k=k+1
            kmi=l+m-1
 50         iv=iv+1
            cer(iv)=fdrirk(i,j,i,j,k)
            ener(2) = ener(2) - cer(iv) * bkeato(i,j,k) * a
            mk(iv)=k
            if (iv.lt.3) go to 60
            iv=0
 60         k=k+2
            if (k.le.kmi) go to 50
 70   continue
      endif
c
      nem=1
c       direct  integrals
      ik=0
      do 140 j=1,norb
         jj=2* abs(kap(j))-1
         do 140 i=1,j
            ji=2* abs(kap(i))-1
            k=1
            kma= min(ji,jj)
 110        ik=ik+1
            mbi(ik)=k
            mii(ik)=i
            mjj(ik)=j
            cer(ik)=fdrirk(j,j,i,i,k)
            if (i.ne.j) go to 120
            call bkmrdf (j,j,k)
            ener(3) = ener(3) + (cmag(1) + cmag(2) + cmag(3)) *
     1                cer(ik) * fdmocc(j,j) / 2.0d 00
 120        if (ik.lt.3) go to 130
            ik=0
 130        k=k+2
            if (k.le.kma) go to 110
 140  continue
      if (norb.gt.1) then
c       echange  integrals
      do 201 j=2,norb
         lj= abs(kap(j))
         na=-1
         if (kap(j).gt.0) go to 121
         na=-na
         lj=lj-1
 121     jp=j-1
         do 201 l=1,jp
            ll= abs(kap(l))
            nb=-1
            if (kap(l).gt.0) go to 131
            nb=-nb
            ll=ll-1
 131        b=fdmocc(j,l)
            nm1= abs(lj+na-ll)
            nmp1=ll+lj+nb
            nmm1=ll+lj+na
            np1= abs(ll+nb-lj)
            k= min(nm1,np1)
            kma=max(nmp1,nmm1)
            if (mod(k+ll+lj,2).eq.0) k=k+1
            nb= abs(kap(j))+ abs(kap(l))
 141        call bkmrdf (j,l,k)
            do 151 i=1,3
 151           cer(i)=0.0d 00
            if (nb.le.k.and.kap(l).lt.0.and.kap(j).gt.0) go to 161
            cer(1)=fdrirk(l,j,l,j,k)
            cer(2)=fdrirk(0,0,j,l,k)
 161        if (nb.le.k.and.kap(l).gt.0.and.kap(j).lt.0) go to 171
            cer(3)=fdrirk(j,l,j,l,k)
            if (cer(2).ne.0.0d 00) go to 171
            cer(2)=fdrirk(0,0,l,j,k)
 171        do 185 i = 1, 3
               ener(3) = ener(3) + cmag(i) * cer(i) * b
               ener(4) = ener(4) + cret(i) * cer(i) * b
 185        continue
            k=k+2
            if (k.le.kma) go to 141
 201  continue
      endif

c     total   energy
      eatom = - (ener(1) + ener(2)) + ener(3) + ener(4)
      do 212 j = 1, norb
 212     eatom = eatom + en(j) * xnel(j)
      if (iprint .ge. 5)  write (io, '(a,1pd18.7)') 'etot', eatom
      do 215 i = 1, 4
         if (iprint .ge. 5) write (io, '(a4,1pd18.7)') iner(i), ener(i)
 215  continue
      return
      end
      double precision function fdmocc (i,j)
c     product of the occupation numbers of the orbitals i and j

      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)

      if (j.eq.i) then
         fdmocc=xnel(i)*(xnel(j)-1)
         a=2* abs(kap(i))
         fdmocc=fdmocc*a/(a-1.0)
      else
         fdmocc=xnel(i)*xnel(j)
      endif
      return
      end
      double precision function fdrirk (i,j,l,m,k)
c                       * calculate radial integrales rk *
c        rk = integral of f(r) * uk(r,s) * g(s)
c uk(r,s) = rinf**k / rsup**(k+1)    rinf=min(r,s)   rsup=max(r,s)
c        if nem=0  f(.)=cg(.,i)*cg(.,j)+cp(.,i)*cp(.,j)
c                  g(.)=cg(.,l)*cg(.,m)+cp(.,l)*cp(.,m)
c        if nem non zero f(.)=cg(.,i)*cp(.,j)
c                        g(.)=cg(.,l)*cp(.,m)
c                  cg (cp) large (small) componenents of the orbitales
c moreover if nem > or =0 the integration is made from 0 to infinity,
c and otherwise from 0 to r.
c        this programm uses yzkrdf and dsordf

      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
c comdir is used just to exchange variables between dsordf,yzkrdf,fdrirk
      dimension hg(251)
      common/inelma/nem
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      save

      fdrirk=0.0d 00
      if (i.le.0.or.j.le.0) go to 201
      call yzkrdf (i,j,k)
      nn= abs(kap(i))+ abs(kap(j))
      nn=max(nn-k,1)
      a=k+1
      do 21 n=1,ndor
 21   hg(n)=0.0d 00
      do 31 n=1,ndor
         if (nn.gt.ndor) go to 31
         hg(nn)=-ag(n)
 31      nn=nn+1
      do 41 n=1,ndor
 41      ag(n)=hg(n)
      ag(1)=ag(1)+ap(1)

 201  if (l.le.0.or.m.le.0) return
      n=-1
      if (nem.ne.0) n=-2
      fdrirk=dsordf(l,m,-1,n,a)
      return
      end
      subroutine inmuat (ihole, xionin, xnval, iholep)
      implicit double precision (a-h,o-z)
      dimension xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
c the meaning of common variables is described below
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
c en one-electron energies
c scc factors for acceleration of convergence
c scw precisions of wave functions
c sce precisions of one-electron energies
c nmax number of tabulation points for orbitals
      common/scrhf1/eps(435),nre(30),ipl
c eps non diagonal lagrange parameters
c nre distingue: - the shell is closed (nre <0)
c                  the shell is open (nre>0)
c                - the orbitals in the integral rk if abs(nre) > or =2
c ipl define the existence of lagrange parameters (ipl>0)
      common/snoyau/dvn(251),anoy(10),nuc
c dvn nuclear potential
c anoy development coefficients at the origin of nuclear potential
c this development is supposed to be written anoy(i)*r**(i-1)
c nuc index of nuclear radius (nuc=1 for point charge)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      data nucm/11/,nesn/50/,ideps/435/

      ndor=10
      testy=1.0d-05
c testy precision for the wave functions
      teste=5.0d-06
c teste precision for the one-electron energies
      rap(1)=100.
      rap(2)=10.
c rap tests of precision for soldir

      call getorb (nz, ihole, xionin, norb, norbsc,
     1             iholep, en, nq, kap, xnel, xnval)
      xk=0
      do 411 i=1,norb
 411  xk=xk+xnel(i)
      if ( abs(nz-xionin-xk) .gt. 0.001) then
         call wlog('check number of electrons in getorb.f')
         stop
      endif
      norbsc=norb
c nz atomic number     noi ionicity (nz-number of electrons)
c norb number of orbitals
c xnel(i) number of electrons on orbital i.
c first norbsc orbitals will be determined selfconsistently,
c the rest of orbitals are orthogonolized if iorth is non null,
c and their energies are those on cards if iene is non null
c or otherwise are the values obtained from solving dirac equation
      nes=nesn
c nes number of attempts in program soldir
      nuc=nucm
c nuc number of points inside nucleus (11 by default)
      do 171 i=1,ideps
 171  eps(i)=0.0d 00

      idim = 251
      if (mod(idim,2) .eq. 0) idim=idim-1

      ipl=0
c if ipl non null, it permits a repartition of tabulation points
c and certain precision tests.
      do 401 i=1,norb
         nre(i)=-1
         llq= abs(kap(i))
         l=llq+llq
         if (kap(i).lt.0) llq=llq-1
         if (llq.lt.0.or.llq.ge.nq(i).or.llq.gt.3) then
            call wlog('kappa out of range, check getorb.f')
            stop
         endif
         nmax(i)=idim
         scc(i)=0.3
         if (xnel(i) .lt. l)  nre(i)=1
         if (xnel(i) .lt. 0.5)  scc(i)=1.0
         do 385 j=1,i-1
            if (kap(j).ne.kap(i)) go to 385
            if (nre(j).gt.0.or.nre(i).gt.0) ipl=ipl+1
 385     continue
 401  continue
 999  return
      end
      subroutine inmuac (ihole, xionin, ikap,xnval)
      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      common/dff/cg(nrptx,30),cp(nrptx,30),bg(10,30),bp(10,30),fl(30),
     1    fix(30), ibgp
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
c the meaning of common variables is described below
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
c en one-electron energies
c scc factors for acceleration of convergence
c scw precisions of wave functions
c sce precisions of one-electron energies
c nmax number of tabulation points for orbitals
      common/scrhf1/eps(435),nre(30),ipl
c eps non diagonal lagrange parameters
c nre distingue: - the shell is closed (nre <0)
c                  the shell is open (nre>0)
c                - the orbitals in the integral rk if abs(nre) > or =2
c ipl define the existence of lagrange parameters (ipl>0)
      common/snoyauc/dvn(nrptx),anoy(10),nuc
c dvn nuclear potential
c anoy development coefficients at the origin of nuclear potential
c this development is supposed to be written anoy(i)*r**(i-1)
c nuc index of nuclear radius (nuc=1 for point charge)
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension xnval(30)
      data nucm/11/

      testy=10.**(-5)
c testy precision for the wave functions

      call getorb (nz, ihole, xionin, norb, norbsc,
     1            iholep, en, nq, kap, xnel, xnval)

      ipl=0
      do 40 i=1,norb
         nre(i)=-1
         llq= abs(kap(i))
         l=llq+llq
c       find last tabulation point
         nmax(i)=0
         do 100  j = idim, 1, -1
            if ( abs(cg(j,i)) .ge. 1.0d-11 .or.
     1           abs(cp(j,i)) .ge. 1.0d-11 )  then
               nmax(i) = j
               goto 16
            endif
  100    continue
   16    continue

         scc(i)=0.3
         if (xnel(i) .lt. l)  nre(i)=1
         if (ikap.eq.kap(i)) ipl=ipl+1
  40  continue
      norbsc=norb
      norb = norb+1
      xnel(norb)=1
      kap(norb)=ikap
      nq(norb) =9
      nmax(norb) = idim
c nz atomic number     noi ionicity (nz-number of electrons)
c norb number of orbitals
c xnel(i) number of electrons on orbital i.
      nuc=nucm
c nuc number of points inside nucleus (11 by default)

      return
      end
      subroutine intdir(gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0)
c            solution of the inhomogenios dirac equation
c gg gp initially exch. terms, at the time of return are wave functions
c ag and ap development coefficients of  gg and gp
c ggmat gpmat  values at the matching point for the inward integration
c en one-electron energy
c fl power of the first development term at the origin
c agi (api) initial values of the first development coefficients
c at the origin of a large (small) component
c ainf initial value for large component at point dr(max0)
c   - at the end of tabulation of gg gp

      implicit double precision (a-h,o-z)
      common/comdir/cl,dz,bid1(522),dv(251),av(10),bid2(522)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      common/subdir/ell,fk,ccl,imm,nd,node,mat
      common/messag/dlabpr,numerr
      character*8 dlabpr
      dimension gg(251),gp(251),ag(10),ap(10),coc(5),cop(5),dg(5),dp(5)
      save
      data cop/2.51d+02,-1.274d+03,2.616d+03,-2.774d+03,1.901d+03/,
     1coc/-1.9d+01,1.06d+02,-2.64d+02,6.46d+02,2.51d+02/,
     2cmixn/4.73d+02/,cmixd/5.02d+02/,hxd/7.2d+02/,npi/5/,icall/0/

c numerical method is a 5-point predictor-corrector method
c predicted value    p(n) = y(n-1) + c * somme de i=1,5 cop(i)*y'(n-i)
c corrected value    c(n) = y(n-1) + c * somme de i=1,4 coc(i)*y'(n-i)
c                                  + coc(5)*p'(n)
c final value        y(n) = cmix*c(n) + (1.-cmix)*p(n)
c                           cmix=cmixn/cmixd

      if (icall.eq.0) then
         icall=1
         c=cmixn/cmixd
         a=1.0d 00-c
         cmc=c*coc(5)
         f=coc(1)
         do 1 j=2,npi
            g=coc(j)
            coc(j)=c*f+a*cop(j)
 1          f=g
         coc(1)=c*cop(1)
      endif
      c=hx/hxd
      ec=en/cl
      ag(1)=agi
      ap(1)=api
      if (imm) 81,15,26
c      search for the second sign change point
 15   mat=npi
      j=1
 16   mat=mat+2
         if (mat.ge.np) then
c   i had trouble with screened k-hole for la, for f-electrons.
c   below i still define matching point if one electron energy not less
c   than -1ev.
            if (ec .gt. -0.0003) then
              mat = np - 12
              go to 25
            endif
            numerr=56011
c          * fail to find matching point
            return
         endif
         f=dv(mat)+ell/(dr(mat)*dr(mat))
         f=(f-ec)*j
         if (f) 25,25,16
 25      j=-j
      if (j.lt.0) go to 16
      if (mat .ge. np-npi) mat=np-12

c     initial values for the outward integration
 26   do 35 j=2,ndor
         k=j-1
         a=fl+fk+k
         b=fl-fk+k
         ep=a*b+av(1)*av(1)
         f=(ec+ccl)*ap(k)+ap(j)
         g=ec*ag(k)+ag(j)
         do 31 i=1,k
            f=f-av(i+1)*ap(j-i)
 31         g=g-av(i+1)*ag(j-i)

         ag(j)=(b*f+av(1)*g)/ep
 35      ap(j)=(av(1)*f-a*g)/ep
      do 41 i=1,npi
         gg(i)=0.0d 00
         gp(i)=0.0d 00
         dg(i)=0.0d 00
         dp(i)=0.0d 00
         do 41 j=1,ndor
            a=fl+j-1
            b=dr(i)**a
            a=a*b*c
            gg(i)=gg(i)+b*ag(j)
            gp(i)=gp(i)+b*ap(j)
            dg(i)=dg(i)+a*ag(j)
 41         dp(i)=dp(i)+a*ap(j)
      i=npi
      k=1
      ggmat=gg(mat)
      gpmat=gp(mat)

c     integration of the inhomogenious system
 51   cmcc=cmc*c

 55   continue
         a=gg(i)+dg(1)*cop(1)
         b=gp(i)+dp(1)*cop(1)
         i=i+k
         ep=gp(i)
         eg=gg(i)
         gg(i)=a-dg(1)*coc(1)
         gp(i)=b-dp(1)*coc(1)
         do 61 j=2,npi
            a=a+dg(j)*cop(j)
            b=b+dp(j)*cop(j)
            gg(i)=gg(i)+dg(j)*coc(j)
            gp(i)=gp(i)+dp(j)*coc(j)
            dg(j-1)=dg(j)
 61         dp(j-1)=dp(j)
         f=(ec-dv(i))*dr(i)
         g=f+ccl*dr(i)
         gg(i)=gg(i)+cmcc*(g*b-fk*a+ep)
         gp(i)=gp(i)+cmcc*(fk*b-f*a-eg)
         dg(npi)=c*(g*gp(i)-fk*gg(i)+ep)
         dp(npi)=c*(fk*gp(i)-f*gg(i)-eg)
      if (i.ne.mat) go to 55

      if (k.lt.0) go to 999
      a=ggmat
      ggmat=gg(mat)
      gg(mat)=a
      a=gpmat
      gpmat=gp(mat)
      gp(mat)=a
      if (imm.ne.0) go to 81

c     initial values for inward integration
      a=test1* abs(ggmat)
      if (ainf.gt.a) ainf=a
      max0=np+2
 73   a=7.0d+02/cl
 75   max0=max0-2
         if ((max0+1).le.(mat+npi)) then
            numerr=138021
c          *the last tabulation point is too close to the matching point
            return
         endif
      if (((dv(max0)-ec)*dr(max0)*dr(max0)).gt.a) go to 75

 81   c=-c
      a=- sqrt(-ec*(ccl+ec))
      if ((a*dr(max0)).lt.-1.7d+02) go to 73
      b=a/(ccl+ec)
      f=ainf/ exp(a*dr(max0))
      if (f.eq.0.0d 00) f=1.0d 00
      do 91 i=1,npi
         j=max0+1-i
         gg(j)=f* exp(a*dr(j))
         gp(j)=b*gg(j)
         dg(i)=a*dr(j)*gg(j)*c
 91      dp(i)=b*dg(i)
      i=max0-npi+1
      k=-1
      go to 51

 999  return
      end
      subroutine lagdat (ia,iex)
c        * non diagonal lagrange parameteres *
c lagrange parameters involving orbital ia if ia is positive
c all lagrange parameters are calculated if ia is negative or zero
c contribution of the exchange terms is omitted if iex=0
c        this program uses akeato(bkeato) fdrirk multrk

      implicit double precision (a-h,o-z)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      dimension ni(2),nj(2)

      i1= max(ia,1)
      idep=1
      if (ia.gt.0) go to 15
 11   idep=i1+1
 15   ni(1)=i1
      nj(2)=i1
      ji1=2* abs(kap(i1))-1
      do 201 i2=idep,norbsc
         if (i2.eq.i1.or.kap(i2).ne.kap(i1)) go to 201
         if (nre(i1).lt.0.and.nre(i2).lt.0) go to 201
c the following line was included to handle the case of 1 electron in
c 2 s-shells.
c Probably need to use schmidt orthogonalization in this case
         if (xnel(i1).eq.xnel(i2)) go to 201
         ni(2)=i2
         nj(1)=i2
         d=0.0d 00
         do 101 l=1,norbsc
            k=0
            jjl=2* abs(kap(l))-1
            kma= min(ji1,jjl)
 41         a=akeato(l,i1,k)/xnel(i1)
            b=a-akeato(l,i2,k)/xnel(i2)
            c=b
            if (a.ne.0.0d 00) c=c/a
            if ( abs(c).lt.1.0d-07) go to 51
            d=d+b*fdrirk(l,l,i1,i2,k)
 51         k=k+2
            if (k.le.kma) go to 41
            if (iex.eq.0) go to 101
            kma=(ji1+jjl)/2
            k= abs(jjl-kma)
            if ((kap(i1)*kap(l)).lt.0) k=k+1
 61         a=bkeato(l,i2,k)/xnel(i2)
            b=a-bkeato(l,i1,k)/xnel(i1)
            c=b
            if (a.ne.0.0d 00) c=c/a
            if ( abs(c).lt.1.0d-07) go to 71
            d=d+b*fdrirk(i1,l,i2,l,k)
 71         k=k+2
            if (k.le.kma) go to 61
 101     continue
         i= min(i1,i2)
         j= max(i1,i2)
         eps(i+((j-1)*(j-2))/2)=d/(xnel(i2)-xnel(i1))
 201  continue
      if (ia.gt.0) go to 999
      i1=i1+1
      if (i1.lt.norbsc) go to 11
 999  return
      end
      subroutine messer
c  prints error message on the output device
      implicit double precision (a-h,o-z)
      common/messag/dlabpr,numerr
      character*8 dlabpr
      character*512 slog

      ilig=numerr/1000
      ier=numerr-1000*ilig
      write(slog,'(a,i6,a,i6,a,a8)')  'error number ',ier,
     1 ' detected on a line ',ilig,'in the program',dlabpr
      call wlog(slog)
      return
      end
      subroutine muatco(xnval)
c               * angular coefficients *
c        sous programmes utilises  cwig3j
c
      implicit double precision (a-h,o-z)
      dimension xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/mulabk/afgk
      dimension afgk(30,30,0:3)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)

      do 511 i=1,30
      do 511 j=1,30
      do 511 k=0,3
 511  afgk(i,j,k)=0.0d 00
 601  do 701 i=1,norb
         li= abs(kap(i))*2-1
         do 701 j=1,i
            lj= abs(kap(j))*2-1
            kmax=(li+lj)/2
            kmin= abs(li-lj)/2
            if ((kap(i)*kap(j)).lt.0) kmin=kmin+1
c calculate a_k(i,j)
            m=0
            if (j.eq.i .and. xnval(i).le.0.0d0) m=1
c           use to test SIC
c           if (j.eq.i) m=1

            afgk(j,i,0)=afgk(j,i,0)+xnel(i)*(xnel(j)-m)
            if (xnval(i).gt.0.0d0 .and. xnval(j).gt.0.0d0) goto 700
c calculate b_k(i,j)
            b=afgk(j,i,0)
            if (j.eq.i .and. xnval(i).le.0.0d0) then
               a=li
               b=-b*(a+1.0d 00)/a
               kmin = kmin+2
            endif
            do 675 k = kmin, kmax,2
               afgk(i,j,k/2)=b*(cwig3j(li,k*2,lj,1,0,2)**2)
 675        continue

 700        continue
 701  continue
      return
      end
      subroutine nucdev (av,dr,dv,dz,hx,nuc,np,ndor,dr1)
c        * construction of nuclear potential *
c av coefficients of the development at the origin of nuclear potential
c dr  tabulation points
c dv  nuclear potential
c dz  nuclear charge
c hx  exponential step
c nuc index of the nuclear radius
c np  number of tabulation points
c ndor number of the coefficients for development at the origin
c the declared below arguments are saved, dr1 is the first

      implicit double precision (a-h,o-z)
      dimension av(10),dr(251),dv(251),at(251)

c    specify atomic mass and thickness of nuclear shell
c a atomic mass (negative or null for the point charge)
c epai parameter of the fermi density distribution
c (negative or null for uniform distribution), which is
c       cte / (1. + exp((r-rn)/epai) )
c with nuclear radius rn= 2.2677e-05 * (a**(1/3))

c calculate radial mesh
      a = 0.0
      epai = 0.0

      if (a.le.1.0d-01) then
         nuc=1
      else
         a=dz*(a**(1./3.))*2.2677d-05
         b=a/ exp(hx*(nuc-1))
         if (b.le.dr1) then
            dr1=b
         else
            b=log(a/dr1)/hx
            nuc=3+2*int(b/2.0)
            if (nuc.ge.np) stop 'dr1 too small'
c           index of atomic radius larger than dimension of dr
            dr1=a*exp(-(nuc-1)*hx)
         endif
      endif

      dr(1)=dr1/dz
      do 181 l=2,np
 181  dr(l)=dr(1)* exp(hx*(l-1))

      if (ndor.lt.5) then
c       * it should be at least 5 development coefficients
         call wlog('stopped in programm nucdev, ndor should be > 4.')
         stop
      endif
c  calculate nuclear potential on calculated radial mesh
      do 11 i=1,ndor
 11      av(i)=0.0d 00
      if (epai.le.0.0) then
         do 15 i=1,np
 15         dv(i)=-dz/dr(i)
         if (nuc.le.1) then
            av(1)=-dz
         else
            av(2)=-3.0d 00*dz/(dr(nuc)+dr(nuc))
            av(4)=-av(2)/(3.0d 00*dr(nuc)*dr(nuc))
            l=nuc-1
            do 25 i=1,l
 25            dv(i)=av(2)+av(4)*dr(i)*dr(i)
         endif
      else
         b= exp(-dr(nuc)/epai)
         b=1.0d 00/(1.0d 00+b)
         av(4)=b
         av(5)=epai*b*(b-1.0d 00)
         if (ndor.le.5) go to 45
         at(1)=1.0d 00
         at(2)=1.0d 00
         nf=1
         do 41 i=6,ndor
            n=i-4
            nf=n*nf
            dv(1)=n*at(1)
            n1=n+1
            dv(n1)=1.0d 00
            do 35 j=2,n
 35         dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j)
            do 37 j=1,n1
               m=n+1-j
               l=1
               if (mod(j,2).eq.0) l=-l
               av(i)=av(i)+l*dv(j)*(b**m)
 37            at(j)=dv(j)
 41         av(i)=b*av(i)*(epai**n)/nf
 45      do 47 i=1,np
            b=1.0d 00+ exp((dr(i)-dr(nuc))/epai)
            if ((b*av(4)).gt.1.0d+15) go to 51
            dv(i)=dr(i)*dr(i)*dr(i)/b
 47         l=i
 51      if (l.ge.(np-1)) l=np-2
         k=l+1
         do 55 i=k,np
 55         dv(i)=0.0d 00
         at(1)=0.0d 00
         at(2)=0.0d 00
         k=2
         do 61 i=4,ndor
            k=k+1
            do 58 j=1,2
 58         at(j)=at(j)+av(i)*(dr(j)**k)/k
            av(i)=av(i)/(k*(k-1))
 61         av(2)=av(2)+av(i)*(dr(1)**k)
         a=hx/2.4d+01
         b=a*1.3d+01
         k=l+1
         do 71 i=3,k
 71      at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1))
         dv(l)=at(l)
         do 75 i=k,np
 75      dv(i)=dv(l)
         e= exp(hx)
         c=1.0d 00/(e*e)
         i=l-1
 83      dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e)
         i=i-1
         if (i-1) 85,85,83
 85      dv(1)=dv(3)*c+hx*(at(1)+4.0d 00*at(2)/e+at(3)*c)/3.0d 00
         av(2)=(av(2)+dv(1))/dr(1)
         a=-dz/dv(l)
         do 95 i=4,ndor
 95      av(i)=-a*av(i)
         av(2)=a*av(2)
         do 97 i=1,np
 97      dv(i)=a*dv(i)/dr(i)
      endif

      return
      end
      subroutine muatcc(xnval)
c               * angular coefficients *
c        sous programmes utilises  cwig3j
c
      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/mulabkc/afgkc
      dimension afgkc(-ltot-1:ltot,30,0:3)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)

      do 511 i=-ltot-1,ltot
      do 511 j=1,30
      do 511 k=0,3
 511  afgkc(i,j,k)=0.0d 00
 601  do 701 ikap=-ltot-1,ltot
         if (ikap .eq. 0) go to 701
         li= abs(ikap)*2-1
         do 700 j=1,norb-1
            lj= abs(kap(j))*2-1
            kmax=(li+lj)/2
            kmin= abs(li-lj)/2
            if ((ikap*kap(j)).lt.0) kmin=kmin+1
            if (xnval(j) .gt. 0.0d0) goto 700
c calculate b_k(i,j)
            do 675 k = kmin, kmax,2
               index=(k-kmin)/2
               afgkc(ikap,j,index)=xnel(j)*(cwig3j(li,k*2,lj,1,0,2)**2)
 675        continue
 700     continue
 701  continue
      return
      end
      subroutine nucdec (av,dr,dv,dz,hx,nuc,np,ndor,dr1)
c        * construction of nuclear potential *
c av coefficients of the development at the origin of nuclear potential
c dr  tabulation points
c dv  nuclear potential
c dz  nuclear charge
c hx  exponential step
c nuc index of the nuclear radius
c np  number of tabulation points
c ndor number of the coefficients for development at the origin
c the declared below arguments are saved, dr1 is the first

      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      dimension av(10),dr(nrptx),dv(nrptx),at(nrptx)

c    specify atomic mass and thickness of nuclear shell
c a atomic mass (negative or null for the point charge)
c epai parameter of the fermi density distribution
c (negative or null for uniform distribution), which is
c       cte / (1. + exp((r-rn)/epai) )
c with nuclear radius rn= 2.2677e-05 * (a**(1/3))

c calculate radial mesh
      a = 0.0
      epai = 0.0

      if (a.le.1.0d-01) then
         nuc=1
      else
         a=dz*(a**(1./3.))*2.2677d-05
         b=a/ exp(hx*(nuc-1))
         if (b.le.dr1) then
            dr1=b
         else
            b=log(a/dr1)/hx
            nuc=3+2*int(b/2.0)
            if (nuc.ge.np) stop 'dr1 too small'
c           index of atomic radius larger than dimension of dr
            dr1=a*exp(-(nuc-1)*hx)
         endif
      endif

      dr(1)=dr1/dz
      do 181 l=2,np
 181  dr(l)=dr(1)* exp(hx*(l-1))

      if (ndor.lt.5) then
c       * it should be at least 5 development coefficients
         call wlog('stopped in programm nucdec, ndor should be > 4.')
         stop
      endif
c  calculate nuclear potential on calculated radial mesh
      do 11 i=1,ndor
 11      av(i)=0.0d 00
      if (epai.le.0.0) then
         do 15 i=1,np
 15         dv(i)=-dz/dr(i)
         if (nuc.le.1) then
            av(1)=-dz
         else
            av(2)=-3.0d 00*dz/(dr(nuc)+dr(nuc))
            av(4)=-av(2)/(3.0d 00*dr(nuc)*dr(nuc))
            l=nuc-1
            do 25 i=1,l
 25            dv(i)=av(2)+av(4)*dr(i)*dr(i)
         endif
      else
         b= exp(-dr(nuc)/epai)
         b=1.0d 00/(1.0d 00+b)
         av(4)=b
         av(5)=epai*b*(b-1.0d 00)
         if (ndor.le.5) go to 45
         at(1)=1.0d 00
         at(2)=1.0d 00
         nf=1
         do 41 i=6,ndor
            n=i-4
            nf=n*nf
            dv(1)=n*at(1)
            n1=n+1
            dv(n1)=1.0d 00
            do 35 j=2,n
 35         dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j)
            do 37 j=1,n1
               m=n+1-j
               l=1
               if (mod(j,2).eq.0) l=-l
               av(i)=av(i)+l*dv(j)*(b**m)
 37            at(j)=dv(j)
 41         av(i)=b*av(i)*(epai**n)/nf
 45      do 47 i=1,np
            b=1.0d 00+ exp((dr(i)-dr(nuc))/epai)
            if ((b*av(4)).gt.1.0d+15) go to 51
            dv(i)=dr(i)*dr(i)*dr(i)/b
 47         l=i
 51      if (l.ge.(np-1)) l=np-2
         k=l+1
         do 55 i=k,np
 55         dv(i)=0.0d 00
         at(1)=0.0d 00
         at(2)=0.0d 00
         k=2
         do 61 i=4,ndor
            k=k+1
            do 58 j=1,2
 58         at(j)=at(j)+av(i)*(dr(j)**k)/k
            av(i)=av(i)/(k*(k-1))
 61         av(2)=av(2)+av(i)*(dr(1)**k)
         a=hx/2.4d+01
         b=a*1.3d+01
         k=l+1
         do 71 i=3,k
 71      at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1))
         dv(l)=at(l)
         do 75 i=k,np
 75      dv(i)=dv(l)
         e= exp(hx)
         c=1.0d 00/(e*e)
         i=l-1
 83      dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e)
         i=i-1
         if (i-1) 85,85,83
 85      dv(1)=dv(3)*c+hx*(at(1)+4.0d 00*at(2)/e+at(3)*c)/3.0d 00
         av(2)=(av(2)+dv(1))/dr(1)
         a=-dz/dv(l)
         do 95 i=4,ndor
 95      av(i)=-a*av(i)
         av(2)=a*av(2)
         do 97 i=1,np
 97      dv(i)=a*dv(i)/dr(i)
      endif

      return
      end
      subroutine ortdat (ia)
c        * orthogonalization by the schmidt procedure*
c the ia orbital is orthogonalized toa all orbitals of the same
c symmetry if ia is positive, otherwise all orbitals of the same
c symmetry are orthogonalized
c        this program uses dsordf

      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1         fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
c  dg,ag,dp,ap are used to exchange data only with dsordf
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim

      m=norb
      l= max(ia,1)
      if (ia.gt.0) go to 11
 5    m=l
      l=l+1
      if (l.gt.norb) go to 999
 11   do 15 i=1,idim
         dg(i)=0.0d 00
 15      dp(i)=0.0d 00
      maxl=nmax(l)
      do 21 i=1,maxl
         dg(i)=cg(i,l)
 21      dp(i)=cp(i,l)
      do 25 i=1,ndor
         ag(i)=bg(i,l)
 25      ap(i)=bp(i,l)
      do 51 j=1,m
         if (j.eq.l.or.kap(j).ne.kap(l)) go to 51
         max0=nmax(j)
         a=dsordf (j,j,0,3,fl(l))
         do 41 i=1,max0
            dg(i)=dg(i)-a*cg(i,j)
 41         dp(i)=dp(i)-a*cp(i,j)
         do 45 i=1,ndor
            ag(i)=ag(i)-a*bg(i,j)
 45         ap(i)=ap(i)-a*bp(i,j)
         maxl= max(maxl,max0)
 51   continue
      max0= maxl
      nmax(l)=max0
      a=dsordf (l,max0,0,4,fl(l))
      a= sqrt(a)
      do 71 i=1,max0
         cg(i,l)=dg(i)/a
 71      cp(i,l)=dp(i)/a
      do 75 i=1,ndor
         bg(i,l)=ag(i)/a
 75      bp(i,l)=ap(i)/a
      if (ia.le.0) go to 5
 999  return
      end
      subroutine ortdac(ikap,ps,qs,aps,aqs)
c        * orthogonalization by the schmidt procedure*
c the ia orbital is orthogonalized toa all orbitals of the same
c symmetry if ia is positive, otherwise all orbitals of the same
c symmetry are orthogonalized
c        this program uses dsordc

      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      complex*16 dsordc
      complex*16 ps(nrptx), qs(nrptx), aps(10),aqs(10)
      common/dff/ cg(nrptx,30), cp(nrptx,30), bg(10,30), bp(10,30),
     1             fl(30), fix(30), ibgp
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1   nq(30),kap(30),nmax(30)
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      complex*16 a

      do 51 j=1,norb-1
         if (kap(j).ne.ikap .or. xnel(j).le.0) go to 51
         a = dsordc(j,fl(norb),ps,qs,aps,aqs)
         do 41 i=1,idim
            ps(i)=ps(i)-a*cg(i,j)
 41         qs(i)=qs(i)-a*cp(i,j)
         do 42 i=1,ndor
            aps(i)=aps(i)-a*bg(i,j)
 42         aqs(i)=aqs(i)-a*bp(i,j)
 51   continue
      return
      end
      subroutine potrdf (ia)
c        this programm uses akeato(bkeato),aprdev,multrk,yzkrdf
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1        fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10),
     2              eg(251),ceg(10),ep(251),cep(10)
c     dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir
      dimension at(251),bt(251)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      common/snoyau/dvn(251),anoy(10),nuc
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)

      do 9 i=1,ndor
         cep(i)=0.0d 00
         ceg(i)=0.0d 00
 9       av(i)=anoy(i)
      do 11 i=1,idim
         at(i)=0.0d 00
         bt(i)=0.0d 00
         ep(i)=0.0d 00
         eg(i)=0.0d 00
 11      dv(i)=0.0d 00

c     coulomb terms
      jia=2* abs(kap(ia))-1
      k=0
 21   do 25 i=1,idim
 25   dg(i)=0.0d 00
      do 31 i=1,ndor
 31   ag(i)=0.0d 00
      max0=0
      do 51 j=1,norb
         do 33 i = 1,10
            bgj(i) = bg(i,j)
 33         bpj(i) = bp(i,j)
         m=2* abs(kap(j))-1
         if (k.gt.m) go to 51
         a=akeato(ia,j,k)/xnel(ia)
         if (a.eq.0.0d 00) go to 51
         m=nmax(j)
         do 35 i=1,m
 35         dg(i)=dg(i)+a*(cg(i,j)*cg(i,j)+cp(i,j)*cp(i,j))
         n=2* abs(kap(j))-k
         l=ndor+2-n
         if (l.le.0) go to 51
c        quick fix of development coefficients
         a = a * fix(j)**2
         do 41 i=1,l
            m=n-2+i
 41         ag(m)=ag(m)+a*(aprdev(bgj,bgj,i)+
     1            aprdev(bpj,bpj,i))
 51      max0= max(max0,nmax(j))
      call yzkrdf (0,max0,k)
      do 61 i=1,ndor
         l=k+i+3
         if (l.gt.ndor) go to 61
         av(l)=av(l)-ag(i)
 61   continue
      do 81 i=1,idim
 81   dv(i)=dv(i)+dg(i)
      k=k+2
      if (k.le.ndor) av(k)=av(k)+ap(1)
      if (k.lt.jia) go to 21

c     exchange terms
      if (method.eq.0) go to 411
      do 201 j=1,norb
         if (j-ia) 105,201,105
 105     max0=nmax(j)
         jj=2* abs(kap(j))-1
         kma=(jj+jia)/2
         k= abs(jj-kma)
         if ((kap(j)*kap(ia)).lt.0) k=k+1

 111     a=bkeato(j,ia,k)/xnel(ia)
         if (a.eq.0.0d 00) go to 151
         call yzkrdf (j,ia,k)
         do 121 i=1,max0
            eg(i)=eg(i)+a*dg(i)*cg(i,j)
 121        ep(i)=ep(i)+a*dg(i)*cp(i,j)
         n=k+1+ abs(kap(j))- abs(kap(ia))
         if (n.gt.ndor) go to 141
         do 135 i=n,ndor
            ceg(i)=ceg(i)+bg(i+1-n,j)*a*ap(1) *fix(j)/fix(ia)
 135        cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1) *fix(j)/fix(ia)
 141     i=2* abs(kap(j))+1
         if (i.gt.ndor) go to 151
         do 143 ix = 1,10
            bgj(ix) = bg(ix,j)
 143        bpj(ix) = bp(ix,j)
         do 145 n=i,ndor
            ceg(n)=ceg(n)-a*aprdev(ag,bgj,n+1-i) *fix(j)**2
 145        cep(n)=cep(n)-a*aprdev(ag,bpj,n+1-i) *fix(j)**2
 151     k=k+2
         if (k.le.kma) go to 111
 201  continue
 411  if (ipl.eq.0) go to 511
      do 481 j=1,norbsc
         if (kap(j).ne.kap(ia).or.j.eq.ia) go to 481
         if (nre(j).lt.0.and.nre(ia).lt.0) go to 481
         m= max(j,ia)
         i= min(j,ia)+((m-1)*(m-2))/2
         a=eps(i)*xnel(j)
         max0=nmax(j)
         do 461 i=1,max0
            at(i)=at(i)+a*cg(i,j)
 461        bt(i)=bt(i)+a*cp(i,j)
         do 471 i=1,ndor
            ceg(i)=ceg(i)+bg(i,j)*a
 471        cep(i)=cep(i)+bp(i,j)*a
 481  continue

c addition of nuclear potential and division of potentials and
c       their development limits by speed of light
 511  do 527 i=1,ndor
         av(i)=av(i)/cl
         cep(i)=cep(i)/cl
 527     ceg(i)=ceg(i)/cl
      do 531 i=1,idim
         dv(i)=(dv(i)/dr(i)+dvn(i))/cl
         ep(i)=(ep(i)+bt(i)*dr(i))/cl
 531     eg(i)=(eg(i)+at(i)*dr(i))/cl
      return
      end
      subroutine potdvp
c     this programm uses aprdev,multrk,yzkrdf
c     to calculate potential development coefficients
      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      common/dff/ cg(nrptx,30), cp(nrptx,30), bg(10,30), bp(10,30),
     1              fl(30), fix(30), ibgp
      complex*16 dg,ag,dp,ap,dv,av,eg,ceg,ep,cep
      common/comdirc/cl,dz,dg(nrptx),ag(10),dp(nrptx),ap(10),dv(nrptx),
     2         av(10),eg(nrptx),ceg(10),ep(nrptx),cep(10)
c     dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/snoyauc/dvn(nrptx),anoy(10),nuc
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)

      do 9 i=1,10
 9       av(i)=anoy(i)

c     calculate density development coefficients
      do 31 i=1,ndor
 31   ag(i)=0.0d 00
      do 51 j=1,norb-1
         do 33 i = 1,10
            bgj(i) = bg(i,j)
 33         bpj(i) = bp(i,j)
         n=2* abs(kap(j))
         l=ndor+2-n
         if (l.le.0) go to 51
         do 41 i=1,l
            m=n-2+i
 41         ag(m)=ag(m)+xnel(j)*(aprdev(bgj,bgj,i)+
     1            aprdev(bpj,bpj,i))*fix(j)**2
 51   continue

c     transform density coefficients into ones for potential
      ap(1)=0.0d 00
      do 15 i=1,ndor
         ag(i)=ag(i)/(i+2)/(i+1)
         ap(1)=ap(1)+ag(i)*dr(1)**(i+1)
 15   continue

      do 61 i=1,ndor
         l=i+3
         if (l.gt.ndor) go to 61
         av(l)=av(l)-ag(i)
 61   continue
c     av(2)=avoy(2) + ap(1)+(vxcvzl(1)-dvn(1)) in order
c     to have sum av(i)*dr(1)**(i-2)=vxcval(1)
      av(2)=av(2)+ap(1)

c addition of nuclear potential and division of potentials and
c       their development limits by speed of light
      do 527 i=1,10
 527     av(i)=av(i)/cl
      return
      end
      subroutine potex(ps,qs,aps,aqs,jri)
c        this programm uses bkeato,aprdec,multrk,yzkrdc
      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      complex*16 aprdec
      complex*16 ps(nrptx),qs(nrptx),aps(10),aqs(10)
      common/dff/cg(nrptx,30),cp(nrptx,30),bg(10,30),bp(10,30),
     1             fl(30), fix(30), ibgp
      complex*16 dg,ag,dp,ap,dv,av,eg,ceg,ep,cep
      common/comdirc/cl,dz,dg(nrptx),ag(10),dp(nrptx),ap(10),dv(nrptx),
     2          av(10),eg(nrptx),ceg(10),ep(nrptx),cep(10)
c     dg,dp to get data from yzkrdc, dv,eg,ep -output for soldir
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      common/mulabkc/afgkc
      dimension afgkc(-ltot-1:ltot,30,0:3)
      dimension bgj(10),bpj(10)

c     ia=norb
      jia=2* abs(kap(norb))-1
      do 9 i=1,10
         cep(i)=0.0d 00
 9       ceg(i)=0.0d 00
      do 11 i=1,idim
         ep(i)=0.0d 00
 11      eg(i)=0.0d 00

c     exchange terms
      do 201 j=1,norb-1
 105     jj=2* abs(kap(j))-1
         kma=(jj+jia)/2
         k= abs(jj-kma)
         if ((kap(j)*kap(norb)).lt.0) k=k+1
         kmin = k
c        kma=min(kma,15)
c        if (k.lt.kma) goto 201

c111     a=bkeato(j,ia,k)/xnel(ia)
 111     a=afgkc(kap(norb),j,(k-kmin)/2)
         if (a.eq.0.0d 00) go to 151
         call yzkrdc (j,k,fl(norb),ps,qs,aps,aqs)
         do 121 i=1,idim
            eg(i)=eg(i)+a*dg(i)*cg(i,j)
 121        ep(i)=ep(i)+a*dg(i)*cp(i,j)
         n=k+1+ abs(kap(j))- abs(kap(norb))
c         differrent for irregular solution
         if (fl(norb) .lt.0.0) n=k+1+ abs(kap(j)) + abs(kap(norb))
         if (n.gt.ndor) go to 141
         do 135 i=n,ndor
            ceg(i)=ceg(i)+bg(i+1-n,j)*a*ap(1)*fix(j)/fix(norb)
 135        cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1)*fix(j)/fix(norb)
 141     i=2* abs(kap(j))+1
         if (i.gt.ndor) go to 151
         do 143 ix = 1,10
            bgj(ix) = bg(ix,j)
 143        bpj(ix) = bp(ix,j)
         do 145 n=i,ndor
            nx = n + 1 - i
            ceg(n) = ceg(n) - a * aprdec(ag,bgj,nx)*fix(j)**2
 145        cep(n) = cep(n) - a * aprdec(ag,bpj,nx)*fix(j)**2
 151     k=k+2
         if (k.le.kma) go to 111
 201  continue

c    division of potentials and
c    their development limits by speed of light
      do 527 i=1,ndor
         cep(i)=cep(i)/cl
 527     ceg(i)=ceg(i)/cl
      do 531 i=1,jri
         ep(i)=ep(i)/cl
 531     eg(i)=eg(i)/cl
      do 532 i=jri+1,nrptx
         ep(i)=0.0d0
 532     eg(i)=0.0d0

      return
      end
      subroutine potslw (dv,d,dr,dpas,np)
c
c coulomb potential uses a 4-point integration method
c dv=potential;  d=density;  dp=bloc de travail; dr=radial mesh
c dpas=exponential step;
c np=number of points
c **********************************************************************

      implicit double precision (a-h,o-z)
      dimension dv(251), d(251), dp(251), dr(251)

      das=dpas/24.0
      do 10 i=1,np
   10 dv(i)=d(i)*dr(i)
      dlo=exp(dpas)
      dlo2=dlo*dlo
      dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0*(dlo-1.0))
      dp(1)=dv(1)/3.0-dp(2)/dlo2
      dp(2)=dv(2)/3.0-dp(2)*dlo2
      j=np-1
      do 20 i=3,j
   20 dp(i)=dp(i-1)+das*(13.0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1)))
      dp(np)=dp(j)
      dv(j)=dp(j)
      dv(np)=dp(j)
      do 30 i=3,j
      k=np+1-i
   30 dv(k)=dv(k+1)/dlo+das*(13.0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp
     1 (k-1)*dlo))
      dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0*dp(2)/dlo+dp(3)/dlo2)/3.0
      do 40 i=1,np
   40 dv(i)=dv(i)/dr(i)
      return
      end
      subroutine scfdat (title, ifr, iz, ihole, xion, vcoul, srho, dmag,
     1     srhovl, rcore, ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,
     2     s02, efrozn, eatom)

      implicit double precision (a-h,o-z)

c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     save central atom dirac components, see comments below.
      dimension dgc0(251), dpc0(251)
      dimension dgc(251, 30, 0:nfrx), dpc(251, 30, 0:nfrx)
      dimension adgc(10, 30, 0:nfrx), adpc(10, 30, 0:nfrx)

      character*(*)  title
      dimension vcoul(251)
      dimension srho(251), dmag(251), srhovl(251), xnval(30)
c     temporary do not use core-valence separation
      dimension xnvalp(30)

      dimension ovpint(30, 30)
      common /print/ iprint

      character*40 ttl
c     character*512 slog
      common /char/ ttl
      character*30 fname

c muatco programm to calculate angular coefficients
c        this programm uses cofcon cofdat dsordf ictime iowrdf
c        lagdat messer nucdev ortdat potrdf soldir
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1         fl(30), fix(30), ibgp
c cg (cp) large (small) components
c bg (bp) development coefficients at the origin of large
c    (small) component
c fl power of the first term of development limits.
c ibgp first dimension of the arrays bg and bp

      common/comdir/ cl, dz, gg(251), ag(10), gp(251), ap(10), bid(783)
c  gg,gp are the output from soldir
      common/itescf/ testy, rap(2), teste, nz, norb, norbsc
      common/mulabk/ afgk
      common/inelma/ nem
      dimension afgk(30, 30, 0:3)
      common/messag/ dlabpr, numerr
      character*8 dprlab, dlabpr
      common/ratom1/ xnel(30), en(30), scc(30), scw(30), sce(30),
     1nq(30), kap(30), nmax(30)
      common/scrhf1/ eps(435), nre(30), ipl
      common/snoyau/ dvn(251), anoy(10), nuc
      common/tabtes/ hx, dr(251), test1, test2, ndor, np, nes, method,
     1 idim
      data dprlab /'  scfdat'/
      data harryd /2./

      if (iprint .ge. 3)  then
c        prepare file for atom output
         write(fname,14)  ifr
   14    format('atom', i2.2, '.dat')
         open (unit=16, file=fname, status='unknown', iostat=ios)
c        call chopen (ios, fname, 'atom')
c        call head (16)
         write (16,*)  ' free atom ', ifr
         lttl = istrln(ttl)
         if (iprint .ge. 3)  write(16,40) ttl(1:lttl)
 40      format (1h1,40x,a)
      endif

c  initialize the data and test parameters
      jfail = 0
      ibgp = 10
      numerr = 0
      nz = iz
 11   call inmuat (ihole, xion, xnval, iholep)

      idfock = 1
c     idfock=1  --  pure Dirac-Fock.
c     idfock=5  --  exchange 5 model.
c     idfock=6  --  exchange 6 model.
      if (idfock.eq.1) then
         do 42 i=1,30
  42     xnvalp(i) = 0.0d0
      else
c        use core-valence separation. also change vlda.f
         do 43 i=1,30
  43     xnvalp(i) = xnval(i)
      endif

c     iholep is the index for core hole orbital in all arrays
c     ihole is just a code number for given core hole
c     for 90% of atoms iholep=ihole
      ttl = title
      ilast = 0

c   calculate initial orbitals using thomas-fermi model ido=1
c   option to read from cards(ido=2) destroyed
      ido = 1
      if (numerr .eq. 0) then
         a = -xion - 1
         call wfirdf (en, a, nq, kap, nmax, ido)
      endif

      niter = 30
c if niter is negative then schmidt orthogonalization procedure is used
c           niter =1000*n1+100*n2+n3
c n3 is the number of iterations per orbital
      j = 1
      ind = 1
      nter = 0
      do 41 i = 1, norb
 41   scw(i) = 0.
      test1 = testy / rap(1)
      test2 = testy / rap(2)
      netir = abs(niter) * norb
      if (iprint .ge. 5)  then
         write(16,210) niter, teste, testy
  210    format (5x,'number of iterations',i4,//,
     1        5x,'precision of the energies',1pe9.2,//,
     2        23x,'wave functions  ',1pe9.2,/)
         write(16,220) idim, dr(1), hx
  220    format (' the integration is made on ', i3,
     1        ' points-the first is equal to ' ,f7.4,/,
     2        ' and the step-size pas = ',f7.4,/)
         write(16,230) test1, nes
  230    format ('matching of w.f. with precision', 1pe9.2,
     2        ' in ',i3,' attempts ',/)
         if (nuc .gt. 1)  write(16,250)
  250    format (1h0, 30x,'finite nucleus case used'/)
      endif

c     angular coefficients
c     corrected for valence model. ala
      call muatco(xnvalp)
      if (numerr .ne. 0) go to 711

c     iteration over the number of cycles
 101  iort = 0
         nter = nter + 1
         if (niter .ge. 0) go to 105
c        orthogonalization by schmidt procedure
 104     call ortdat (j)
 105     method = 1
c        calculate lagrange parameters
         if (nre(j).gt.0 .and. ipl.ne.0) call lagdat (j,1)
c        calculate electron potential
         call potrdf (j)
c        add potential due to xc with valence electrons
         call vlda (j, xnval, srho, srhovl, dmag, ilast, idfock)
         e = en(j)
         np = idim
c        resolution of the dirac equation
         ifail = 0
         ainf = cg(nmax(j),j)
         call soldir (en(j), fl(j), bg(1,j), bp(1,j), ainf,
     1                nq(j), kap(j), nmax(j), ifail)
         if (ifail.ne.0 .and. jfail.eq.0) jfail = j
         if (jfail.eq.j .and. ifail.eq.0) jfail = 0
         if (numerr. eq. 0) go to 111
         if (iort.ne.0 .or. niter.lt.0) go to 711
         iort = 1
         go to 104

 111     sce(j) = abs ((e - en(j)) / en(j))
c        variation of the wave function using two iterations
         k = nmax(j)
         pr = 0.
         do 121 i = 1, k
            w = cg(i,j) - gg(i)
            if (abs(w) .le. abs(pr)) go to 115
            pr = w
            a = cg(i,j)
            b = gg(i)
 115        w = cp(i,j) - gp(i)
            if (abs(w) .le. abs(pr)) go to 121
            pr = w
            a = cp(i,j)
            b = gp(i)
 121     continue
c        write original Desclaux output on screen and into the logfile
c        write (slog,'(i4, i3, 2(1pe11.2), 2(1pd16.6), 4x, a, i2)')
c    1   nter, j, sce(j), pr, a, b, 'method', method
c        call wlog(slog)

c        acceleration of the convergence
         b = scc(j)
         call cofcon (a, b, pr, scw(j))
         scc(j) = b
         do 151 i = 1, k
            gg(i) = b * gg(i) + a * cg(i,j)
 151        gp(i) = b * gp(i) + a * cp(i,j)
         do 155 i = 1, ndor
            ag(i) = b * ag(i) + a * bg(i,j)
 155        ap(i) = b * ap(i) + a * bp(i,j)
c        normalization of the wave function
         a = dsordf (j, k, 0, 4, fl(j))
         a = sqrt(a)
         do 171 i = 1, np
            cg(i,j) = gg(i) / a
 171        cp(i,j) = gp(i) / a
         do 175 i = 1, ndor
            bg(i,j) = ag(i) / a
 175        bp(i,j) = ap(i) / a
c        determination of the next orbital to calculate
         if (nter.lt.norbsc .or. (ind.lt.0 .and. j.lt.norbsc)) then
            j = j + 1
            go to 451
         endif
            j = j + 1
         pr = 0.
         do 301 i = 1, norbsc
            w = abs (scw(i))
            if (w .gt. pr) then
               pr = w
               j = i
            endif
 301     continue
         if (j .gt. norbsc) j = 1
         if (pr .gt. testy) go to 421
         pr = 0.
         do 321 i = 1, norbsc
            w = abs (sce(i))
            if (w .gt. pr) then
               pr = w
               j = i
            endif
 321     continue
         if (pr .ge. teste) go to 421
         if (ind .lt. 0) go to 999
         ind = -1
         j = 1
         go to 451

 421     ind = 1
 451  if (nter .le. netir) go to 101
      numerr= 192011
c **** number of iterations exceeded the limit
      dlabpr = dprlab
 711  call messer
      stop
 999  if (numerr .eq. 0) then
         if (jfail .ne. 0) then
            call wlog(
     1    '  Failed to match lower component, results are meaningless')
            stop
         endif
c        tabulation of the results
         if (iprint .ge. 5)  call tabrat
         call etotal (16, kap, xnel, xnvalp, en, eatom)
         do 504 ix = 1,251
 504       dmag(ix)=0.0d0
         ilast = 1
         iorb = 0
c        use to test SIC
c        do 505 iorb = 1,norb
 505       call vlda (iorb, xnval, srho, srhovl, dmag, ilast, idfock)
         ecorr =2.0
         call somm(dr,dmag,dmag,hx, ecorr,0,idim)
         eatom = (eatom-ecorr/4.0) * harryd

         jcore = 1
         do 500 j = 1, norb
  500      if (xnel(j).gt.xnval(j) .and. nmax(j).gt.jcore) jcore=nmax(j)

c construct atomic difference in spin-up and -down densities
c   j=15,16 are 4f orbitals of Gd. j=8,9 are d-orbitals for Mn,Fe
c   The sign change for opposite central atom spin and antiferromagnetic
c   is taken care of in ovrlp.f
         do 530 i = 1, idim
  530    dmag(i) = 0.0

c     for Fe,Mn
      if (iz.eq.26) then
         do 35 i = 1, np
   35       dmag(i) = dmag(i) + 5.0 * (cg(i,8)**2 + cp(i,8)**2)
      endif

c     for Gd
      if (iz.eq.64) then
         do 36 i=1,np
   36       dmag(i)=dmag(i) +
     1       6.0*(cg(i,15)**2+cp(i,15)**2) + cg(i,16)**2+cp(i,16)**2
     1        + cg(i,20)**2+cp(i,20)**2
      endif

c  return coulomb potential
         rcore = dr(jcore)
c  fix later: can be replaced by potrdf
         call potslw (vcoul, srho, dr, hx, idim)
         do 510 i = 1, 251
  510      vcoul(i) = (vcoul(i) - nz / dr(i)) * harryd

c        return srho as 4*pi*density instead of 4*pi*density*r**2
         do 560  i = 1, 251
            srho(i) = srho(i) / (dr(i)**2)
            dmag(i) = dmag(i) / (dr(i)**2)
            srhovl(i) = srhovl(i) / (dr(i)**2)
  560    continue

         if (iprint .ge. 3)  close(unit=16)

         if (ispinr .ne. 0)  then
c        need kap(i) for central atom without core hole, all output of
c        getorb is dummy, except iholep and kap(i) which is put in nq(i)
            call getorb (iz, ispinr, xion, i, j,
     1                   iholep, eps, nre, nq, scw, sce)
            do 552  i = 1, nmax(iholep)
               dgc0(i) = cg(i,iholep)
               dpc0(i) = cp(i,iholep)
  552       continue
            do 553  i = nmax(iholep) + 1, 251
               dgc0(i) = 0.0d0
               dpc0(i) = 0.0d0
  553       continue
         endif

         do 590 j = 1, 30
            do 570 i = 1, nmax(j)
               dgc(i,j,ifr) = cg(i,j)
               dpc(i,j,ifr) = cp(i,j)
  570       continue
            do 575 i = nmax(j) + 1, 251
               dgc(i,j,ifr) = 0.0d 00
               dpc(i,j,ifr) = 0.0d 00
  575       continue
            do 580 i = 1, 10
               adgc(i,j,ifr) = bg(i,j)
               adpc(i,j,ifr) = bp(i,j)
  580       continue
  590    continue
      endif

c     calc. overlap integrals for the final and initial state orbitals
c     of the central atom
      if (iholep .gt. 0 .and. iholep.lt.30 .and. ihole.le.0) then
         efrozn = en(iholep) * harryd
         do 790 i = 1, norb
c          to handle special case when electron added to new orbital
           if (nq(i) .eq. kap(i)) then
              itr = 0
           elseif (nq(i+1) .eq. kap(i)) then
              itr = 1
           else
              call wlog
     1        ('  If it is not la, gd or np, please, give us a call')
              call wlog('  s02 is overestimated')
              do 710 j = 1, i - 1
  710            ovpint(j,i) = 0.0
              ovpint(i,i) = 1.0
              goto 780
           endif
           i0 = i + itr
           ifr1 = 0
           do 720 ir = 1, idim
             gg(ir) = dgc(ir, i0, ifr1)
  720        gp(ir) = dpc(ir, i0, ifr1)
           do 730 ir = 1, ndor
              ag(ir) = adgc(ir, i0, ifr1)
  730         ap(ir) = adpc(ir, i0, ifr1)
           do 770 j = 1, norb
             if (kap(i) .ne. kap(j)) go to 770
             ovpint(i,j) = dsordf ( j, j, 0, 3, fl(i))
  770      continue
  780      continue
  790    continue
         call s02at (iholep, norb, kap, xnel, ovpint, s02)
c        print*,'z=',iz, '   s02 calculated = ', s02
      endif

      return
      end
      subroutine soldir (en,fl,agi,api,ainf,nq,kap,max0,ifail)
c                  resolution of the dirac equation
c                   p' - kap*p/r = - ( en/cl-v )*g - eg/r
c                   g' + kap*g/r = ( 2*cl+en/cl-v )*p + ep/r
c at the origin v approximately is -z/(r*cl) due to the point nucleus
c en one-electron energy in atomic units and negative
c fl power of the first term in development at the origin
c agi (api) initial values of the first development coefficient
c at the origin of the large(small)component
c ainf initial value for the large component at the point dr(max0)
c nq principal quantum number     kap quantum number kappa
c max0 the last point of tabulation of the wave function
c        this programm uses intdir

      implicit double precision (a-h,o-z)
      common/comdir/cl,dz,gg(251),ag(10),gp(251),ap(10),dv(251),av(10),
     2eg(251),ceg(10),ep(251),cep(10)
c gg,gp -output, dv,eg,ep - input
      dimension hg(251),agh(10),
     1hp(251),aph(10),bg(251),bgh(10),bp(251),bph(10)
c
c cl speed of light (approximately 137.037 in atomic units)
c dz nuclear charge
c gg (gp) large (small) component
c hg,hp,bg et bp working space
c dv direct potential (v)     eg and ep exchange potentials
c ag,ap,agh,aph,bgh,bph,av,ceg and cep are respectively the
c development coefficients for gg,gp,hg,hp,bg,bp,dv,eg et ep
c
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
c
c hx exponential step
c dr radial mesh
c test1 precision for the matching the small component if method=1
c test2 precision for the normalisation if method=2
c ndor number of terms for the developments at the origin
c np maximum number of the tabulation points
c nes maximum number of attempts to ajust the small component
c method at the initial time distinguish the homoginious (method=0)
c  from inhomoginious system. at the end is the index of method used.
c idim dimension of the block dr

      common/subdir/ell,fk,ccl,imm,nd,node,mat

c ell fk*(fk+1)/ccl     fk=kap     ccl=cl+cl
c imm a flag for the determination of matching point
c nd number of nodes found     node number of nodes to be found
c mat index of the matching point

      common/messag/dlabpr,numerr
      character*8 dprlab,dlabpr, drplab
c at the time of return numerr should be zero if integration is correct,
c otherwise numerr contains the number of instruction, which
c indicate the sourse and reason for abnornal return.
*     character*512 slog
      save

      data dprlab/'  soldir'/,drplab/'  intdir'/
      dlabpr=dprlab
      enav=1.0d 00
      ainf= abs(ainf)
      ccl=cl+cl
      iex=method
      if (method.le.0) method=1
c notice that iex=0,1 and method=1,2 only below.
c this was used to simplify block structure of program. ala 11/22/94
      fk=kap
      if (av(1).lt.0.0d 00.and.kap.gt.0) api=-agi*(fk+fl)/av(1)
      if (av(1).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(fk-fl)
      ell=fk*(fk+1.0d 00)/ccl
      node=nq- abs(kap)
      if (kap.lt.0) node=node+1
      emin=0.0
      do 91 i=1,np
         a=(ell/(dr(i)*dr(i))+dv(i))*cl
         if (a.lt.emin) emin=a
 91   continue
      if (emin .ge. 0.0) then
         numerr=75011
c       *potential is apparently positive
         return
      endif
      if (en.lt.emin) en=emin*0.9d 00
      edep=en

 101  numerr=0
      test=test1
      if (method.gt.1) test=test2
      einf=1.0d 00
      esup=emin
      en=edep
      ies=0
      nd=0
 105  jes=0
 106  modmat=0
      imm=0
      if ( abs((enav-en)/en).lt.1.0d-01) imm=1
      enav=en

c     integration of the inhomogenious system
 107  do 111 i=1,idim
         gg(i)=eg(i)
 111     gp(i)=ep(i)
      do 115 i=2,ndor
         ag(i)=ceg(i-1)
 115     ap(i)=cep(i-1)
      call intdir (gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0)
      if (numerr.ne.0) then
         dlabpr=drplab
         return
      endif
      if (iex.ne.0) go to 141

c     match large component for the homogenios system(method=0)
      a=ggmat/gg(mat)
      do 135 i=mat,max0
         gg(i)=a*gg(i)
 135     gp(i)=a*gp(i)
      j=mat
      go to 215

c     integration of the homogenios system
 141  do 151 i=1,idim
            hg(i)=0.0d 00
 151     hp(i)=0.0d 00
      do 155 i=1,ndor
         agh(i)=0.0d 00
 155     aph(i)=0.0d 00
      imm=1
      if (method.eq.1) imm=-1
      call intdir (hg,hp,agh,aph,hgmat,hpmat,en,fl,agi,api,ainf,max0)

c     match the large component for inhomogenious system(method=1)
      a=gg(mat)-ggmat
      if (method.lt.2) then
         b=-a/hg(mat)
      else
         b=gp(mat)-gpmat
         ah=hpmat*hg(mat)-hgmat*hp(mat)
         if (ah.eq.0.0d 00) go to 263
         c=(b*hg(mat)-a*hp(mat))/ah
         b=(b*hgmat-a*hpmat)/ah
         do 165 i=1,ndor
            ag(i)=ag(i)+c*agh(i)
 165        ap(i)=ap(i)+c*aph(i)
         j=mat-1
         do 168 i=1,j
            gg(i)=gg(i)+c*hg(i)
 168        gp(i)=gp(i)+c*hp(i)
      endif
      do 173 i=mat,max0
         gg(i)=gg(i)+b*hg(i)
 173     gp(i)=gp(i)+b*hp(i)

      if (method.ge.2) then
c        integration of the system derived from disagreement in energy
         do 175 i=2,ndor
            bgh(i)=ag(i-1)/cl
 175        bph(i)=ap(i-1)/cl
         do 177 i=1,max0
            bg(i)=gg(i)*dr(i)/cl
 177        bp(i)=gp(i)*dr(i)/cl
         call intdir (bg,bp,bgh,bph,bgmat,bpmat,en,fl,agi,api,ainf,max0)

c        match both components for inhomogenious system (method=2)
         f=bg(mat)-bgmat
         g=bp(mat)-bpmat
         a=(g*hg(mat)-f*hp(mat))/ah
         g=(g*hgmat-f*hpmat)/ah
         do 181 i=1,j
            bg(i)=bg(i)+a*hg(i)
 181        bp(i)=bp(i)+a*hp(i)
         do 182 i=1,ndor
            bgh(i)=bgh(i)+a*agh(i)
 182        bph(i)=bph(i)+a*aph(i)
         do 183 i=mat,max0
            bg(i)=bg(i)+g*hg(i)
 183        bp(i)=bp(i)+g*hp(i)
c        calculate the norm
         call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,
     1     gpmat,fl,max0,mat)

c        correction to the energy (method=2)
         do 186 i=1,max0
 186     hg(i)=(gg(i)*bg(i)+gp(i)*bp(i))*dr(i)
         ah=0.0d 00
         c=0.0d 00
         do 187 i=2,max0,2
 187     ah=ah+hg(i)+hg(i)+hg(i+1)
         ah=hx*(ah+ah+hg(1)-hg(max0))/3.0d 00+hg(1)/(fl+fl+1.0d 00)
         f=(1.0d 00-b)/(ah+ah)
         c=1.0d 00-b
         do 191 i=1,max0
            gg(i)=gg(i)+f*bg(i)
 191        gp(i)=gp(i)+f*bp(i)
         do 195 i=1,ndor
            ag(i)=ag(i)+f*bgh(i)
 195        ap(i)=ap(i)+f*bph(i)
      endif

c     search for the maximum of the modulus of large component
      a=0.0d 00
      bgh(1)=b
      bph(1)=ah
      do 211 i=1,max0
         g=gg(i)*gg(i)
         if (g.le.a) go to 211
         a=g
         j=i
 211  continue
      if (j.gt.mat .and. modmat.eq.0) then
         modmat=1
         mat=j
         if (mod(mat,2).eq.0) mat=mat+1
         imm=1
         if (mat.lt.(max0-10)) go to 107

         mat=max0-12
         j=mat
         if (mod(mat,2).eq.0) mat=mat+1
c        write(slog,'(a,i4,a,i4)') ' warning  mat=',mat,' max0=',max0
c        call wlog(slog)
      endif
c this case can happen due to bad starting point in scf procedure.
c ignore this warning unless you are getting it at final norb calls
c of soldir
c  redirected by ala 11/21/94.
c     numerr=220021
c * impossible matching point
c     go to 899

c compute number of nodes
 215  nd=1
      j= max(j,mat)
      do 231 i=2,j
         if (gg(i-1).eq.0.0d 00) go to 231
         if ((gg(i)/gg(i-1)).le.0.0d 00) nd=nd+1
 231  continue

      if (nd-node) 251,305,261
 251  esup=en
      if (einf.lt.0.0d 00) go to 271
      en=en*8.0d-01
      if ( abs(en).gt.test1) go to 285
      numerr=238031
c    *zero energy
      go to 899

 261  einf=en
      if (esup.gt.emin) go to 271
 263  en=en*1.2d 00
      if (en.gt.emin) go to 285
      numerr=245041
c    *energy is lower than the minimum of apparent potential
      go to 899

 271  if ( abs(einf-esup).gt.test1) go to 281
      numerr=249051
c    *the upper and lower limits of energy are identical
      go to 899

 281  en=(einf+esup)/2.0d 00

 285  jes=jes+1
      if (jes.le.nes) go to 106

c *number of attempts to find good number of nodes is over the limit
c this case can happen due to bad starting point in scf procedure.
c ignore this warning unless you  got it at final norb calls of soldir
c     call wlog('warning jes>nes')
      ifail=1
c    *redirected by ala 11/21/94.
c     numerr=255061
c     go to 899

c     calculation of the norm
 305  call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,
     1     gpmat,fl,max0,mat)
      if (method.eq.1) then
c        correction to the energy (method=1)
         c=gpmat-gp(mat)
         f=gg(mat)*c*cl/b
         if (gpmat.ne.0.0d 00) c=c/gpmat
      endif

      en=en+f
      g= abs(f/(en-f))
 371  if ((en.ge.0 .or. g.gt.2.0d-01) .or.
     1 (abs(c).gt.test .and. (en.lt.esup.or.en.gt.einf))) then
c        try smaller step in enrgy under above conditions
         f=f/2.0d 00
         g=g/2.0d 00
         en=en-f
         if (g.gt.test1) go to 371
         numerr=29071
c       *zero energy
         go to 899
      endif

      if ( abs(c).gt.test)  then
         ies=ies+1
         if (ies.le.nes) go to 105
         ifail=1
c        call wlog('warning: iteration stopped because ies=nes')
c     everything is fine unless you got this message on the latest stage
c     of selfconsistent process. just stopped trying to match lower
c     component, because number of trials exceeded limit.
c     lines below were commented out.  ala 11/18/94
      endif

c     numerr=298081
c    *number of attempts to match the lower component is over the limit
c     go to 899

c     divide by a square root of the norm, and test the sign of w.f.
      b= sqrt(b)
      c=b
      if ((ag(1)*agi).lt.0.0d 00.or.(ap(1)*api).lt.0.0d 00) c=-c
      do 711 i=1,ndor
         ag(i)=ag(i)/c
 711     ap(i)=ap(i)/c
      if ((gg(1)*agi).lt.0.0d 00.or.(gp(1)*api).lt.0.0d 00) b=-b
      do 721 i=1,max0
         gg(i)=gg(i)/b
 721     gp(i)=gp(i)/b
      if (max0.ge.np) return
      j=max0+1
      do 741 i=j,np
         gg(i)=0.0d 00
 741     gp(i)=0.0d 00
c     if everything o'k , exit is here.
      return

c     abnormal exit is here, if method.ne.1
 899  if (iex.eq.0 .or. method.eq.2) go to 999
      method=method+1
      go to 101

 999  return
      end

      subroutine norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,
     1 gpmat,fl,max0,mat)
c    calculate norm b. this part of original code was used twice,
c    causing difficult block structure. so it was rearranged into
c    separate subroutine. ala
      implicit double precision (a-h, o-z)
      dimension hp(251),dr(251),gg(251),gp(251),ag(10),ap(10)

      b=0.0d 00
      do 311 i=1,max0
 311  hp(i)=dr(i)*(gg(i)*gg(i)+gp(i)*gp(i))
      if (method.ne.1) go to 315
      hp(mat)=hp(mat)+dr(mat)*(gpmat**2-gp(mat)**2)/2.0d 00
 315  do 321 i=2,max0,2
 321  b=b+hp(i)+hp(i)+hp(i+1)
      b=hx*(b+b+hp(1)-hp(max0))/3.0d 00
      do 325 i=1,ndor
         g=fl+fl+i
         g=(dr(1)**g)/g
         do 325 j=1,i
 325     b=b+ag(j)*g*ag(i+1-j)+ap(j)*g*ap(i+1-j)
      return
      end
      subroutine solout (en,fl,agi,api,kap,max0,ic3,vm)
c                  resolution of the dirac equation
c                   p' - kap*p/r = - ( en/cl-v )*g - eg/r
c                   g' + kap*g/r = ( 2*cl+en/cl-v )*p + ep/r
c at the origin v approximately is -z/(r*cl) due to the point nucleus
c en one-electron energy in atomic units and negative
c fl power of the first term in development at the origin
c agi (api) initial values of the first development coefficient
c at the origin of the large(small)component
c kap quantum number kappa
c max0 the last point of tabulation of the wave function

      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
c     include 'const.h'
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (one = 1, zero = 0)
      parameter (third = one/3)
      parameter (raddeg = 180 / pi)
      complex*16 coni
      parameter (coni = (0,1))
c     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      parameter (fa = 1.919 158 292 677 512 811d0)

      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c     speed of light in louck's units (rydbergs?)
      parameter (clight = 2 * alpinv)
      parameter (npi=6, test=1.0d+5, csq=clight**2 )
      complex*16 en,agi,api,c3,vmh
      complex*16 gg,ag,gp,ap,dv,av,eg,ceg,ep,cep, vm(nrptx)
      common/comdirc/cl,dz,gg(nrptx),ag(10),gp(nrptx),ap(10),dv(nrptx),
     1   av(10),eg(nrptx),ceg(10),ep(nrptx),cep(10)

      complex*16 ec,eph,egh,f,g,ac,bc,acp,bcp,dg,dp, dv1,dv2,vh
      complex*16 dg2, dp2, dg3, dp3, dg4, dp4
      dimension dg(npi), dp(npi)

c gg,gp -output, dv,eg,ep - input
c
c cl speed of light (approximately 137.037 in atomic units)
c dz nuclear charge
c gg (gp) large (small) component
c dv direct potential (v)     eg and ep exchange potentials
c ag,ap,av,ceg and cep are respectively the
c development coefficients for gg,gp,dv,eg and ep
c
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
c hx exponential step
c dr radial mesh
c test1,test2,nes,method are dummy.
c  ndor number of terms for the developments at the origin
c np maximum number of the tabulation points
c idim dimension of the block dr


      ccl=cl+cl
      if (real(av(1)).lt.0.0d 00.and.kap.gt.0) api=-agi*(kap+fl)/av(1)
      if (real(av(1)).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(kap-fl)
      exphx = exp (hx/2)
      ihard = 0
      ec=en/cl
      ag(1)=agi
      ap(1)=api
      do 115 i=2,ndor
         ag(i)=ceg(i-1)
 115     ap(i)=cep(i-1)
c     integration of the inhomogenious system
c     no need in normalization, since we can use
c     normalization agi=ag(1)=const

c            solution of the inhomogenios dirac equation
c gg gp initially exch. terms, at the time of return are wave functions
c ag and ap development coefficients of  gg and gp
c en one-electron energy
c fl power of the first development term at the origin
c agi (api) initial values of the first development coefficients
c at the origin of a large (small) component

c     initial values for the outward integration
      if (ic3.eq.0) then
c       Desclaux power expansion
         do 35 j=2,ndor
            k=j-1
            a=fl+kap+k
            b=fl-kap+k
            eph=a*b+av(1)*av(1)
            f=(ec+ccl)*ap(k)+ap(j)
            g=ec*ag(k)+ag(j)
            do 31 i=1,k
               f=f-av(i+1)*ap(j-i)
 31            g=g-av(i+1)*ag(j-i)

            ag(j)=(b*f+av(1)*g)/eph
 35         ap(j)=(av(1)*f-a*g)/eph

         do  41 i = 1,1
            gg(i)=0.0d 00
            gp(i)=0.0d 00
c        dg(i)=0.0d 00
c        dp(i)=0.0d 00
         do 41 j=1,ndor
            a=fl+j-1
            b=dr(i)**a
            cc = a*b
c           dg(i)=dg(i)+cc*ag(j)
c           dp(i)=dp(i)+cc*ap(j)
            gg(i)=gg(i)+b*ag(j)
 41         gp(i)=gp(i)+b*ap(j)
czeroc     zero pot test
czero      gp(1) = gp(1)/gg(1)
czero      gg(1) = 1.0
      else
c        see fovrg.f in feff6, be aware of different units
         twoz = -dble(av(1)) * 2.0*cl
         rat1 = twoz/clight
         rat2 = rat1**2
         rat3 = csq/twoz
         il = -kap
         if (kap.gt.0) il = kap+1
         l0 = il-1
         ag(1) = agi
         if (twoz.le.0.0) then
            ap(1) = -ec/(2.0*il+1.0)*dr(1)*ag(1)
            ag(2) = 0.0
            ap(2) = 0.0
            ag(3) = 0.0
            ap(3) = 0.0
         else
            ap(1) = (fl-il)*rat3*ag(1)
            ag(2) = (3.0*fl-rat2)/(2.0*fl+1.0) * ag(1)
            ap(2)= rat3*( (fl -l0)*ag(2) - ag(1) ) -ap(1)
            ag(3)=( (fl+3.0*il)*ag(2) - 3.0*l0*ag(1) +
     1      (fl+il+3.0)/rat3*ap(2) ) /(fl+1.0)/4.0
            ap(3)=( rat3*(2.0*l0*(fl+2.0-il)-l0-rat2)*ag(2)
     1      - 3.0*l0*rat3*(fl+2.0-il)*ag(1) + (fl+3.0-2.0*il-rat2)
     2      *ap(2) ) /(fl+1.0)/4.0
            ap(1) = ap(1)/clight
            ag(2)= ag(2)*rat3
            ap(2)= ap(2)*rat3/clight
            ag(3)= ag(3)*rat3**2
            ap(3)= ap(3)*rat3**2/clight
         endif
         gg(1)=dr(1)**fl * (ag(1)+dr(1)*(ag(2)+dr(1)*ag(3)))
         gp(1)=dr(1)**fl * (ap(1)+dr(1)*(ap(2)+dr(1)*ap(3)))
      endif


c     runge-kutta for first npi points
      i = 1
      f = (ec - dv(i))*dr(i)
      g = f + ccl * dr(i)
      c3 = ic3*vm(1)/g**2
      dg(i) = hx * (g*gp(i) - kap*gg(i) + ep(i))
      dp(i) = hx * (kap*gp(i) - (f-c3)*gg(i) - eg(i))

 44   continue
      ac = gg(i) + 0.5d0 * dg(i)
      bc = gp(i) + 0.5d0 * dp(i)
      rh = dr(i) *exphx
c     find potential and exchange terms between 2 points
c     use linear interpolation with imp. nonlinearity correction
      xm1 = (dr(i+1)-rh) / (dr(i+1)-dr(i))
      xm2 = (rh - dr(i)) / (dr(i+1)-dr(i))
      if (dble(av(1)) .lt. 0.0) then
c        point nucleus case
c        important nonlinearity from z/r term
         dv1 = dv(i) - av(1)/dr(i)
         dv2 = dv(i+1) - av(1)/dr(i+1)
         vh = dv1*xm1 + dv2*xm2
         vh = vh + av(1)/rh
         vmh = (xm1*vm(i)*dr(i) +xm2*vm(i+1)*dr(i+1))/rh
      else
c        finite nucleus
c        important nonlinearity from z*r**2 term
         dv1 = dv(i) - av(4)*dr(i)**2
         dv2 = dv(i+1) - av(4)*dr(i+1)**2
         vh = (dv1*(dr(i+1)-rh)+dv2*(rh-dr(i))) / (dr(i+1)-dr(i))
         vh = vh + av(4)*rh**2
         vmh = (xm1*vm(i)/dr(i)**2 +xm2*vm(i+1)/dr(i+1)**2)*rh**2
      endif
      eph = ep(i) * xm1 + ep(i+1) * xm2
      egh = eg(i) * xm1 + eg(i+1) * xm2

      f = (ec - vh)*rh
      g = f + ccl * rh
      c3 = ic3*vmh/g**2
      dg2 = hx * (g*bc - kap*ac + eph)
      dp2 = hx * (kap*bc - (f-c3)*ac - egh)
      ac = ac + 0.50*(dg2-dg(i))
      bc = bc + 0.50*(dp2-dp(i))
      dg3 = hx * (g*bc - kap*ac + eph)
      dp3 = hx * (kap*bc - (f-c3)*ac - egh)
      ac = ac + dg3 - 0.50*dg2
      bc = bc + dp3 - 0.50*dp2

      i=i+1
      f = (ec - dv(i))*dr(i)
      g = f + ccl * dr(i)
      c3 = ic3*vm(i)/g**2
      dg4 = hx * (g*bc - kap*ac + ep(i))
      dp4 = hx * (kap*bc - (f-c3)*ac - eg(i))
      gg(i) = gg(i-1)+(dg(i-1) + 2.0*(dg2+dg3)+dg4)/6.0
      gp(i) = gp(i-1)+(dp(i-1) + 2.0*(dp2+dp3)+dp4)/6.0
      dg(i) = hx * (g*gp(i) - kap*gg(i) + ep(i))
      dp(i) = hx * (kap*gp(i) - (f-c3)*gg(i) - eg(i))
      if (i.lt.npi) goto 44

c     scale derivatives for milne method
      do 51 i = 1,npi
        dg(i) = dg(i)/hx
 51     dp(i) = dp(i)/hx

c     integration of the inhomogenious system
      a1 = hx * 3.3
      a2 = -hx * 4.2
      a3 = hx * 7.8
      a4 = hx * 14.0/45.0
      a5 = hx * 64.0/45.0
      a6 = hx * 24.0/45.0
      do 55 i = npi,max0-1
         nit = 0
c        predictor
         acp=gg(i-5)+a1*(dg(npi)+dg(npi-4))+a2*(dg(npi-1)+dg(npi-3))
     1       +a3*dg(npi-2)
         bcp=gp(i-5)+a1*(dp(npi)+dp(npi-4))+a2*(dp(npi-1)+dp(npi-3))
     1       +a3*dp(npi-2)
c        ac,bc -corrector w/o contribution from derivatives at i+1
         ac=gg(i-3)+a4*dg(npi-3)+a5*(dg(npi)+dg(npi-2))+a6*dg(npi-1)
         bc=gp(i-3)+a4*dp(npi-3)+a5*(dp(npi)+dp(npi-2))+a6*dp(npi-1)
         do 61 j=1,npi-1
            dg(j)=dg(j+1)
 61         dp(j)=dp(j+1)
         f=(ec-dv(i+1))*dr(i+1)
         g=f+ccl*dr(i+1)
         c3 = ic3*vm(i+1)/g**2
 64      dg(npi)=g*bcp-kap*acp+ep(i+1)
         dp(npi)=kap*bcp-(f-c3)*acp-eg(i+1)
c        corrected values
         gg(i+1)=ac+a4*dg(npi)
         gp(i+1)=bc+a4*dp(npi)
         if ( abs(test*(gg(i+1)-acp)) .gt. abs(gg(i+1)) .or.
     1        abs(test*(gp(i+1)-bcp)) .gt. abs(gp(i+1)) ) then
c           test failed
            if (nit.lt.40) then
               acp = gg(i+1)
               bcp = gp(i+1)
               nit = nit + 1
               goto 64
            else
               ihard = ihard+1
            endif
         endif
 55   continue

      do 741 i=max0+1,np
         gg(i)=0.0d 00
 741     gp(i)=0.0d 00

      return
      end
      subroutine s02at(ihole, norb, nk, xnel, ovpint, dval)
      implicit double precision (a-h,o-z)
      double precision  m1(7,7), m2(7,7)
      dimension nk(30), xnel(30), iorb(30), ovpint(30,30)

      dval = 1.0
c     loop over possible kappa for existing atoms
      do 100 kap = -4,3

c        initialize matrices and other stuff
         do 10 i = 1,7
         do 10 j = 1,7
            m1(i,j) = 0
  10        m2(i,j) = 0
         do 20 i= 1,7
            iorb(i) = 0
            m1(i,i) = 1.0
  20        m2(i,i) = 1.0
c        morb - number of orbitals with quantum number kappa
         morb = 0
         nhole = 0

c        construct the largest possible matrix for given value of kappa.
         do 40 i = 1, norb
            if (nk(i) .eq. kap) then
               morb = morb + 1
               iorb(morb) = i
               do 50 j = 1, morb
c                 print overlap integrals
c                 print*, kap,' ', iorb(j),' ', iorb(morb), '
c    1                            ovp= ',ovpint(iorb(j), iorb(morb))
   50             m1(j,morb) = ovpint(iorb(j), iorb(morb))
               do 60 j = 1, morb - 1
   60             m1(morb,j) = m1(j,morb)

               if (ihole .eq. i) nhole = morb
            endif
   40    continue
         if (morb .eq. 0) goto 100
         dum1 = determ(m1, morb, 7)
         dum1 = dum1**2

         dum3 = determ(m1, morb-1, 7)
         dum3 = dum3**2
         xn = xnel(iorb(morb))
         nmax = 2*abs(kap)
         xnh = nmax - xn
         if (nhole .eq. 0) then
            dval = dval * dum1**xn * dum3**xnh
         elseif (nhole .eq. morb) then
            dval = dval * dum1**(xn-1) * dum3**(xnh+1)
         else
            call elimin(m1,nhole,m2)
            dum2 = determ(m2,morb,7)
            dum2 = dum2**2
            dum4 = determ(m2,morb-1,7)
            dum4 = dum4**2
            dum5 = (dum4*dum1*xnh + dum2*dum3*xn)/nmax
            dval = dval * dum5 * dum1**(xn-1) * dum3**(xnh-1)
         endif

100   continue

      return
      end

      subroutine elimin(d1,n,d2)
      implicit double precision (a-h,o-z)
      dimension d1(7,7), d2(7,7)

      do 10 i = 1,7
      do 10 j = 1,7
         if (i .ne. n) then
            if (j .ne. n) then
               d2(i,j)=d1(i,j)
            else
               d2(i,j) = 0
            endif
         else
            if (j .ne. n) then
               d2(i,j) = 0
            else
               d2(i,j) = 1.0
            endif
         endif
   10 continue
      return
      end

      double precision function determ(array,nord,nrows)
c
c     calculate determinate of a square matrix
c        (from bevington "data reduction and error analysis
c         for the physical sciences" pg 294)
c     array: matrix to be analyzed
c     nord: order of matrix
c     nrows:  first dimension of matrix in calling routine
c
      double precision array(nrows,nrows)
      determ = 1.
      do 150 k=1,nord
c
c
        if (array(k,k).ne.0) go to 130
        do 100 j=k,nord
          if (array(k,j).ne.0) go to 110
  100   continue
        determ = 0.
        go to 160
c
  110   do 120 i=k,nord
          saved = array(i,j)
          array(i,j) = array(i,k)
  120   array(i,k) = saved
        determ = -determ
c
  130   determ = determ*array(k,k)
        if (k.ge.nord) go to 150
        k1 = k+1
        do 140 i=k1,nord
          do 140 j=k1,nord
  140   array(i,j) = array(i,j)-array(i,k)*array(k,j)/array(k,k)
  150 continue
  160 return
c end double precision function determ
      end

      subroutine tabrat
c      tabulation of the results
c do identifications of orbitals
c nmax number of tabulation points for wave function
c      this programm uses dsordf

      implicit double precision (a-h,o-z)
      parameter (zero = 0)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common /char/ ttl
      character*40  ttl
      character*2  titre(30)
      character*2  ttire(9)
      dimension at(8),mbi(8)
      data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/

      do 110 i=1,norb
         if (kap(i) .gt. 0) then
           j=2*kap(i)
         else
           j=-2*kap(i)-1
         endif
         titre(i)=ttire(j)
 110  continue

c     tabulation of number of points and of average values of
c                   r**n (n=6,4,2,1,-1,-2,-3)
      do 201 i=2,8
 201     mbi(i)=8-i-i/3-i/4+i/8
      lttl = istrln(ttl)
      write(16,11) ttl(1:lttl)
  11  format (10x,a)
      write(16,*)
     1'number of electrons nel and average values of r**n in a.u.'
      write(16,2061) (mbi(k),k=2,8)
 2061 format (4x,'nel','  n=',7(i2,8x))
      do 251 i=1,norb
         llq= abs(kap(i))-1
         j=8
         if (llq.le.0) j=7
         do 241 k=2,j
 241        at(k)=dsordf(i,i,mbi(k),1, zero)
 251     write(16,2071) nq(i),titre(i),xnel(i),(at(k),k=2,j)
 2071 format(i2,a2,f7.3,7(1pe10.3))

c      overlap integrals
      if (norb.le.1) return
      write(16,11) ttl(1:lttl)
      write(16,321)
 321  format(10x,'overlap integrals')
      do 351 i=1,norb-1
         do 331 j=i+1,norb
            if (kap(j).ne.kap(i)) go to 331
            at(1)=dsordf(i,j,0,1, zero)
            write(16,2091)  nq(i),titre(i),nq(j),titre(j),at(1)
 331     continue
 351  continue
 2091 format (4x,i3,a2,i3,a2,f14.7)
      return
      end
      subroutine wfirdf (en,ch,nq,kap,nmax,ido)
c     calculate initial orbiatls from integration of dirac equation
c cg (cp) large (small) radial components
c bg (bp) development coefficients at the origin of cg (cp)
c en one-electron energies
c fl power of the first term of development at the origin
c ch ionicity (nuclear charge - number of electrons)
c nq principal quantum number
c kap quantum number "kappa"
c nmax number of tabulation points for the orbitals
c ibgp first dimension of the arrays bg and bp
c        this programmes utilises nucdev,dentfa,soldir et messer

      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1         fl(30), fix(30), ibgp
      dimension en(30),nq(30),kap(30),nmax(30)
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),
     1dv(251),av(10),eg(251),ceg(10),ep(251),cep(10)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/inelma/nem
      common/messag/dlabpr,numerr
      character*8 dlabpr
      character*512 slog
      common/snoyau/dvn(251),anoy(10),nuc
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim

      cl=1.370373d+02
c    speed of light in atomic units
      dz = nz
c make r-mesh and calculate nuclear potential
c hx exponential step
c dr1 first tabulation point multiplied by nz
      hx=5.0d-02
      dr1= nz*exp(-8.8)
      call nucdev (anoy,dr,dvn,dz,hx,nuc,idim,ndor,dr1)
c notice that here nuc=1,
c unless you specify nuclear mass and thickness in nucdev.f

      a=(dz/cl)**2
      if (nuc.gt.1) a=0.0d 00
      do 11 j=1,norb
         b=kap(j)*kap(j)-a
         fl(j)= sqrt(b)
c        quick fix of development coefficients. ala
 11      fix(j) = dr(1)**(fl(j)-abs(kap(j)))
c calculate potential from thomas-fermi model
      do 21 i=1,idim
 21   dv(i)=(dentfa(dr(i),dz,ch)+dvn(i))/cl
      if (numerr.ne.0) return
      do 51 i=1,idim
         eg(i)=0.0d 00
 51      ep(i)=0.0d 00
      do 61 i=1,ibgp
         ceg(i)=0.0d 00
         cep(i)=0.0d 00
 61      av(i)=anoy(i)/cl
      av(2)=av(2)+dentfa(dr(nuc),dz,ch)/cl
      test1=testy/rap(1)
      b=test1

c resolution of the dirac equation to get initial orbitals
      if (ido.ne.1) then
         call wlog('only option ido=1 left')
         ido = 1
      endif
c  here was a piece to read orbitals from cards
      do 281 j=1,norb
         bg(1,j)=1.0d 00
         i=nq(j)- abs(kap(j))
         if (kap(j).lt.0) i=i-1
         if (mod(i,2).eq.0) bg(1,j)=-bg(1,j)
         if (kap(j).lt.0) go to 201
         bp(1,j)=bg(1,j)*cl*(kap(j)+fl(j))/dz
         if (nuc.gt.1) bg(1,j)=0.0d 00
         go to 211

 201     bp(1,j)=bg(1,j)*dz/(cl*(kap(j)-fl(j)))
         if (nuc.gt.1) bp(1,j)=0.0d 00
 211     np=idim
         en(j)=-dz*dz/nq(j)*nq(j)
         method=0
         call soldir
     1     (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),0)

         if (numerr.eq.0) go to 251
         call messer
         write(slog,'(a,2i3)')
     1   'soldir failed in wfirdf for orbital nq,kappa ',nq(j),kap(j)
         call wlog(slog)
         go to 281

 251     do 261 i=1,ibgp
            bg(i,j)=ag(i)
 261        bp(i,j)=ap(i)
         do 271 i=1,np
            cg(i,j)=dg(i)
 271        cp(i,j)=dp(i)
 281  continue
      nem=0
      return
      end
      subroutine yzkrdf (i,j,k)
c       * calculate  function yk *
c yk = r * integral of f(s)*uk(r,s)
c uk(r,s) = rinf**k/rsup**(k+1)   rinf=min(r,s)   rsup=max(r,s)
c f(s)=cg(s,i)*cg(s,j)+cp(s,i)*cp(s,j)      if nem=0
c f(s)=cg(s,i)*cp(s,j)                      if nem is non zero
c f(s) is constructed by the calling programm  if i < or =0
c in the last case a function f (lies in the block dg) is supposedly
c tabulated untill point dr(j), and its' devlopment coefficients
c at the origin are in ag and the power in r of the first term is k+2

c the output functions yk and zk are in the blocks dp and dg.
c at the origin  yk = cte * r**(k+1) - developement limit,
c cte lies in ap(1) and development coefficients in ag.
c        this programm uses aprdev and yzkteg

      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),
     1         fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
      dimension chg(10)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      common/inelma/nem
      dimension bgi(10),bgj(10),bpi(10),bpj(10)

      if (i.le.0) go to 51
c     construction of the function f
      do  5 l= 1,ibgp
        bgi(l) = bg(l,i)
        bgj(l) = bg(l,j)
        bpi(l) = bp(l,i)
  5     bpj(l) = bp(l,j)
      id= min(nmax(i),nmax(j))
      ap(1)=fl(i)+fl(j)
      if (nem.ne.0) go to 31
      do 11 l=1,id
 11   dg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)
      do 21 l=1,ndor
 21   ag(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l)
      go to 55

 31   do 35 l=1,id
 35   dg(l)=cg(l,i)*cp(l,j)
      do 41 l=1,ndor
 41   ag(l)=aprdev(bgi,bpj,l)
      go to 55

 51   ap(1)=k+2
      id=j
 55   call yzkteg (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim)
      return
      end
      subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim)
c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to
c   infinity of  f(u) * u**(-k-1)
c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k

c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1)
c dr tabulation points   h exponential step
c np number of tabulation points for f
c idim dimension of the blocks f,g and dr

c at the origin yk=cte*r**(k+1)-developement limit
c the constant for yk lies in ap
c output functions yk and zk lie in f and g, and their
c development coefficients at the origin in af and ag.

c integration from point to point by a 4 points method.
c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24

      implicit double precision (a-h,o-z)
      dimension f(251),af(10),g(251),ag(10),dr(251)

c    initialisation and development coefficients of yk
      np= min(np,idim-2)
      b=ap
      ap=0.0d 00
      g(1)=0.0d 00
      g(2)=0.0d 00
      do 15 i=1,nd
         b=b+1.0d 00
         ag(i)=af(i)/(b+k)
         if (af(i).ne.0.0d 00) then
            c=dr(1)**b
            g(1)=g(1)+ag(i)*c
            g(2)=g(2)+ag(i)*(dr(2)**b)
            af(i)=(k+k+1)*ag(i)/(b-k-1)
            ap=ap+af(i)*c
         endif
 15   continue
      do 21 i=1,np
 21   f(i)=f(i)*dr(i)
      np1=np+1
      f(np1)=0.0d 00
      f(np1+1)=0.0d 00

c     calcualation of zk
      eh= exp(h)
      e=eh**(-k)
      b=h/2.4d+01
      c=1.3d+01*b
      ee=e*e*b
      b=b/e
      do 51 i=3,np1
 51   g(i)=g(i-1)*e+(c*(f(i)+f(i-1)*e)-(f(i-2)*ee+f(i+1)*b))

c     calcualation of yk
      f(np)=g(np)
      do 61 i=np1,idim
 61   f(i)=f(i-1)*e
      i=k+k+1
      b=i*b*eh
      ee=i*ee/(eh*eh)
      e=e/eh
      c=i*c
      do 71  i=np-1,2,-1
 71   f(i)=f(i+1)*e+(c*(g(i)+g(i+1)*e)-(g(i+2)*ee+g(i-1)*b))
      ee=e*e
      c=8.0d 00*c/1.3d+01
      f(1)=f(3)*ee+c*(g(3)*ee+4.0d 00*e*g(2)+g(1))
      ap=(ap+f(1))/(dr(1)**(k+1))
      return
      end
      subroutine wfirdc (eph,kap,nmax,ikap,vxc,ps,qs,aps,aqs,irr,ic3,vm)
c     calculate photoelectron orbital using lda in dirac equation
c     cg (cp) large (small) radial components
c     bg (bp) development coefficients at the origin of cg (cp)
c     eph one-electron energy of photoelectron
c     fl power of the first term of development at the origin
c     kap quantum number "kappa"
c     nmax number of tabulation points for the orbitals
c     ikap should be equal zero for usual calculation of atomic orbitals
c      otherwise ikap is quantum number kappa for photoelectron,
c     vxc  is initial lda potential for photoelectron
c     ibgp first dimension of the arrays bg and bp
c        this programmes utilises nucdec,dentfa,soldir et messer

      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      common/dff/cg(nrptx,30),cp(nrptx,30),bg(10,30),bp(10,30),
     1             fl(30), fix(30), ibgp
      dimension kap(30),nmax(30)
c    for photoelectron potential and wavefunction will be complex
      complex*16 eph,dg,ag,dp,ap,dv,av,eg,ceg,ep,cep,vxc(nrptx)
      complex*16 ps(nrptx),qs(nrptx),aps(10),aqs(10),vm(nrptx)
      common/comdirc/cl,dz,dg(nrptx),ag(10),dp(nrptx),ap(10),
     1dv(nrptx),av(10),eg(nrptx),ceg(10),ep(nrptx),cep(10)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/messag/dlabpr,numerr
      character*8 dlabpr
      common/snoyauc/dvn(nrptx),anoy(10),nuc
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim

      cl=1.370373d+02
c     speed of light in atomic units
      dz = nz
c     make r-mesh and calculate nuclear potential
c     hx exponential step
c     dr1 first tabulation point multiplied by nz
      dr1= nz*exp(-8.8)
      call nucdec (anoy,dr,dvn,dz,hx,nuc,idim,10,dr1)
c     notice that here nuc=1,
c     unless you specify nuclear mass and thickness in nucdec.f


      a=(dz/cl)**2
czero      print*,'testing'
czero      a = 0.0

      if (nuc.gt.1) a=0.0d 00
      do 11 j=1,norb
         b=kap(j)*kap(j)-a
         if (j.eq.norb) b=b+(kap(j)+1)*ic3
         fl(j)= sqrt(b)
 11      fix(j) = dr(1)**(fl(j)-abs(kap(j)))
c     if irregular solution
      if (irr.gt.0) then
         fl(norb) = -fl(norb)
         fix(norb) = 1.0/fix(norb)
      endif

c     use lda potential to calculate initial w.f.
      do 21 i=1,idim
 21   dv(i)= vxc(i)/cl
      if (numerr.ne.0) return
      do 51 i=1,idim
         eg(i)=0.0d 00
 51      ep(i)=0.0d 00
      do 61 i=1,ibgp
         ceg(i)=0.0d 00
 61      cep(i)=0.0d 00
      call potdvp
      av(2)=av(2)+(vxc(nuc)-dvn(nuc))/cl

c     resolution of the dirac equation to get initial orbital
      do 281 j=norb,norb
         aps(1) = 1.0
         if (a .gt. 0.0d0) then
            if (kap(j)*irr .gt. 0) then
               aqs(1)=aps(1)*dz/(cl*(kap(j)-fl(j)))
            else
               aqs(1)=aps(1)*cl*(kap(j)+fl(j))/dz
            endif
         else
            if (kap(j)*irr.gt.0)then
               aps(1)=1.0d 00
               aqs(1)=0.0d 00
            else
               aps(1)=0.0d 00
               aqs(1)=1.0d 00
            endif
         endif

 211     np=1+(8.8 + log(10.0))/hx
c        exp(-8.8+(np-1)*hx) = 10.0 bohrs - max distance
         if (idim .lt. np) np=idim
         if (nmax(norb) .gt. np) nmax(norb)=np

czero         print*,'testing'
czero         do 333 ix = 1,10
czero 333       av(ix) = 0.0
czeroc     testing
czero        do 63 i=1,idim
czero 63     dv(i) = 0.0

         call solout (eph,fl(j),aps(1),aqs(1),kap(j),nmax(j),ic3,vm)

         do 261 i=1,10
            aps(i)=ag(i)
 261        aqs(i)=ap(i)
         do 271 i=1,idim
            ps(i)=dg(i)
 271        qs(i)=dp(i)
 281  continue
      return
      end
      subroutine yzkrdc (i,k,flps,ps,qs,aps,aqs)
c       * calculate  function yk *
c yk = r * integral of f(s)*uk(r,s)
c uk(r,s) = rinf**k/rsup**(k+1)   rinf=min(r,s)   rsup=max(r,s)
c j=norb for photoelectron
c f(s)=cg(s,i)*cg(s,j)+cp(s,i)*cp(s,j)
c f(s) is constructed by the calling programm  if i < or =0
c in the last case a function f (lies in the block dg) is supposedly
c tabulated untill point dr(j), and its' devlopment coefficients
c at the origin are in ag and the power in r of the first term is k+2

c the output functions yk and zk are in the blocks dp and dg.
c at the origin  yk = cte * r**(k+1) - developement limit,
c cte lies in ap(1) and development coefficients in ag.
c        this programm uses aprdec and yzktec

      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      complex*16 aprdec
      complex*16 ps(nrptx),qs(nrptx),aps(10),aqs(10)
      common/dff/cg(nrptx,30), cp(nrptx,30), bg(10,30), bp(10,30),
     1             fl(30), fix(30), ibgp
      complex*16 dg,ag,dp,ap,bidcom, chg(10)
      common/comdirc/cl,dz,dg(nrptx),ag(10),dp(nrptx),ap(10),
     1   bidcom(3*nrptx+30)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1   nq(30),kap(30),nmax(30)
      common/tabtesc/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgi(10),bpi(10)

c     construction of the function f
      do  5 l= 1,ibgp
        bgi(l) = bg(l,i)
  5     bpi(l) = bp(l,i)
      id=min(nmax(i),np)
      ap(1)=fl(i)+flps
      do 11 l=1,id
 11   dg(l)=cg(l,i)*ps(l)+cp(l,i)*qs(l)
      do 12 l = id+1,idim
 12    dg(l) = 0.0d0
      do 21 l=1,ndor
 21   ag(l) = aprdec(aps,bgi,l) + aprdec(aqs,bpi,l)

      call yzktec (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim)
      return
      end
      subroutine yzktec (f,af,g,ag,dr,ap,h,k,nd,np,idim)
c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to
c   infinity of  f(u) * u**(-k-1)
c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k

c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1)
c dr tabulation points   h exponential step
c np number of tabulation points for f
c idim dimension of the blocks f,g and dr

c at the origin yk=cte*r**(k+1)-developement limit
c the constant for yk lies in ap
c output functions yk and zk lie in f and g, and their
c development coefficients at the origin in af and ag.

c integration from point to point by a 4 points method.
c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24

      implicit double precision (a-h,o-z)
c     include 'dim.h'
      parameter (nphx = 7)
      parameter (npotx = nphx)
      parameter (nfrx = nphx)
      parameter (novrx = 8)
c     parameter (natx = 250)
      parameter (natx = 1000)
      parameter (ltot = 24)
      parameter (nrptx = 1251)
      parameter (nex = 100)
      parameter (lamtot=15)
      parameter (mtot=4, ntot=2)
      parameter (legtot=9)
      parameter (npatx = 8)
      complex*16 f,af,g,ag,ap
      dimension f(nrptx),af(10),g(nrptx),ag(10),dr(nrptx)

c    initialisation and development coefficients of yk
      np= min(np,idim-1)
      f(np+1)=0.0d0
      b = dble(ap)
      ap=0.0d 00
      g(1)=0.0d 00
      do 15 i=1,nd
         b=b+1.0d 00
         ag(i)=af(i)/(b+k)
         if (af(i).ne.0.0d 00) then
            c=dr(1)**b
            g(1)=g(1)+ag(i)*c
c         for irregular solution b-k-1 can become zero
            if (abs(b-k-1) .le. 0.00001) then
               af(i) = 0.0
               b = b - 1.0d0
            else
               af(i)=(k+k+1)*ag(i)/(b-k-1)
            endif
            ap=ap+af(i)*c
         endif
 15   continue
      do 21 i=1,np
 21   f(i)=f(i)*dr(i)

c     calcualation of zk
      hk=h*k
      e = exp(-h)
      ehk = e**k

      if (k.ne.0)then
       b1 = (ehk-1.0d0 +hk) / (hk*k)
      else
       b1=h/2.0
      endif

      b0 = h-(1.0+hk)*b1
      do 51 i=1,np
 51      g(i+1)=g(i)*ehk+b0*f(i)+f(i+1)*b1

c     calculation of yk
      f(np+1)=g(np+1)
      ehk=ehk*e
      i=k+k+1
      hk=hk+h
      b1 = i*(ehk-1.0d0 +hk) / (hk*(k+1))
      b0 = i*h-(1.0+hk)*b1
      do 75  i=np,1,-1
 75      f(i) = f(i+1)*ehk+b0*g(i+1)+b1*g(i)

      ap=(ap+f(1))/(dr(1)**(k+1))
      return
      end