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

c Main Authors of FEFF8: please contact us concerning any problems.
c A. L. Ankudinov, alex@phys.washington.edu      (206) 543 3904
c B. Ravel,        bruce.ravel@nist.gov          (301) 975-5759
c J. J. Rehr,      jjr@phys.washington.edu       (206) 543 8593

c Citations: Please cite at least one of the following articles if 
c FEFF8 is used in published work: 
c    1) Main FEFF8 reference 
c       A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson, 
c       Phys. Rev. B 58, 7565, (1998).
c    2) Multiple scattering theory
c       J.J. Rehr and R.C. Albers, Phys. Rev. B 41, 8139 (1990).
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      program feff
      integer iabs, nabs
      logical ceels !KJ added ceels 5-06

      call rdinp(nabs,ceels)
      call ffmod1
      call ffmod2
      do 900 iabs = 1, nabs
        if (nabs.gt.1) call ffsort (iabs,ceels) !KJ 5-6 added second argument
        call ffmod4
        call ffmod5
        call ffmod6(iabs)
        call ffmod9
 900  continue
      stop
      end
c///////////////////////////////////////////////////////////////////////
c Distribution:  RDINP 1.0
c Copyright (c) [2002] University of Washington
c 
c This software was prepared in part with US Government Funding under
c DOE contract DE-FG03-97ER45623.

c Redistribution and use of this Distribution in source and binary
c formats, with or without modification is permitted, provided the 
c following conditions are met:
c 
c Redistributions must retain the above notices and the following list
c of conditions and disclaimer;
c 
c Modified formats carry the marking
c     "Based on or developed using Distribution: RDINP 1.0
c      RDINP 1.0 Copyright (c) [2002] University of Washington"
c 
c Recipient acknowledges the right of the University of Washington to
c prepare uses of this Distribution and its modifications that may be
c substantially similar or functionally equivalent to
c Recipient-prepared modifications.
c
c Recipient and anyone obtaining access to the Distribution through
c recipient's actions accept all risk associated with possession and
c use of the Distribution.
c
c THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
c WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
c MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
c IN NO EVENT SHALL THE UNIVERSITY OF WASHINGTON OR CONTRIBUTORS TO THE
c DISTRIBUTION BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
c EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
c PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
c REVENUE; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
c LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
c NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
c SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c     sub-program exchange point
!     program rdinp 
      subroutine rdinp (nabs,ceels)

c    reads 'feff.inp' file and writes several files in special format
c    ready for the use by other modules: geom.dat, global.dat,
c    mod1.inp, mod2.inp, mod3.inp mod4.inp mod5.inp mod6.inp ldos.inp .
c    The subroutine output 'nabs' is needed for configurational average
c    The rest of output, passed to wrtall via common blocks (allinp.h)

c     coded s. zabinski 1994
c     last modified by a.l.ankudinov march 2001  for new i/o structure

      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../RDINP/allinp.h
c     Common blocks with all input data
c     the common
cc    atoms.dat
      integer  natt
      integer iphatx(nattx)
      double precision  ratx(3,nattx)
      common /geom/ ratx, iphatx, natt
cc    geom.dat
c       integer  nat
c       integer iatph(0:nphx)
c       integer iphat(natx)
c       double precision  rat(3,natx)
c       common /geom/ ratx, iphatx, natt
cc    global.inp
c       configuration average
      integer iphabs
c     global polarization data
      integer  ipol, ispin, le2
      double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
      complex*16 ptz(-1:1, -1:1)
      common /global/ ptz, evec, xivec, spvec, elpty, angks, rclabs, 
     1     ipol, ispin, le2, iphabs
c     c    mod1.inp
      character*80 title(nheadx)
c     integer mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec,
      integer mpot, nph, ntitle, ihole, ipr1, iafolp, iunf,
     1     nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
      integer iz(0:nphx)
      integer lmaxsc(0:nphx)
      real rfms1
      double precision gamach, rgrd, ca1, ecv, totvol
      double precision  xnatph(0:nphx), folp(0:nphx), spinph(0:nphx)
      double precision  xion(0:nphx)
c     for OVERLAP option
      integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
      double precision  rovr(novrx,0:nphx)
      common /mod1/ title, xion, xnatph, spinph, folp, gamach, rgrd,
     1     ca1, ecv, totvol, rovr, rfms1, iz, lmaxsc, mpot, nph, ntitle,
     2     ihole, ipr1, iafolp, nmix,nohole,jumprm, inters,
     3     nscmt, icoul, lfms1, novr, iphovr, nnovr, iunf
c     c    ldos.inp
      integer mldos, lfms2
      double precision emin, emax, eimag, rfms2
      common /mod7/ emin, emax, eimag, rfms2, mldos, lfms2
cc    mod2.inp
c     integer mphase, ipr2, ixc, ixc0, vr0, vi0, ispec, lreal, lfms2
      integer mphase, ipr2, ixc, ixc0, ispec, lreal, l2lp, iPlsmn
      integer lmaxph(0:nphx), iGrid
      character*6  potlbl(0:nphx)
c     double precision rgrd, rfms2, gamach, xkstep, xkmax, vixan
      double precision xkstep, xkmax, vixan, vr0, vi0
      common /mod2/ xkstep, xkmax, vixan, vr0, vi0, 
     &     lmaxph, mphase, ipr2, ixc, ixc0, ispec, lreal, l2lp,
     &     izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis, iPlsmn,
     &     iGrid, potlbl
c     c    mod3.inp
      integer mfms, idwopt, minv
c     integer lmaxph(0:nphx)
c     real rfms2, rprec, rdirec, toler1, toler2
      real rprec, rdirec, toler1, toler2
      double precision   tk, thetad, sig2g
      common /mod3/ tk, thetad, sig2g, rprec, rdirec, toler1,
     1       toler2,  mfms, idwopt, minv
c     c    mod4.inp
      integer  mpath, ms, nncrit, nlegxx, ipr4
c     real critpw, pcritk, pcrith,  rmax, rfms2
      real critpw, pcritk, pcrith,  rmax
      common /mod4/ critpw, pcritk, pcrith,  rmax,
     1       mpath, ms, nncrit, nlegxx, ipr4
c     c    mod5.inp
      integer  mfeff, ipr5, iorder
      logical  wnstar
      double precision critcw
      common /mod5/ critcw, mfeff, ipr5, iorder, wnstar
c     c    mod6.inp
c     integer  mchi, ispec, idwopt, ipr6, mbconv
c     double precision  vrcorr, vicorr, s02, alphat, sig2g
      integer  mchi, ipr6, mbconv, absolu !KJ added absolu 3-06
      double precision  vrcorr, vicorr, s02, alphat, thetae
      common /mod6/ vrcorr, vicorr, s02, alphat, thetae, 
     &     mchi, ipr6, mbconv, absolu   !KJ added absolu 3-06
c     c    so2.inp  
      integer  mso2conv, ipse, ipsk
      double precision wsigk, cen
      character(12) cfname
      common /so2/ wsigk, cen, cfname, mso2conv, ipse, ipsk
      
c     c    eels.inp
c     EELS variables  !KJ 1-06 this section added for ELNES, EXELFS, MAGIC cards
      real*8 ebeam, aconv, acoll, thetax, thetay, emagic
      integer eels, relat, aver, cross, iinput,spcol
      integer nqr,nqf,magic
      integer ipmin,ipmax,ipstep
      common /eelsva/ ebeam,aconv,acoll,thetax,thetay,emagic,magic,
     &     nqr, nqf, aver, cross, relat, iinput, spcol,ipmin, ipmax,
     &     ipstep, eels
c     !KJ end
	
c= ../RDINP/allinp.h}
c={../HEADERS/vers.h
      character*12 vfeff
c                       123456789012  
      parameter (vfeff='Feff 8.50')
c= ../HEADERS/vers.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

c     Single scattering path to go with Overlap information
      parameter (nssx = 16)
      dimension indss(nssx), iphss(nssx)
      dimension degss(nssx), rss(nssx)

c     Local stuff
      character*150  line
      dimension ltit(nheadx)
      parameter (nwordx = 20)
      character*20 words(nwordx)
      integer iatph(0:nphx)
      integer icnt  !KJ 1-06 this is just a local index that doesn't need to be saved

      parameter (nbr=30)
      logical nogeom
      parameter (big = 1.0e5)
      character*512 slog
      character*12 tmpstr
      logical ceels  !KJ for monolithic version 5-6

      external dist

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

      call par_begin
      if (worker) go to 400

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

      tmpstr = vfeff
      call triml (tmpstr)
      call wlog(' ' // tmpstr)

c     initialize all things to be passed
      nabs = 1
      call iniall

c     initialize local staff 
      iatom = 0
      ifolp = 0
      iovrlp = 0
      iphabs = 0
      lxnat = 0
      folpx = 1.15d0
      nogeom = .false.
      rclabs = big
      rmult = 1.0d0
      s02h = 1.0d0
      natt = 0
      nss = 0
      do 90  iss = 1, nssx
         indss(iss) = 0
         iphss(iss) = 0
         degss(iss) = 0
         rss(iss) = 0
  90  continue
      do 95 iph = 0, nphx
  95  iatph(iph) = 0

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 RPATH or 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 CRIT (CRITERIA)
c            17 if NOGEOM
c            18 if IORDER
c            19 if PCRI (PCRITERIA)
c            20 if SIG2
c            21 if XANE (XANES)
c            22 if CORR (CORRECTIONS)
c            23 if AFOL (AFOLP)
c            24 if EXAF (EXAFS)
c            25 if POLA (POLARIZATION)
c            26 if ELLI (ELLIPTICITY) 
c            27 if RGRI (RGRID)
c            28 if RPHA (RPHASES), real phase shifts
c            29 if NSTA (NSTAR), n* for co-linear polarization
c            30 if NOHO (NOHOLE), use no hole for potentials
c            31 if SIG3 third and first cumulants for ss paths
c            32 if JUMP (JUMPRM), remove jumps of potential   
c            33 if MBCO (MBCONV), do convolution with exitation spectrum
c            34 if SPIN do calculation for spin-up(down) photoelectron  
c            35 if EDGE to specify edge by name
c            36 if SCF  do self-consistency loop
c            37 if FMS  use FMS for cluster of the size rfms
c            38 if LDOS print out l-dos for specified energy range
c            39 if INTE how to find interstitial parameters
c            40 if CFAV to do configuration average
c            41 if S02  to specify S_0^2
c            45 if RSIG (RSIGMA), real self-energy 
c            46 if XNCD natural dichroism
c            47 if MULT for quadrupolar etc. transitions
c            48 if UNFR unfreeze f-electrons
c            49 if TDLDA use TDLDA background
c            50 if PMBSE use BSE for background
c            51 if PLASMON       - Added by Josh Kas
c                                - PLASMON
c                                - With this card set, ffmod2 will read exc.dat and
c                                - use a multiple pole self energy
c            52 if S02C (S02CONV) compute S_0^2 from response function
c            53 if SELF print on shell self energy as a function of E.
c            54 if SFSE print off shell self energy and spectral function.
c            55 if RCONV print running convolution with spectral function.
c            56 if ELNE calculate ELNES  !KJ 1-06
c            57 if EXEL calculate EXELFS !KJ 1-06
c            58 if MAGI plot magic angle !KJ 1-06
c            59 if ABSO don't normalize spectrum !KJ 3-06
c            60 if EGRID (Gives user control of grid through grid.inp)
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
c                4 reading EELS input  !KJ

c#mn{
c  replaced read of feff.inp with  call to rdline, which will:
c    1. read from feff.inp if found, otherwise will stop and complain
c       (support for reading from standard input would be easy to add)
c    2. handles line processing tasks like 
c         = ignoring comment lines and blank lines
c         = tab removal
c    3. allows 'include' files in input file
c    4. for initial call, set jinit = -1, line = input_file_name
c
      mode  = 0
      jinit = -1
      line  = 'feff.inp'
  200 continue 
         call rdline(jinit,line)
         if (line .eq. 'read_line_end')    line='END'
         if (line .eq. 'read_line_error')  line='END'
c#mn}

         nwords = nwordx
         call bwords (line, nwords, words)
         itok = itoken (words(1),'feff.inp')

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
               iatom  = iatom  +1
            elseif (itok .eq. 2)  then
c              HOLE     1  1.0
c                   holecode s02
               read(words(2),20,err=900)  ihole
               if (nwords.gt.2) read(words(3),30,err=900)  s02h
               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
               iovrlp = iovrlp +1
            elseif (itok .eq. 4)  then
c              CONTROL  mphase, mpath, mfeff, mchi
c               0 - do not run modules, 1 - run module
               if (nwords.eq.5) then
c                 feff7 input file
                  read(words(2),20,err=900)  mpot
                  mphase = mpot
                  mfms = mpot
                  read(words(3),20,err=900)  mpath
                  read(words(4),20,err=900)  mfeff
                  read(words(5),20,err=900)  mchi
               else
c                 feff8 input file
                  read(words(2),20,err=900)  mpot
                  read(words(3),20,err=900)  mphase
                  read(words(4),20,err=900)  mfms
                  read(words(5),20,err=900)  mpath
                  read(words(6),20,err=900)  mfeff
                  read(words(7),20,err=900)  mchi
               endif
               mode = 0
            elseif (itok .eq. 5)  then
c              EXCHANGE  ixc  vr0  vi0 (ixc0)
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=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, ixc0 = 2)
               vr0=0.0
               vi0=0.0
               read(words(2),20,err=900)  ixc
!              if (nwords.ge.3) (read(words(3),30,err=900)  vr0
                read(words(3),30,err=900)  vr0
!              if (nwords.ge.4) read(words(4),30,err=900)  vi0
                read(words(4),30,err=900)  vi0
               if (nwords .gt. 4) read(words(5),20,err=900)  ixc0
               if (ixc .ge. 3)  call warnex(' EXCHANGE >= 3:')
               mode = 0
            elseif (itok .eq. 6)  then
c              ION  iph xion(iph)
               read(words(2),20,err=900)  iph
               call phstop(iph,line)
               read(words(3),30,err=900)  xion(iph)
               call warnex(' ION:')
               mode = 0
            elseif (itok .eq. 7)  then
c              TITLE title...
               ntitle = ntitle + 1
               if (ntitle .le. nheadx)  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)
               ifolp = 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              RPATH rmax (max r for ss and pathfinder)
               read(words(2),30,err=900)  rmax
            elseif (itok .eq. 10)  then
c              DEBYE  temp debye-temp ( idwopt )
c                   temps in kelvin
c                   idwopt = 0 use CD model
c                   idwopt = 1 use EM method
c                   idwopt = 2 use RM method
c                   idwopt = -1,-2,... don't calculate DW factors
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
               idwopt=0 
               if (nwords.gt.3) then
                 read(words(4),20,err=900)  idwopt
                 if (idwopt.gt.2) then
                    write(slog,'(a,i5,2x,a)')
     1                 ' Option idwopt=',idwopt,'is not available.'
                    call wlog(slog)
                    write(slog,'(a)')
     1                   '...setting idwopt=2 to use RM.' 
                    call wlog(slog)
                 endif
               endif
               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)
                  call par_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 ipr5 ipr6
c              print flags for various modules
c              ipr1 potph  0 pot.bin only
c                          1 add misc.dat
c                          2 add pot.dat
c                          5 add atom.dat
c                          6 add central atom dirac stuff
c                          7 stop after doing central atom dirac stuff
c              ipr2 xsph   0 phase.bin only
c                          2 add  phase.dat
c                          3 add  emesh.dat
c              ipr3 fmstot  currently is dummy
c              ipr4 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              ipr5 genfmt 0 files.dat, feff.dats that pass 2/3 of
c                            curved wave importance ratio
c                          1 keep all feff.dats
c              ipr6 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
               if (nwords.eq.5) then
c                 feff7 input file
                  read(words(2),20,err=900)  ipr1
                  ipr2 = ipr1
                  ipr3 = ipr1
                  read(words(3),20,err=900)  ipr4
                  read(words(4),20,err=900)  ipr5
                  read(words(5),20,err=900)  ipr6
               else
c                 feff8 input file
                  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
                  read(words(6),20,err=900)  ipr5
                  read(words(7),20,err=900)  ipr6
               endif
               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              CRIT critcw critpw
               read(words(2),30,err=900)  critcw
               read(words(3),30,err=900)  critpw
               mode = 0
            elseif (itok .eq. 17)  then
c              NOGEOM (do not write geom.dat) (disabled)
               nogeom = .true.
               mode = 0
            elseif (itok .eq. 18)  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. 19)  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. 20)  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. 21)  then
c              XANES ( xkmax  xkstep vixan)
               slog='XANES is not available in this version of feff8.5'
               call wlog(slog)
               call wlog("Ignoring XANES")
            elseif (itok .eq. 22)  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. 23)  then
c              AFOLP use generalized automatic folp
               folpx = 1.15
               if (nwords.ge.2) read(words(2),30,err=900)  folpx
               mode =0
            elseif (itok .eq. 24)  then
c              EXAFS  xkmax for energy grid
               read(words(2),30,err=900)  xkmax
               mode = 0
            elseif (itok .eq. 25)  then
c              POLARIZATION  X Y Z
               ipol = 1
c              run linear polarization code 
               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. 26)  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. 27)  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)
               i = 1 + int (12.5d0 / rgrd)
               if (mod(i,2) .eq. 0) i = i + 1
               if (i.gt.nrptx) then
                 write(slog,'(a,i6)') 
     1           ' FATAL error in RGRID: increase in dim.h nrptx to', i
                 call wlog(slog)
                 call par_stop(' ')
               endif
               mode = 0
            elseif (itok .eq. 28)  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 = 2
               mode = 0
            elseif (itok .eq. 29)  then
c              NSTAR, write out n* for colinear polarization
               wnstar = .true.
               mode = 0
            elseif (itok .eq. 30)  then
c              NOHOLE
               if (nohole.lt.0) then
                  nohole = 0
                  if (nwords.ge.2) read(words(2),20,err=900)  nohole
                  call warnex(' NOHOLE:')
               end if
            elseif (itok .eq. 31)  then
c              SIG3 alphat  thetae   first and third cumulants for ss paths
               read(words(2),30,err=900)  alphat
               if (nwords.ge.3) read(words(3),20,err=900)  thetae
               call warnex(' SIG3:')
               write(slog,'(a,1pe13.5)') ' SIG3, alphat ; ', alphat
               call wlog(slog)
               mode = 0
            elseif (itok .eq. 32)  then
c              JUMPRM remove potential jumps at muffin tin radii
               jumprm = 1
            elseif (itok .eq. 33)  then
c              MBCONV do many body convolution with excitation spectrum
               mbconv = 1
            elseif (itok .eq. 34)  then
c              SPIN  specifies spin direction on central atom 
               read(words(2),20,err=900)  ispin 
c              set default spin along z axis
               if (ispin.ne.0) spvec(3) = 1.d0
               if (nwords.gt.2) read(words(3),30,err=900)  spvec(1)
               if (nwords.gt.3) read(words(4),30,err=900)  spvec(2)
               if (nwords.gt.4) read(words(5),30,err=900)  spvec(3)
            elseif (itok .eq. 35)  then
c              EDGE     L3 
c                   holecode
               call setedg (words(2), ihole)
               mode = 0
            elseif (itok .eq. 36)  then
c              SCF    rfms [ lfms nscmt  ca1 nmix  ecv icoul]
c              number of cycles, mode of calculating coulomb potential,
c              convergence accelerator
               nscmt = nbr
               ca1 = 0.2d0
               read(words(2),30,err=900)  rfms1
               if (nwords.gt.2) read(words(3),20,err=900)  lfms1
               if (nwords.gt.3) read(words(4),20,err=900)  nscmt
               if (nwords.gt.4) read(words(5),30,err=900)  ca1
               if (nwords.gt.5) read(words(6),20,err=900)  nmix
               if (nwords.gt.6) read(words(7),30,err=900)  ecv
               if (nwords.gt.7) read(words(8),20,err=900)  icoul
               if (nscmt.le.0 .or. nscmt.gt.nbr) nscmt = nbr
               if (lfms1.gt.0) lfms1 = 1
c              sanity checks for ca1
               if (ca1.lt.0) ca1 =0
               if (ca1.gt.0.5) then
                 call wlog(' Reduce convergence factors in SCF ')
                 call par_stop
     .            (' Cannot run with specified ca1 in SCF card.')
               endif
               if (ecv.ge.0) ecv = -40.0
               if (nmix.le.0) nmix=1
               if (nmix.gt.30) nmix=30
            elseif (itok .eq. 37)  then
c              FMS   rfms2  (lfms2 minv toler1 toler2 rdirec)
c              radius of the cluster to do FMS
               slog="FMS is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring FMS")
            elseif (itok .eq. 38)  then
               slog="LDOS is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring LDOS")
            elseif (itok .eq. 39)  then
c              INTERSTITIAL  inters  totvol
c              inters = 1 local V_int (around central atom)
c              inters = 0 extended V_int (average over all atoms)
c              more obscure options described in manual
               read(words(2),20,err=900)  inters
               if (nwords.ge.3) read(words(3),30,err=900)  totvol
            elseif (itok .eq. 40) then
c              CFAV  iphabs nabs rclabs
               read(words(2),20,err=900)  iphabs
               read(words(3),20,err=900)  nabs
               read(words(4),30,err=900)  rclabs
               if (rclabs.lt.0.5) rclabs=big
               mode = 0
            elseif (itok .eq. 41) then
c              S02  s02
               read(words(2),30,err=900)  s02
               mode = 0
            elseif (itok .eq. 42)  then
               slog="XES is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring XES")
            elseif (itok .eq. 43)  then
               slog="DANES is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring DANES")
c              DANES ( xkmax  xkstep vixan)
            elseif (itok .eq. 44)  then
c              FPRIME  emin emax estep
               slog="FPRIME is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring FPRIME")
            elseif (itok .eq. 45)  then
c              RSIGMA  (real self energy only)
               call warnex(' RSIGMA :')
               call wlog(' Real self energy only will be used.  ' //
     1                   'FEFF results will be unreliable.')
               if (lreal.lt.1) lreal = 1
               mode = 0
            elseif (itok .eq. 46)  then
c              XNCD or XMCD
               slog="XMCD is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring XMCD")
            elseif (itok .eq. 47)  then
c              MULTIPOLES le2 (l2lp)
               read(words(2),20,err=900)  le2
               if (nwords.gt.2) read(words(3),20,err=900)  l2lp
               mode = 0
            elseif (itok .eq. 48)  then
c              UNFREEZEF   
               iunf = 1
               mode = 0
            elseif (itok .eq. 49)  then
c              TDLDA 
               slog="TDLDA is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring TDLDA")
            elseif (itok .eq. 50)  then
c              PMBSE 
               slog="PMBSE is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring PMBSE")
            elseif (itok .eq. 51)  then ! Added by Josh Kas
c              PLASMON
               if(nwords.gt.1) then
                  read(words(2),20,err=900) iPlsmn
               else
                  iPlsmn = 1
               end if
            elseif (itok .eq. 52)  then ! Added by Josh Kas
c              S02CONV
               mso2conv = 1
            elseif (itok .eq. 53)  then ! Added by Josh Kas
c              SELF (print out on shell self energy Sig(k(E),E) )
               ipse = 1
            elseif (itok .eq. 54)  then ! Added by Josh Kas
c              SFSE k0 (print out self energy Sig(k0,E) ) 
               ipsk = 1
               read(words(2),30,err=900)  wsigk
            elseif (itok .eq. 55) then ! Added by Josh Kas
c              RCONV (print running convolution with file cfname at energy cen)
c              RCONV cen cname
               read(words(2),30,err=900) cen
               cfname = words(3)(1:12)
            elseif (itok.eq.56) then  !KJ added this card 1-06
c               ELNES
               slog="ELNES is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring ELNES")
            elseif (itok.eq.57) then  !KJ added this card 1-06
c               EXELFS
               slog="EXELFS is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring EXELFS")
            elseif (itok .eq. 58) then !KJ added this card 1-06
c               MAGIC card
               slog="MAGIC is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring MAGIC")
            elseif (itok .eq. 59) then !KJ added this card 3-06
c               ABSOLUTE card
               slog="ABSOLUTE is not available in this" // 
     &                  "version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring ABSOLUTE")
            elseif ( itok .eq. 60) then
c               EGRID card
               slog="EGRID is not available in this version of FEFF8.5"
               call wlog(slog)
               call wlog("Ignoring EGRID")
            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.')
               call par_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
            natt = natt+1
            if (natt.gt. nattx)  then
               write(slog,'(a,i8)') 'Too many atoms, max is ', nattx
               call wlog(slog)
               call par_stop('RDINP-3')
            endif
            read(words(1),30,err=900)  ratx(1,natt)
            read(words(2),30,err=900)  ratx(2,natt)
            read(words(3),30,err=900)  ratx(3,natt)
            read(words(4),20,err=900)  iphatx(natt)
            if (iatph(iphatx(natt)) .le. 0) iatph(iphatx(natt)) = natt
         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)
               call par_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)
               call par_stop('RDINP')
            endif
            read(words(2),20,err=900)  iz(iph)
            if (iz(iph).lt. 6) then
               lmaxsc(iph) = 1
            elseif (iz(iph).lt.55) then
               lmaxsc(iph) = 2
            else
               lmaxsc(iph) = 3
            endif
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)
            if (nwords .ge. 4)  then
              read(words(4),20,err=900) ltmp
              if (ltmp.ge.1 .and. ltmp.le.lx) lmaxsc(iph) = ltmp
            endif
            lmaxph(iph) = 3
            if (iz(iph).lt.6) lmaxph(iph) = 2
            if (nwords .ge. 5)  then
              read(words(5),20,err=900) ltmp
              if (ltmp.ge.1 .and. ltmp.le.lx) lmaxph(iph) = ltmp
            endif
            if (nwords .ge. 6) then
              read(words(6),30,err=900) xnatph(iph)
              lxnat = 1
            endif
            if (nwords .ge. 7) then
              read(words(7),30,err=900) spinph(iph)
            endif
           elseif (mode.eq.4) then  !KJ 1-06 this mode added to read ELNES card
             if(icnt.eq.5) then
                 read(words(1),30,err=900) ebeam   ! read beam energy in keV
                 ebeam=ebeam * dble(1000)  ! convert to eV
                 read(words(2),20,err=1011) aver ! average over sample to beam orientation?
                 read(words(3),20,err=1011) cross ! calculate cross terms?
                 read(words(4),20,err=1011) relat ! use relativistic q-vector?
		 read(words(5),20,err=1012) iinput ! read xmu.dat or opconsKK.dat or ... ?   !KJ 5/6
                 read(words(6),20,err=1013) spcol !column that has spectrum
		 if (aver.eq.1) icnt=icnt-1 !skip the line for beam orientation
                 goto 1011
 1012		 iinput=1		 
 1013            spcol=4
                 if(iinput.eq.2) spcol=3
 1011          continue ! Josh - Should these 1011 be 900? !KJ No.  Optional input.
              elseif(icnt.eq.4) then
d                 read(words(1),30,err=900) xivec(1)  ! read direction of incoming beam
                 read(words(2),30,err=900) xivec(2)  ! in arbitrary units
                 read(words(3),30,err=900) xivec(3)
                 xinorm=dsqrt(xivec(1)**2+xivec(2)**2+xivec(3)**2)
		 if (xinorm.gt.0.0) then
		    do i=1,3
                       xivec(i)=xivec(i)/xinorm    ! normalize this vector.
		    enddo
		 elseif(.not.(aver.eq.1)) then
		    call wlog('WARNING : beam direction unspecified
     1                  in orientation sensitive EELS calculation.
     2                  Please correct before running EELS module.')
		 endif
             elseif(icnt.eq.3) then
                 read(words(1),30,err=900) acoll  ! collection semiangle in mrad
                 read(words(2),30,err=900) aconv  ! convergence semiangle in mrad
                 acoll=acoll/dble(1000);aconv=aconv/dble(1000) ! convert from mrad to rad
             elseif(icnt.eq.2) then
                 read(words(1),20,err=900) nqr    ! specify q-mesh, radial parameter
                 read(words(2),20,err=900) nqf    ! specify q-mesh, angular parameter
		 if(nqr*nqf.eq.0) then
		    call wlog('WARNING : zero q-mesh points specified
     1               for EELS calculation.  Please correct before
     2               running EELS module.')
                 endif
           elseif(icnt.eq.1) then
                 read(words(1),30,err=900) thetax ! detector position in plane perpendicular to beam ; angle in mrad
                 read(words(2),30,err=900) thetay ! detector position in plane perpendicular to beam ; angle in mrad
                 mode=0  ! finished reading ELNES card
!! initialize evec to be nonzero and perpendicular to xivec
!               if(dabs(xivec(1)-xivec(2)).gt.0.0001.or.
!     1            dabs(xivec(2)-xivec(3)).gt.0.0001) then
!                     evec(1)=xivec(2)*xivec(1)-xivec(3)**2
!                     evec(2)=xivec(3)*xivec(2)-xivec(1)**2
!                     evec(3)=xivec(1)*xivec(3)-xivec(2)**2
!                 else
!                     evec(1)=xivec(2)
!                     evec(2)=dble(0)
!                     evec(3)=-xivec(2)
!                 endif
             endif
             icnt=icnt-1    ! now read the next line
         !KJ end my changes                            
         else
            write(slog,'(a,i8)') 'Mode unrecognized, mode ', mode
            call wlog(slog)
            call par_stop('RDINP-6')
         endif
      goto 200
  220 continue
c done reading input file, 
c#{mn
c call rdline with jinit=0 to clean up all input files
       jinit = 0
       call rdline(jinit,line)
c#mn}

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



c !KJ added this check 1-06
      if(magic.eq.1.and.(eels.ne.1)) then
          call wlog('To use MAGIC card you must have ELNES card.')
          call wlog('Ignoring MAGIC card.')
          magic=0
        endif
c !KJ

c  !KJ another check for eels 1-06
      if((eels.eq.1).and.(aver.eq.1).and.(cross.eq.1)) then
          call wlog('WARNING : you have asked to calculate an
     1   orientation averaged spectrum, but you have also asked
     2   to calculate cross-terms.  Averaging kills the cross terms.
     3   Hence the program ignores your request and does not
     4   calculate cross terms.')
      endif
c  !KJ

c  !KJ  set up a variable needed for elnes 1-06
        if(eels.eq.1) then
          if(aver.eq.1) then
             ipstep=1
             ipmin=10
             ipmax=10
          else
            ipmin=1
            ipmax=9
            if(cross.eq.1) then
               ipstep=1
            else
               ipstep=4
            endif
          endif
        endif
c  !KJ


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

c     Do not use ihole .le. 0
      if (ihole .le. 0)  then
         call wlog(' Use NOHOLE to calculate without core hole.')
         call wlog(' Only ihole greater than zero are allowed.')
         call par_stop('RDINP')
      endif

c     Find out how many unique potentials we have
c     in POTENTIAL card
      nph = 0
      do 300  iph = nphx, 0, -1
         if (iz(iph) .gt. 0)  then
            nph = iph
            goto 301
         endif
  300 continue
  301 continue

c     cannot use OVERLAP and ATOMS cards together
      if (iatom .gt. 0 .and. iovrlp .gt. 0)  then
        call wlog(' Cannot use ATOMS and OVERLAP in the same feff.inp.')
        call par_stop('RDINP')
      endif

c     cannot use OVERLAP and CFAVERAGE   cards together
      if (novr(0) .gt. 0) then
c        OVERLAP is used, cannot do configuration average
         iphabs = 0
         nabs = 1
         rclabs = big
      endif

c     Must have central atom
      if (iz(0) .le. 0)  then
         if (iphabs .gt. 0) then
c           central atom is of the iphabs type
            iz(0) = iz(iphabs)
            potlbl(0) = potlbl(iphabs)
            lmaxsc(0) = lmaxsc(iphabs)
            lmaxph(0) = lmaxph(iphabs)
            xion(0) = xion(iphabs)
         else
            call wlog(' No absorbing atom (unique pot 0) was defined.')
            call par_stop('RDINP')
         endif
      endif

c     No gaps allowed in unique pots.  Make sure we have enough
c     to overlap all unique pots 0 to nph.
      if (iphabs.gt.0 .and. iatph(0).le.0)   iatph(0) = iatph(iphabs)
      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.')
            call par_stop('RDINP-')
         endif
c        by default freeze f-electrons and reset lmaxsc=2
         if (iunf.eq.0 .and. lmaxsc(iph).gt.2) lmaxsc(iph)=2
  340 continue

c     Need number of atoms of each unique pot, count them.  If none,
c     set to one. Do statistics for all atoms in feff.inp.
      do 350  iph = 0, nph
        if (lxnat.eq.0) then 
          xnatph(iph) = 0
          do 346  iat = 1, natt
              if (iphatx(iat) .eq. iph)  xnatph(iph) = xnatph(iph)+1
  346     continue
          if (iph.gt.0 .and. iph.eq.iphabs) xnatph(iph) = xnatph(iph)-1
        else
          if (xnatph(iph).le. 0.01) then
            if (iph.eq.0) then
              xnatph(iph) = 0.01d0
            else
              write (slog,'(a,i4)') ' Inconsistency in POTENTIAL card'//
     1                              ' is detected for unique pot ', iph
              call wlog (slog)
              call wlog (' Results might be meaningless.')
            endif
          endif
        endif
        if (xnatph(iph) .le. 0)  xnatph(iph) = 1
  350 continue
      if (lxnat.ne.0) then
c        normalize statistics to hav one absorber
         do 351 iph = 1, nph
  351    xnatph(iph) = xnatph(iph) /xnatph(0)
         xnatph(0) = 1
      endif
      xnat = 0
      do 352 iph = 0,nph
  352 xnat = xnat + xnatph(iph)

c     Find distance to nearest and most distant atom (use overlap card
c     if no atoms specified.)
      if (natt .lt. 2)  then
         ratmin = rovr(1,0)
         ratmax = rovr(novr(0),0)
      else
         ratmax = 0
         ratmin = 1.0e10
         iatabs = iatph(0)
         icount = 0
         if (iatabs.le.0) iatabs = iatph( iphabs)
         if (iatabs.le.0) call par_stop('RDINP fatal error: iatabs=NaN')

         do 412  iat = 1, natt
           if (iphatx(iat) .eq. iphabs .or. iphatx(iat).eq.0)
     1        icount = icount +1
           if (iat.ne.iatabs) then
c           skip absorbing atom
            tmp = dist (ratx(1,iat), ratx(1,iatabs))
            if (tmp .gt. ratmax)  ratmax = tmp
            if (tmp .lt. ratmin)  ratmin = tmp
           endif
  412    continue
         if (nabs.le.0) nabs = icount
      endif

c     Set total volume
      if (totvol.gt.0) totvol = totvol * ratmin**3 * xnat

c     Set rfms if they are too small
      if (rfms1 .lt. ratmin) rfms1 = -1.e0
      if (rfms2 .lt. ratmin) rfms2 = -1.e0
      if (rfms2 .lt. ratmin .and. ispec.lt.2) ispec = - ispec 
      if (rfms2 .lt. ratmin .and. ispec.eq.3) ispec = - ispec 
c     if ispec.le.0 MS expansion will be used, else - FMS method.
      

c     Set rmax if necessary
      if (rmax.le.0 .and. nss.le.0 .and. ispec.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) and s02
      iph = 0
      call setgam (iz(iph), ihole, gamach)
      if (s02.eq.1.d0) s02=s02h

c     Convert everything to code units, and use rmult factor
c     rmax is for pathfinder, so leave it in Ang.
      rmax = rmax * rmult
      rfms1 = rfms1 * rmult 
      rfms2 = rfms2 * rmult 
      totvol = totvol * rmult**3
c     Use rmult factor.  Leave distances in Ang.
      do 430  iat = 1, natt
         do 420  i = 1, 3
            ratx(i,iat) = ratx(i,iat) * rmult
  420    continue
  430 continue
      do 460  iph = 0, nph
         do 450  iovr = 1, novr(iph)
            rovr(iovr,iph) = rovr(iovr,iph) * rmult
  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     Clean up control flags
      if (mpot .ne. 0)  mpot = 1
      if (mphase .ne. 0)  mphase = 1
      if (mfms .ne. 0)  mfms = 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 (ifolp  .ne. 0)  iafolp = -1
      if (natt.le.0) then
c       Overalp geometry
        mfms = 0
        mpath = 0
        ms = 0
c       no SCF loop
        nscmt = 0
        do 464 iph = 0, nph
          if (novr(iph).le.0) call par_stop('Bad OVERLAP cards.')
  464   continue
      endif

      if (iafolp .ge. 0) then
         do 485 i = 0, nphx
  485    folp(i) = folpx
      endif

      if (ntitle .le. 0)  then
         ntitle = 1
         title(1) = 'Null title'
      endif
      do 490  i = 1, ntitle
         ltit(i) = istrln (title(i))
  490 continue
      nttl = ntitle

c     write atoms.dat, global.inp, modN.inp and ldos.inp
      call wrtall (nabs)

c     In case of OVERLAP and SS calculateions write 'paths.dat'
c     without invoking the pathfinder. Single scattering paths only.
      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)
  706    format (1x, 71('-'))
         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

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

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 (ipr4 .lt. 2)  ipr4 = 2
         if (nabs.gt.1) call 
     1     par_stop('NOGEOM and CFAVERAGE are incompatible')
      else
c       temporarily call ffsort. here
        iabs = 1
c !KJ 1-06 : If the user does EELS and doesn't calculate cross terms for an
c       orientation sensitive calculation, FEFF mustn't change the
c       coordinate system, as this would lead to the appearance of
c       cross terms after all.  Therefore, I added an argument to the
c       calling sequence of ffsort.
c       To be precise, giving '.false.' disables the call of ffsort to mkptz.
c       Giving '.true.' makes ffsort work exactly as it always has.
        if((eels.eq.1)) then
           call ffsort(iabs,.false.)
        else
           call ffsort(iabs,.true.)
        endif   !KJ end my changes
       endif
       
       ceels=(eels.eq.1) !KJ 5-6 for monolithic version

      close(unit=11)
  400 call par_barrier
      call par_end

c     sub-program exchange
!     stop
      return

c     normal end of rdinp

  900 continue
      call wlog(' Error reading input, bad line follows:')
      write(slog,'(1x,a)') line(1:71)
      call wlog(slog)
      call par_stop('RDINP fatal error.')

      end

      subroutine phstop (iph,line)
      implicit double precision (a-h, o-z)
      character*(*) line
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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)
         call par_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 ffsort (iabs,doptz)
c KJ 1-06 : I added second input argument doptz      
      implicit double precision (a-h, o-z)

c     finds iabs-th atom of 'iphabs' type in file atoms.dat and writes
c     a smaller list of all atoms within 'rclabs' of that particular
c     absorber into 'geom.dat' file.
c      first coded by a.l.ankudinov, 1998 for CFAVERAGE card
c      modified by a.l.ankudinov, march 2001 for new i/o structure

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/vers.h
      character*12 vfeff
c                       123456789012  
      parameter (vfeff='Feff 8.50')
c= ../HEADERS/vers.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

cc    INPUT
cc    atoms.dat
        integer  natt
        integer iphatx(nattx)
        double precision  ratx(3,nattx)
	logical doptz  !KJ 1-06 : call mkptz or not?	
cc    global.dat
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    OUTPUT: geom.dat
        integer  nat
        integer iatph(0:nphx), iphat(natx), index(natx)
        double precision  rat(3,natx)

c     Local stuff
      parameter (big = 1.0e5)
      character*512 slog

      external dist

c     if (worker) go to 400

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)

cc    read atoms.dat file
      open (file='atoms.dat', unit=3, status='old',iostat=ios)
        read(3, 35) slog, natt
  35    format (a8, i7)
        read  (3, 10) slog
        do 40  iat = 1, natt
          read (3,36) ratx(1,iat), ratx(2,iat), ratx(3,iat), iphatx(iat)
  36      format( 3f13.5, i4)
  40    continue
      close(3)

c     read global.inp
c     CFAVERAGE iphabs nabs rclabs
        open (file='global.dat', unit=3, status='old',iostat=ios)
        call chopen (ios, 'global.inp', 'ffsort')
        read (3, 10) slog
        read (3, 45) nabs, iphabs, rclabs
  45    format ( 2i8, f13.5)
c       global polarization data
        read  (3,10) slog
        read  (3, 50)  ipol, ispin, le2, elpty, angks
  50    format ( 3i5, 2f12.4)
        read  (3, 10) slog
        do 60 i = 1,3
          read  (3,30) evec(i), xivec(i), spvec(i)
  60    continue
        read  (3, 10) slog
        do 70 i = -1, 1
          read (3,30) a1, b1, a2, b2, a3, b3
          ptz(-1,i)= cmplx(a1,b1) 
          ptz(0,i) = cmplx(a2,b2) 
          ptz(1,i) = cmplx(a3,b3) 
  70    continue
      close(3)

c     Find the first absorber (iphabs type) in a long list (iabs.le.0),
c     or find iabs-th atom in the list of type iphabs (iabs.gt.0)
      iatabs = 0
      icount = 0
      ifound = 0
      do 305 iat = 1, natt
         if (iphatx(iat) .eq. 0) iphatx(iat) = iphabs
         if (iphatx(iat) .eq. iphabs) icount = icount +1
         if (ifound.eq.0 .and. icount.gt.0 .and. (icount.eq.iabs .or.
     1                          (iabs.le.0 .and. icount.eq.1))) then
            iatabs = iat
            ifound =1
         endif
  305 continue

c     Make several sanity checks
      if (iatabs.eq.0 .and. natt.gt.1) then
         call wlog(' No absorbing atom (unique pot 0 or iphabs in'//
     1             ' CFAVERAGE  card) was defined.')
         call par_stop('RDINP')
      endif
      if (iphabs.eq.0 .and. icount.gt.1) then
         call wlog(' More than one absorbing atom (potential 0)')
         call wlog(' Only one absorbing atom allowed')
         call par_stop('RDINP')
      endif
      if ((icount.gt.0 .and. icount.lt.nabs) .or. nabs.le.0) then
         nabs = icount
         call wlog(' Averaging over ALL atoms of iphabs type')
      endif

c     Make absorbing atom first in the short list
      if (iatabs .ne. 0) then
         rat(1,1) = 0
         rat(2,1) = 0
         rat(3,1) = 0
         iphat(1) = 0
         index(1) = iatabs
      endif
          
c     make a smaller list of atoms from a big one
      nat = 1
      do 309 iat = 1,natt
         if (iat.ne.iatabs) then
            tmp = dist (ratx(1,iat), ratx(1,iatabs))
            if (tmp.gt.0.1 .and. tmp.le.rclabs) then
               nat = nat + 1
               if (nat.gt.natx) then
                 write (slog, 307) nat, natx
  307            format (' Number of atoms', i6, 'exceeds max allowed',
     1           ' for the pathfinder =', i6)
                 call wlog (' Use or reduce rclabs in CFAVERAGE card')
                 call wlog (' Or increase parameter natx and recompile')
                 call par_stop('RDINP')
               endif
               rat(1,nat) = ratx(1,iat)-ratx(1,iatabs)
               rat(2,nat) = ratx(2,iat)-ratx(2,iatabs)
               rat(3,nat) = ratx(3,iat)-ratx(3,iatabs)
               iphat(nat) = iphatx(iat)
               index(nat) = iat
            endif
         endif
 309  continue
c     sort atoms by distance
      do 315 iat = 1,nat-1
        r2min = rat(1,iat)**2 + rat(2,iat)**2 + rat(3,iat)**2
        imin = iat
        do 310 i = iat+1,nat
          r2 = rat(1,i)**2 + rat(2,i)**2 + rat(3,i)**2
          if (r2.lt.r2min) then
            r2min = r2
            imin = i
          endif
 310    continue
        if (imin.ne.iat) then
c         permute coordinates for atoms iat and imin
          do 311 i = 1,3
            r2 = rat(i,iat)
            rat(i,iat) = rat(i,imin)
            rat(i,imin) = r2
 311      continue
          i = iphat(iat)
          iphat(iat) = iphat(imin)
          iphat(imin) = i
          i = index(iat)
          index(iat) = index(imin)
          index(imin) = i
        endif
 315  enddo

c     rotate xyz frame for the most convinience and make
c     polarization tensor
c     make polarization tensor when z-axis is along k-vector 
      if (doptz)  !KJ I added this if-statement 1-06
     1  call mkptz( ipol, elpty, evec, xivec, ispin, spvec, nat, rat,
     2           angks, le2, ptz)
c     rewrite global.inp for initial iteration to update 'ptz'
      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c       configuration average data
        write (3, 10) ' nabs, iphabs - CFAVERAGE data'
        write (3, 45) nabs, iphabs, rclabs
c       global polarization data
        write (3,10) ' ipol, ispin, le2, elpty, angks'
        write (3, 50)  ipol, ispin, le2, elpty, angks
        write (3, 10) 'evec         xivec        spvec'
        do 360 i = 1,3
          write (3,30) evec(i), xivec(i), spvec(i)
 360    continue
        write (3, 10) ' polarization tensor '
        do 370 i = -1, 1
          write(3,30) dble(ptz(-1,i)), dimag(ptz(-1,i)), dble(ptz(0,i)),
     1                dimag(ptz(0,i)),  dble(ptz(1,i)), dimag(ptz(1,i))
 370    continue
      close(3)
c     Find model atoms for unique pots that have them
c     Use atom closest to absorber for model
      do 316  iph = 1, nphx
 316  iatph(iph) = 0
c     By construction absorbing atom is first in the list
      iatph(0) = 1
      nph = 0
      do 330  iph = 1, nphx
         rabs = big
         do 320  iat = 2, nat
            if (iph .eq. iphat(iat))  then
               tmp = dist (rat(1,iat), rat(1,1))
               if (tmp .lt. rabs)  then
c                 this is the closest so far
                  rabs = tmp
                  iatph(iph) = iat
               endif
            endif
  320    continue
         if (iatph(iph).gt.0) nph = iph
  330 continue
c     if iatph > 0, a model atom has been found.

c     Check if 2 atoms are closer together than 1.75 bohr (~.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 * bohr)  then
               call wlog(' WARNING:  TWO ATOMS VERY CLOSE TOGETHER.' //
     1                   '  CHECK INPUT.')
               iatx = index(iat)
               jatx = index(jat)
               write(slog,'(a,2i8)') ' atoms ', iatx, jatx
               call wlog(slog)
               write(slog,'(i5,1p,3e13.5)') iatx, (ratx(i,iatx),i=1,3)
               call wlog(slog)
               write(slog,'(i5,1p,3e13.5)') jatx, (ratx(i,jatx),i=1,3)
               call wlog(slog)
               call wlog(' Run continues in case you really meant it.')
            endif
  470    continue
  480 continue

c     Write output geom.dat
      open (file='geom.dat', unit=3, status='unknown',iostat=ios)
        write (3,535) nat, nph
  535   format ('nat, nph = ', 2i5)
        write (3,516) (iatph(iph), iph=0,nph)
  516   format(16i5)
        write (3, 10) ' iat     x       y        z       iph  '
        write (3, 526)
  526   format (1x, 71('-'))
        ibounc = 1
        do 540  i = 1, nat
          write(3,536) i, rat(1,i), rat(2,i), rat(3,i), iphat(i), ibounc
  536     format(i4, 3f13.5, 2i4)
  540   continue
      close(3)

c     Atoms for the pathfinder
      if (iatabs .le. 0)  then
         call wlog(' Absorbing atom coords not specified.')
         call wlog(' Cannot find multiple scattering paths.')
         call par_stop('RDINP')
      endif

c 400 call par_barrier

      return
      end
      subroutine iniall
c     initializes all input variables contained in the
c     common blocks of the header file allinp.h 
c     written by Alexei Ankudinov , march 2001.
c     following the suggested by Bruce Ravel subroutine iorini
      implicit double precision (a-h, o-z)

      real szero, sone
      double precision dzero, done
      parameter(szero = 0.e0, dzero = 0.d0)
      parameter(sone = 1.e0,  done = 1.d0)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../RDINP/allinp.h
c     Common blocks with all input data
c     the common
cc    atoms.dat
      integer  natt
      integer iphatx(nattx)
      double precision  ratx(3,nattx)
      common /geom/ ratx, iphatx, natt
cc    geom.dat
c       integer  nat
c       integer iatph(0:nphx)
c       integer iphat(natx)
c       double precision  rat(3,natx)
c       common /geom/ ratx, iphatx, natt
cc    global.inp
c       configuration average
      integer iphabs
c     global polarization data
      integer  ipol, ispin, le2
      double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
      complex*16 ptz(-1:1, -1:1)
      common /global/ ptz, evec, xivec, spvec, elpty, angks, rclabs, 
     1     ipol, ispin, le2, iphabs
c     c    mod1.inp
      character*80 title(nheadx)
c     integer mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec,
      integer mpot, nph, ntitle, ihole, ipr1, iafolp, iunf,
     1     nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
      integer iz(0:nphx)
      integer lmaxsc(0:nphx)
      real rfms1
      double precision gamach, rgrd, ca1, ecv, totvol
      double precision  xnatph(0:nphx), folp(0:nphx), spinph(0:nphx)
      double precision  xion(0:nphx)
c     for OVERLAP option
      integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
      double precision  rovr(novrx,0:nphx)
      common /mod1/ title, xion, xnatph, spinph, folp, gamach, rgrd,
     1     ca1, ecv, totvol, rovr, rfms1, iz, lmaxsc, mpot, nph, ntitle,
     2     ihole, ipr1, iafolp, nmix,nohole,jumprm, inters,
     3     nscmt, icoul, lfms1, novr, iphovr, nnovr, iunf
c     c    ldos.inp
      integer mldos, lfms2
      double precision emin, emax, eimag, rfms2
      common /mod7/ emin, emax, eimag, rfms2, mldos, lfms2
cc    mod2.inp
c     integer mphase, ipr2, ixc, ixc0, vr0, vi0, ispec, lreal, lfms2
      integer mphase, ipr2, ixc, ixc0, ispec, lreal, l2lp, iPlsmn
      integer lmaxph(0:nphx), iGrid
      character*6  potlbl(0:nphx)
c     double precision rgrd, rfms2, gamach, xkstep, xkmax, vixan
      double precision xkstep, xkmax, vixan, vr0, vi0
      common /mod2/ xkstep, xkmax, vixan, vr0, vi0, 
     &     lmaxph, mphase, ipr2, ixc, ixc0, ispec, lreal, l2lp,
     &     izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis, iPlsmn,
     &     iGrid, potlbl
c     c    mod3.inp
      integer mfms, idwopt, minv
c     integer lmaxph(0:nphx)
c     real rfms2, rprec, rdirec, toler1, toler2
      real rprec, rdirec, toler1, toler2
      double precision   tk, thetad, sig2g
      common /mod3/ tk, thetad, sig2g, rprec, rdirec, toler1,
     1       toler2,  mfms, idwopt, minv
c     c    mod4.inp
      integer  mpath, ms, nncrit, nlegxx, ipr4
c     real critpw, pcritk, pcrith,  rmax, rfms2
      real critpw, pcritk, pcrith,  rmax
      common /mod4/ critpw, pcritk, pcrith,  rmax,
     1       mpath, ms, nncrit, nlegxx, ipr4
c     c    mod5.inp
      integer  mfeff, ipr5, iorder
      logical  wnstar
      double precision critcw
      common /mod5/ critcw, mfeff, ipr5, iorder, wnstar
c     c    mod6.inp
c     integer  mchi, ispec, idwopt, ipr6, mbconv
c     double precision  vrcorr, vicorr, s02, alphat, sig2g
      integer  mchi, ipr6, mbconv, absolu !KJ added absolu 3-06
      double precision  vrcorr, vicorr, s02, alphat, thetae
      common /mod6/ vrcorr, vicorr, s02, alphat, thetae, 
     &     mchi, ipr6, mbconv, absolu   !KJ added absolu 3-06
c     c    so2.inp  
      integer  mso2conv, ipse, ipsk
      double precision wsigk, cen
      character(12) cfname
      common /so2/ wsigk, cen, cfname, mso2conv, ipse, ipsk
      
c     c    eels.inp
c     EELS variables  !KJ 1-06 this section added for ELNES, EXELFS, MAGIC cards
      real*8 ebeam, aconv, acoll, thetax, thetay, emagic
      integer eels, relat, aver, cross, iinput,spcol
      integer nqr,nqf,magic
      integer ipmin,ipmax,ipstep
      common /eelsva/ ebeam,aconv,acoll,thetax,thetay,emagic,magic,
     &     nqr, nqf, aver, cross, relat, iinput, spcol,ipmin, ipmax,
     &     ipstep, eels
c     !KJ end
	
c= ../RDINP/allinp.h}

c     initialize character string arrays
      do 10 i=1,nheadx
        title(i) = ' '
 10   continue

c  initialize integer scalars
      iGrid = 0 ! Josh Kas
      ntitle = 0
      nat = 0
      natt = 0
      nph = 0

      iafolp = 0
      idwopt = -1
      ihole = 1
      inters = 0
      iorder = 2
      ipr1 = 0
      ipr2 = 0
      ipr3 = 0
      ipr4 = 0
      ipr5 = 0
      ipr6 = 0
      ipse = 0
      ipsk = 0
      ispec = 0
      ixc = 0
      ixc0 = -1
      jumprm = 0
      lfms1 = 0
      lfms2 = 0
      minv = 0
      lreal = 0
      mbconv = 0
      mchi = 1
      mfeff = 1
      mfms = 1
      mpath = 1
      mphase = 1
      mldos = 0
      mpot = 1
      ms = 0
      iPlsmn = 0 ! Josh Kas
      mso2conv = 0 ! Josh Kas
      nlegxx = 10
      nmix = 1
      nohole = -1
      nscmt = 0
      icoul = 0
      iunf = 0
      izstd = 0
      ifxc = 0
      ipmbse = 0
      itdlda = 0
      nonlocal = 0
      ibasis = 0

cc initialize reals
      critpw = 2.5*sone
      pcritk = szero
      pcrith = szero
      rmax = -1 * sone
      rfms1 = -1 * sone
      rfms2 = -1 * sone
      rdirec = -1 * sone
      toler1 = 1.d-3
      toler2 = 1.d-3

cc initialize double precision scalars
      alphat = dzero
      thetae = dzero
      ca1 = dzero
      critcw = 4*done
      eimag = -1*done
      ecv = -40*done 
      emax = dzero
      emin = 1000*done
      rclabs = dzero
      rgrd = 0.05 * done
      s02 = done
      sig2g = dzero
      thetad = dzero
      tk = dzero
      totvol = dzero
      vr0 = dzero
      vi0 = dzero
      vicorr = dzero
      vrcorr = dzero
      xkmax = 20*done
      xkstep = 0.07*done
      vixan = dzero
      wsigk = dzero ! Josh Kas
      cen = dzero ! Josh Kas
      
cc initialize logicals
      wnstar = .false.


c  initialize loops of number of potentials
      do 110 i=0,nphx
        xnatph(i) = dzero
        spinph(i) = dzero
        iz(i) = 0
        xion(i) = dzero
        folp(i) = done
        novr(i) = 0
        lmaxsc(i) = 0
        lmaxph(i) = 0
        potlbl(i) = ' '
 110  continue

c  initialize polarization data
      ipol = 0
      ispin = 0
      le2 = 0
      l2lp = 0
      elpty = dzero
      angks = dzero
      do 130 i=1,3
        evec(i) = dzero
        xivec(i) = dzero
        spvec(i) = dzero
 130  continue
      do 150 i=-1,1
        do 140 j=-1,1
          ptz(j,i) = cmplx(dzero,dzero)
 140    continue
 150  continue

c  initialize atom list data
      do 170 i=1,nattx
 170  iphatx(i) = -1

c  initialize character strings - Josh Kas
      cfname = 'NULL'
      
c  initialize EELS variables !KJ 1-06
      ebeam=dzero
	aconv=dzero
	acoll=dzero
	nqr=0
	nqf=0
	magic=0
	emagic=dzero
	eels=0
	relat=1
	cross=1
	aver=0
      thetax=dzero
	thetay=dzero
	ipmin=1
	ipmax=9
	ipstep=1
	iinput=1  !5/6
       spcol=4
c KJ 

c for ABSOLUTE card  !KJ 3-06
        absolu=0  !KJ 3-06

      return
      end
c  end subroutine iniall
      subroutine mkptz (ipol, elpty, evec, xivec, ispin, spvec,nat,rat,
     1                  angks, le2, ptz)
c     choose new right handed frame of reference with z along spvec,
c      y along (xivec cross spvec); simpler choice if one of them is 0.
c     get all vectors in new frame and
c     makes polarization tensor ptz when z is rotated along k-vector

c     input:
c     ipol = 0  random k-vector orientation in 3d; ptz(i,j)=\delta_{i,j}
c     ipol = 1 for polarizion vector eps and it's  complex conjugate epc
c        ptz(j,i) = 0.5 [(eps(-i))^* eps(-j) + (epc(-i))^* epc(-j)]
c        notice that complex conjugation and taking i-th component
c        are non commuting operations. (eps(-i))^* = (-)^i (epc(i))
c     ipol = 2 ptz(i,j)= i*\delta_{i,j}
c     elpty - ellipticity (optional for ipol=1)
c     xivec - direction of x-ray propagation
c     ispin - type of spin calculations
c        0 - spin independent
c        -1,1 - spin dependent potential
c        2 - calculations with spin-up potential
c       -2 - calculations with spin-down potential
c     spvec - direction of spin vector (along z at the output)
c     nat - number of atoms
c     rat - xyz cordinates of atoms (changed due to the rotations)

c     output:
c     angks - angle between k-vector and spin-vector (0-pi)
c     le2   - 0-only E1, 1-E1+M1, 2-E1+E2, 3-E1+E2+M1 transitions
c     ptz   - polarization tensor

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

c     all input and output through common area /pol/
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      dimension evec(3), xivec(3), spvec(3), rat(3,nat)
      complex*16 ptz
      dimension ptz(-1:1, -1:1)

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

c     make z axis along propagation (XIVEC).
c     le2=0 - only E1 transitions; le2=1 - E1+M1; le2=2 - E1+E2 
      rr = xivec(1)**2 + xivec(2)**2 + xivec(3)**2
      if (rr.eq.0) then
        angks = 0
c       special case when xivec is not specified
        if (ipol.eq.1) then
c         need to know xivec for E2 and M1 transitions
c         leave only E1 contribution
          if (le2.ne.0) call wlog(
     1    '  Can do only E1 transitions. Specify k-vector for M1 or E2')
          le2 = 0
        else
c         for polarization average of circular dichroizm
          if (ispin.ne.0) then
c           spin-dependent case
            do 10 i = 1,3
  10        xivec(i) = spvec(i)
            rr = xivec(1)**2 + xivec(2)**2 + xivec(3)**2
          endif
        endif
      endif
            
              
      if (rr.gt.0) then
         rsp = sqrt(rr)
         rr = xivec(1)**2 + xivec(2)**2
         if ( rr.ne.0 .or. xivec(3).lt.0) then
           if (rr.eq. 0) then
             cst = - 1
             snt = 0
             csf = 1
             snf = 0
           else
c            rotation is defined by angles theta and fi
             rr = sqrt(rr)
             cst = xivec(3) / rsp
             snt = rr / rsp
             csf = xivec(1) / rr
             snf = xivec(2) / rr
           endif
c          rotate all vectors
           do 20 i = 1, nat
 20        call rotate (rat(1,i), cst, snt, csf, snf)
           call rotate (evec, cst, snt, csf, snf)
           call rotate (xivec, cst, snt, csf, snf)
           call rotate (spvec, cst, snt, csf, snf)
         endif
      endif


c     initialize ptz
      do 30 i=-1,1
      do 30 j=-1,1
 30   ptz(j,i) = 0

c     make ptz in the frame when z is along xivec, except ipol=0
      if (ipol .eq. 0) then
         do 40 i=-1,1
 40      ptz(i,i) = 1.d0 /3.d0
      elseif (ipol .eq. 2) then
         ptz( 1, 1) =  1.d0
         ptz(-1,-1) = -1.d0
      elseif (ipol .eq. 1) then
c       Normalize polarization vector
        x = sqrt (evec(1)**2 + evec(2)**2 + evec(3)**2)
        if (x .le. 0.000001) then
         call wlog(' STOP  Polarization vector of almost zero length')
         call wlog(' Correct POLARIZATION card')
         call par_stop('MKPTZ-1')
        endif
        do 50  i = 1, 3
         evec(i) = evec(i) / x
  50    continue
        x = sqrt (xivec(1)**2 + xivec(2)**2 + xivec(3)**2)
        if (x .gt. 0) then
c         run elliptical polarization code
          do 60  i = 1, 3
            xivec(i) = xivec(i) / x
  60      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')
            call wlog(' Correct ELLIPTICITY and POLARIZATION cards')
            call par_stop('MKPTZ-2')
          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
            call wlog(' Changing polarization vector!')
            call wlog(' Incidence is not normal to polarization.')
            call wlog(' Check your input for errors. Run continues.')
            do 70  i = 1,3
              evec(i) = evec(i) - x*xivec(i)
  70        continue
            x = sqrt (evec(1)**2 + evec(2)**2 + evec(3)**2)
            do 80   i = 1, 3
               evec(i) = evec(i) / x
  80        continue
          endif
        else
c         elpty cannot be used with xivec=0
          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 90   i = 1,3
          e(i) = (evec(i)+elpty*e2(i)*coni)
  90    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 100  i = 1,3
          e(i) = (evec(i)-elpty*e2(i)*coni)
  100   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 110 i = -1,1
        do 110 j = -1,1
c         ptz(j,i) = (-1.0)**i * epc(i)*eps(-j) / (1+elpty**2)
c         above - true polarization tensor for given ellipticity, 
c         below - average over left and right in order to have
c         path reversal simmetry
          ptz(j,i) = ((-1.0)**i)*(epc(i)*eps(-j)+eps(i)*epc(-j))
     1               /(1+elpty**2)/2.0
  110   continue
      endif
c     end of making polarization tensor

      angks = 0


c     second rotate so that z parrallel to spin
c     note that new y-axis is normal to spin AND incidence vector
c     which simplifies further expression for rotation matrix
      rr = spvec(1)**2 + spvec(2)**2 + spvec(3)**2
      if (rr.gt.0) then
         rsp = sqrt(rr)
         rr = spvec(1)**2 + spvec(2)**2
         if ( rr.ne.0 .or. spvec(3).lt.0) then
           if (rr.eq. 0) then
             cst = - 1
             snt = 0
             csf = 1
             snf = 0
             angks = pi
           else
c            rotation is defined by angles theta and fi
             rr = sqrt(rr)
             cst = spvec(3) / rsp
             snt = rr / rsp
             csf = spvec(1) / rr
             snf = spvec(2) / rr
             angks = acos( cst)
           endif
c          rotate all vectors
           do 120 i = 1, nat
 120       call rotate (rat(1,i), cst, snt, csf, snf)
           call rotate (evec, cst, snt, csf, snf)
           call rotate (xivec, cst, snt, csf, snf)
         endif
      endif

      return
      end

      subroutine rotate (vec, cst, snt, csf, snf)
      implicit double precision (a-h, o-z)
c     rotates vector to a new coordinate system
c     Euler angles: alpha=phi, beta=theta, gamma=0
      dimension vec(3), temp (3)

      temp(1) = vec(1)*cst*csf + vec(2)*cst*snf - vec(3)*snt
      temp(2) = -vec(1)*snf + vec(2)*csf
      temp(3) = vec(1)*csf*snt + vec(2)*snt*snf + vec(3)*cst
      do 10 i = 1,3
  10  vec(i) = temp(i)

      return
      end
       subroutine rdline(jinit, line)
c
c  return next "real" command line from input file(s)
c    -  allows use of "include file" or "load file" for reading
c       from other files, and manages the set of include files
c    -  checks for and ignores comment lines and blank lines.
c    -  opens and closes all input files, including initial file.
c
c   jinit  initialization/clean-up flag     [in]
c   line   next command line to parse   [in/out]
c
c notes:
c   1. to initialize, set jinit<0 and line= main_input_file_name.inp
c      if line=' ', routine will stop program.
c   2. returned line will be sent through triml and untab.
c   3. uses routine iscomm to test if line is a comment line.
c   4. special returned values:
c        'read_line_end'  = done reading all inputs
c        'read_line_error'= an error has occurred. the calling routine
c                        should probably stop
c   5. to clean up all open files, call with jinit=0
c
c matt newville march 1999
       implicit none
       integer mwords, ilen, i, jinit, mfil, nfil
       parameter (mwords=2, mfil=10)
       character*(*) line, stat*8
       character*90  files(mfil), errmsg, words(mwords)
       parameter (stat='old')
       integer   iunit(mfil), istrln, nwords, ierr, iexist
       logical   iscomm, open
       external  istrln, iscomm
       save      files, iunit, nfil
c
c jinit=-1: initialize
       if (jinit.eq.-1) then
          jinit  = 1
          do 10 i = 1, mfil
             iunit(i) = 0
             files(i) = ' '
 10       continue
          nfil     = 1
          files(1) = line
          call triml(files(1))
          call openfl(iunit(1), files(1), stat, iexist, ierr)
          if (iexist .lt. 0) go to 2600
          if (ierr   .lt. 0) go to 2800
c
c  jinit=0:  close all opened files (except unit 5!)
       elseif (jinit.eq.0) then
          jinit = 1
          do 25, i = 1, mfil
             if ((iunit(i).gt.0).and.(iunit(i).ne.5)) then 
                inquire(unit = iunit(i), opened=open)
                if (open) then
                   close(iunit(i))
                   iunit(i) = 0
                   files(i) = ' '
                endif 
             endif 
 25       continue 
          return
       end if
c  read next line from current input file
 100   continue
cc       print*, 'rdline 100: nfil , files(nfil), iunit = ',
cc     $      nfil,files(nfil)(:20), iunit(nfil)
       line   = ' '
       read(iunit(nfil),'(a)', err =1000, end = 500) line
c
c  check if command line is 'include filename'.
c  if so, open that file, and put it in the files stack
       call untab(line)
       call triml(line)
       if (iscomm(line)) go to 100
       nwords = mwords
       words(2) = ' '
       call bwords(line, nwords, words)
       call lower(words(1))
       if (((words(1) .eq. 'include').or.(words(1) .eq. 'load'))
     $      .and. (nwords .gt. 1)) then
          nfil = nfil + 1
          if (nfil .gt. mfil) go to 2000
          call getfln(words(2), files(nfil), ierr)
          if (ierr. ne. 0) go to 2400
c  test for recursion:
          do 400 i = 1, nfil - 1
             if (files(nfil) .eq. files(i)) go to 3000
 400      continue
          call openfl(iunit(nfil), files(nfil), stat, iexist, ierr)
          if (iexist .lt. 0) go to 2600
          if (ierr   .lt. 0) go to 2800
          go to 100
       end if
       return
c
c  end-of-file for command line file: drop nfil by 1,
c  return to get another command line
 500   continue
       inquire(unit = iunit(nfil), opened=open)
       if (open .and. (iunit(nfil) .ne. 5)) then
          close(iunit(nfil))
       end if
       iunit(nfil) = 0
       files(nfil) = ' '
       nfil = nfil - 1
       if (nfil.gt.0) go to 100
       line = 'read_line_end'
       return
c   error messages
 1000  continue
       call wlog(' # read error: general error')
       go to 4500
 2000  continue
       call wlog(' # read error: too many nested "include"s')
       write(errmsg, '(1x,a,i3)') ' # current limit is ', mfil
       ilen  = istrln(errmsg)
       call wlog(errmsg(1:ilen))
       go to 4500
 2400  continue
       call wlog(' # read error: cannot determine file name')
       go to 4500
 2600  continue
       call wlog(' # read error: cannot find file')
       go to 4500
 2800  continue
       call wlog(' # read error: cannot open file')
       go to 4500
 3000  continue
       call wlog(' # read error: recursive use of file')
       go to 4500
 4500  continue
       errmsg = ' # >> file name = '//files(nfil)
       ilen   = istrln(errmsg)
       call wlog(errmsg(1:ilen) )
       line = 'read_line_error'
       return
c end subroutine read_line
       end
       subroutine getfln(strin, filnam, ierr)
c  strip off the matched delimeters from string, as if getting
c  a filename from "filename", etc.
       integer idel, iend, istrln, ierr
       character*(*) strin, filnam, tmp*144, ope*8, clo*8
       data ope, clo /'"{(<''[',  '"})>'']'/
c
       ierr  = 0
       tmp   = strin
       call triml(tmp)
       ilen  = istrln(tmp)
       idel  = index(ope,tmp(1:1))
       if (idel.ne.0) then
          iend = index(tmp(2:), clo(idel:idel) )
          if (iend.le.0) then
             ierr = -1
             iend = ilen 
          end if
          filnam = tmp(2:iend)
       else
          iend = index(tmp,' ') - 1
          if (iend.le.0) iend  = istrln(tmp) 
          filnam = tmp(1:iend)
       end if
       return
c end  subroutine getfln
       end
       subroutine openfl(iunit, file, status, iexist, ierr)
c  
c  open a file, 
c   if unit <= 0, the first unused unit number greater than 7 will 
c                be assigned.
c   if status = 'old', the existence of the file is checked.
c   if the file does not exist iexist is set to -1
c   if the file does exist, iexist = iunit.
c   if any errors are encountered, ierr is set to -1.
c
c   note: iunit, iexist, and ierr may be overwritten by this routine
       character*(*)  file, status, stat*10
       integer        iunit, iexist, ierr
       logical        opend, exist
c
c make sure there is a unit number and file name
       ierr   = -3
       iexist =  -1
       if (file .eq. ' ') return
       iexist = 0
       iunit  = nxtunt(iunit)
c
c if status = 'old', check that the file name exists
       ierr = -2
       stat =  status                          
       call lower(stat)
       if (stat.eq.'old') then
          iexist = -1
          inquire(file=file, exist = exist)
          if (.not.exist) return
          iexist = iunit
       end if
c 
c open the file
       ierr = -1
       open(unit=iunit, file=file, status=status, err=100)
       ierr = 0
 100   continue
       return
c end  subroutine openfl
       end
      subroutine setedg (a2, ihole)
      integer i, ihole
      character*2 a2, edglbl, edglbp
      dimension edglbl(0:29), edglbp(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','R1' /
      data edglbp / '0', '1 ', '2', '3', '4',
     3            '5','6','7','8','9',
     4            '10','11','12','13','14','15','16',
     5            '17','18','19','20','21','22','23',
     6            '24','25','26','27','28','29' /

      ihole  = -1
      do 10 i = 0,29
  10     if (a2 .eq. edglbl(i) .or. a2 .eq. edglbp(i) ) ihole  = i
      if (ihole  .lt. 0) call par_stop('unknown EDGE')

      return
      end
      subroutine wrtall (nabs)
c     writes data stored in common blocks of allinp.h to 
c     all necessary input files for other modules.
c     version 1.0 written by Alexei Ankudinov, March 2001

c     Note: to add input variable one has to add it to the 
c        appropriate common block in allinp.h, properly initialize
c        it in subroutine iniall and modify subroutine wrtall
c        to write it to the appropriate input file.
c        (i.e. one has to make modifications in 3 places)

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
c={../RDINP/allinp.h
c     Common blocks with all input data
c     the common
cc    atoms.dat
      integer  natt
      integer iphatx(nattx)
      double precision  ratx(3,nattx)
      common /geom/ ratx, iphatx, natt
cc    geom.dat
c       integer  nat
c       integer iatph(0:nphx)
c       integer iphat(natx)
c       double precision  rat(3,natx)
c       common /geom/ ratx, iphatx, natt
cc    global.inp
c       configuration average
      integer iphabs
c     global polarization data
      integer  ipol, ispin, le2
      double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
      complex*16 ptz(-1:1, -1:1)
      common /global/ ptz, evec, xivec, spvec, elpty, angks, rclabs, 
     1     ipol, ispin, le2, iphabs
c     c    mod1.inp
      character*80 title(nheadx)
c     integer mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec,
      integer mpot, nph, ntitle, ihole, ipr1, iafolp, iunf,
     1     nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
      integer iz(0:nphx)
      integer lmaxsc(0:nphx)
      real rfms1
      double precision gamach, rgrd, ca1, ecv, totvol
      double precision  xnatph(0:nphx), folp(0:nphx), spinph(0:nphx)
      double precision  xion(0:nphx)
c     for OVERLAP option
      integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
      double precision  rovr(novrx,0:nphx)
      common /mod1/ title, xion, xnatph, spinph, folp, gamach, rgrd,
     1     ca1, ecv, totvol, rovr, rfms1, iz, lmaxsc, mpot, nph, ntitle,
     2     ihole, ipr1, iafolp, nmix,nohole,jumprm, inters,
     3     nscmt, icoul, lfms1, novr, iphovr, nnovr, iunf
c     c    ldos.inp
      integer mldos, lfms2
      double precision emin, emax, eimag, rfms2
      common /mod7/ emin, emax, eimag, rfms2, mldos, lfms2
cc    mod2.inp
c     integer mphase, ipr2, ixc, ixc0, vr0, vi0, ispec, lreal, lfms2
      integer mphase, ipr2, ixc, ixc0, ispec, lreal, l2lp, iPlsmn
      integer lmaxph(0:nphx), iGrid
      character*6  potlbl(0:nphx)
c     double precision rgrd, rfms2, gamach, xkstep, xkmax, vixan
      double precision xkstep, xkmax, vixan, vr0, vi0
      common /mod2/ xkstep, xkmax, vixan, vr0, vi0, 
     &     lmaxph, mphase, ipr2, ixc, ixc0, ispec, lreal, l2lp,
     &     izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis, iPlsmn,
     &     iGrid, potlbl
c     c    mod3.inp
      integer mfms, idwopt, minv
c     integer lmaxph(0:nphx)
c     real rfms2, rprec, rdirec, toler1, toler2
      real rprec, rdirec, toler1, toler2
      double precision   tk, thetad, sig2g
      common /mod3/ tk, thetad, sig2g, rprec, rdirec, toler1,
     1       toler2,  mfms, idwopt, minv
c     c    mod4.inp
      integer  mpath, ms, nncrit, nlegxx, ipr4
c     real critpw, pcritk, pcrith,  rmax, rfms2
      real critpw, pcritk, pcrith,  rmax
      common /mod4/ critpw, pcritk, pcrith,  rmax,
     1       mpath, ms, nncrit, nlegxx, ipr4
c     c    mod5.inp
      integer  mfeff, ipr5, iorder
      logical  wnstar
      double precision critcw
      common /mod5/ critcw, mfeff, ipr5, iorder, wnstar
c     c    mod6.inp
c     integer  mchi, ispec, idwopt, ipr6, mbconv
c     double precision  vrcorr, vicorr, s02, alphat, sig2g
      integer  mchi, ipr6, mbconv, absolu !KJ added absolu 3-06
      double precision  vrcorr, vicorr, s02, alphat, thetae
      common /mod6/ vrcorr, vicorr, s02, alphat, thetae, 
     &     mchi, ipr6, mbconv, absolu   !KJ added absolu 3-06
c     c    so2.inp  
      integer  mso2conv, ipse, ipsk
      double precision wsigk, cen
      character(12) cfname
      common /so2/ wsigk, cen, cfname, mso2conv, ipse, ipsk
      
c     c    eels.inp
c     EELS variables  !KJ 1-06 this section added for ELNES, EXELFS, MAGIC cards
      real*8 ebeam, aconv, acoll, thetax, thetay, emagic
      integer eels, relat, aver, cross, iinput,spcol
      integer nqr,nqf,magic
      integer ipmin,ipmax,ipstep
      common /eelsva/ ebeam,aconv,acoll,thetax,thetay,emagic,magic,
     &     nqr, nqf, aver, cross, relat, iinput, spcol,ipmin, ipmax,
     &     ipstep, eels
c     !KJ end
	
c= ../RDINP/allinp.h}

      if (.not. master) return

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)

cc    atoms.dat to be read by ffsort,
cc    that will write smaller geom.dat file
      open (file='atoms.dat', unit=3, status='unknown',iostat=ios)
        write (3, 35) natt
  35    format ('natx =  ', i7)
        write (3, 10) '    x       y        z       iph  '
        do 40  iat = 1, natt
          write(3,36) ratx(1,iat), ratx(2,iat), ratx(3,iat), iphatx(iat)
  36      format( 3f13.5, i4)
  40    continue
      close(3)

cc    global.inp
      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c       configuration average data
        write (3, 10) ' nabs, iphabs - CFAVERAGE data'
        write (3, 45) nabs, iphabs, rclabs
  45    format ( 2i8, f13.5)
c       global polarization data
        write (3,10) ' ipol, ispin, le2, elpty, angks'
        write (3, 50)  ipol, ispin, le2, elpty, angks
  50    format ( 3i5, 2f12.4)
        write (3, 10) 'evec         xivec        spvec'
        do 60 i = 1,3
          write (3,30) evec(i), xivec(i), spvec(i)
  60    continue
        write (3, 10) ' polarization tensor '
        do 70 i = -1, 1
          write(3,30) dble(ptz(-1,i)), dimag(ptz(-1,i)), dble(ptz(0,i)),
     1                dimag(ptz(0,i)),  dble(ptz(1,i)), dimag(ptz(1,i))
  70    continue
      close(3)
        
cc    mod1.inp
      open (file='mod1.inp', unit=3, status='unknown',iostat=ios)
        write(3,10) 'mpot, nph, ntitle, ihole, ipr1, iafolp, ixc,ispec'
        write(3,20) mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec
        write(3,10) 
     1  'nmix, nohole, jumprm, inters, nscmt, icoul, lfms1, iunf'
        write(3,20)  nmix, nohole, jumprm, inters, nscmt, icoul, lfms1,
     1   iunf
        do 110 ititle = 1, ntitle
  110   write(3,10) title(ititle)
        write(3,10) 'gamach, rgrd, ca1, ecv, totvol, rfms1'
        write(3,30)  gamach, rgrd, ca1, ecv, totvol, rfms1
        write(3,10) ' iz, lmaxsc, xnatph, xion, folp'
  120   format ( 2i5, 4f13.5)
        do 130 ip = 0, nph
  130   write(3,120) iz(ip), lmaxsc(ip), xnatph(ip), xion(ip), folp(ip)
c       for OVERLAP option
        write(3,10) 'OVERLAP option: novr(iph)'
        write(3,20) ( novr(iph), iph=0,nph)
        write(3,10) ' iphovr  nnovr rovr '
  140   format ( 2i5, f13.5)
        do 150 iph = 0, nph
        do 150 iovr = 1, novr(iph)
  150   write(3,140) iphovr(iovr, iph), nnovr(iovr,iph), rovr(iovr,iph)
      close(3)
cc    mod2.inp
      open (file='mod2.inp', unit=3, status='unknown',iostat=ios)
c     Josh - added flag for PLASMON card (iPlsmn = 0, 1, or 2)
!     Josh - added flag for user difined grid (EGRID card).
        write(3,10) 'mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,
     &     iplsmn,igrid'
        write(3,20)  mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,
     &        iPlsmn, iGrid
        write(3,10) 'vr0, vi0'
        write(3,30)  vr0, vi0
        write(3,10) ' lmaxph(0:nph)'
        write(3,20)  (lmaxph(iph),iph=0,nph)
        write(3,10) ' potlbl(iph)'
        write(3,170)  (potlbl(iph),iph=0,nph)
  170   format (13a6)
        write(3,10) 'rgrd, rfms2, gamach, xkstep, xkmax, vixan'
        write(3,30)  rgrd, rfms2, gamach, xkstep, xkmax, vixan
        write(3,30)  (spinph(iph),iph=0,nph)
        write(3,20)  izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis
      close(3)
cc    mod3.inp
      open (file='mod3.inp', unit=3, status='unknown',iostat=ios)
        write(3,10) 'mfms, idwopt, minv'
        write(3,20)  mfms, idwopt, minv
        write(3,10) 'rfms2, rdirec, toler1, toler2'
        write(3,30)  rfms2, rdirec, toler1, toler2
        write(3,10) 'tk, thetad, sig2g'
        write(3,30)  tk, thetad, sig2g
        write(3,10) ' lmaxph(0:nph)'
        write(3,20)  (lmaxph(iph),iph=0,nph)
      close(3)
cc    mod4.inp
      open (file='mod4.inp', unit=3, status='unknown',iostat=ios)
        write(3,10) 'mpath, ms, nncrit, nlegxx, ipr4'
        write(3,20)  mpath, ms, nncrit, nlegxx, ipr4
        write(3,10) 'critpw, pcritk, pcrith,  rmax, rfms2'
        write(3,30)  critpw, pcritk, pcrith,  rmax, rfms2
      close(3)
cc    mod5.inp
      open (file='mod5.inp', unit=3, status='unknown',iostat=ios)
        write(3,10) 'mfeff, ipr5, iorder, critcw, wnstar'
        write(3,180)  mfeff, ipr5, iorder, critcw, wnstar
  180   format ( 2i4, i8, f13.5, L5)
      close(3)
cc    mod6.inp
      open (file='mod6.inp', unit=3, status='unknown',iostat=ios)
        write(3,10) 'mchi, ispec, idwopt, ipr6, mbconv, absolu' !KJ added absolu 3-06
        write(3,20)  mchi, ispec, idwopt, ipr6, mbconv, absolu !KJ added absolu 3-06
        write(3,10) 'vrcorr, vicorr, s02, critcw'
        write(3,30)  vrcorr, vicorr, s02, critcw
        write(3,10) 'tk, thetad, alphat, thetae, sig2g'
        write(3,30)  tk, thetad, alphat, thetae, sig2g
      close(3)
cc    so2.inp - Josh Kas
      open (file='s02.inp', unit=3, status='unknown',iostat=ios)
        write(3,10) 'mso2conv, ipse, ipsk'
        write(3,20)  mso2conv, ipse, ipsk
        write(3,10) 'wsigk, cen'
        write(3,30) wsigk, cen
        write(3,10) 'ispec, ipr6'
        write(3,20)  ispec, ipr6
        write(3,10) 'cfname'
        write(3,10) cfname
      close(3)
      return
      end
c     sub-pro exchange point
!     program ffmod1
      subroutine ffmod1

c     calculate  el. density and potential given atomic positions for
c     cluster atoms or other similar information
c     calculation can vary in complexity: self-consistency (on/off),
c     spin dependency (on/off), etc..
c       coded by a.l. ankudinov 2000, for modular code structure
c       modified by a.l. ankudinov 2001, for new i/o structure

c     INPUT files: mod1.inp, geom.dat
c     OUTPUT file: pot.bin

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
      real*8 wall_start, wall_end

c     use feff8.2 manual to get more information about each CARD
cc    mod1.inp
        character*80 title(nheadx)
        integer mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec,
     1     iunf, nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
        integer iz(0:nphx), lmaxsc(0:nphx)
        real rfms1
        double precision gamach, rgrd, ca1, ecv, totvol
        double precision  xnatph(0:nphx), folp(0:nphx),  xion(0:nphx)
c       CONTROL mpot
c       RGRID  rgrd
c       TITLE title
c        ntitle: number of title lines(default:0)
c        title:  title lines(default:none)
c       PRINT   ipr1:   print option (default:0)
c       EXAFS, XANES, DANES, FPRIME, XES
c        ispec: type of spectroscopy (default:0-EXAFS)
c       NOHOLE: turn on/off core-hole potential
c       HOLE  ihole: index of core-hole orbital
c        gamach: core hole lifetime
c       POTENTIALS card
c        nph  - number of different potential types(default:1)
c        iz - nicleus charge for each potential charge(default:none)
c        lmaxsc - max orb momentum to calculate (default:3)
c        xnatph - relative amount of atoms of each type (default:1)
c       ION card
c        xion - total initial charge for each potential type
c               (iz + el.charge) which might be fractional (default:0)
c       EXCHANGE card: ixc=2 for potential calculation
c       JUMPRM: turn on potential jump removal at mt radius (default:0)
c       AFOLP iafolp: turn on/off automatic overlap of muffintin spheres
c       FOLP  folp: manual setting for overlapping muffin-tin spheres
c       INTERSTITIAL inters (default:0)  totvol (default:0)
c       SCF rfms1 lfms1 nscmt ca1 nmix ecv  icoul 
c       OVERLAP geometry ( rarely used for EXAFS calculations only)
        integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
        double precision  rovr(novrx,0:nphx)

cc    geom.dat
        integer  nat, iatph(0:nphx), iphat(natx)
        double precision  rat(3,natx)
c       ATOM card
c         nat: number of atoms in a clsuter
c         rat: x,y,z coordinates of all atoms
c         iphat: which potential type correspond to each atom
c         iatph: index of representative atom for each potential type

      call par_begin

c     Initialize clock
      call seconds(wall_start)
      wall_comm = 0.0

c     open the log file, unit 11.  See subroutine wlog.
      if (master) then
        open (unit=11, file='log1.dat', status='unknown', iostat=ios)
        call chopen (ios, 'log1.dat', 'feff')
      else
        par_type = 2
      endif


c     INPUT: read data in pot.inp  and geom.dat files
c     and transform it to atomic hartree units
      call reapot (mpot, rgrd, ntitle, title, ipr1, ispec,
     1           nohole, ihole, gamach, nph, iz, lmaxsc, xnatph,
     2           xion, iunf, ixc, jumprm, iafolp, folp, inters, totvol,
     3           rfms1, lfms1, nscmt, ca1, nmix, ecv, icoul,
     4           novr, iphovr, nnovr, rovr,
     5           nat, rat, iphat, iatph)

      if (mpot .eq. 1)  then
         call wlog(' Calculating potentials ...')
         call pot (rgrd, nohole,
     $             inters, totvol, ecv, nscmt, nmix, ntitle, title,
     $             nat, nph, ihole, gamach, iafolp,
     $             ixc, iphat, rat, iatph,
     $             xnatph, novr,
     $             iphovr, nnovr, rovr, folp, xion, iunf, iz, ipr1,
     $             ispec, jumprm,
     $             lmaxsc, icoul, ca1, rfms1, lfms1)
      endif

c     OUTPUT: subroutine pot writes main output file pot.bin
c     with information on potentials, necessary for other modules;
c     additional output files can be obtained using PRINT card

      if (master) close (unit=11)

c--   Time at end of run
      call seconds(wall_end)
      if (master .and. parallel_run) then
	write (6,*) 'total time    ', wall_end - wall_start
	write (6,*) 'communicate time', wall_comm
      endif
      call par_end

c     sub-pro exchange point
!     stop
      return
      end
      subroutine afolp ( nph, nat, iphat, rat, iatph, xnatph,
     1                novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1                edens, edenvl,
     2                dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm, 
     2                ixc, rhoint, vint, rs, xf, xmu, xmunew,
     3                rnrmav, qtotel, inters, totvol)

c     find folp(iph) automatically and recalculates
c     interstitial parameters, rmt, vint, etc.
c     written by ala 11.97
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      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), folpx(0:nphx)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension dmag(251,0:nphx+1)
      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), rmtx(0:nphx)
      dimension rnrm(0:nphx)
      character*512 slog

      do 5 iph=0,nph
         rmtx(iph) = rmt(iph) / folp(iph)
   5  continue

      call wlog(' iph, rnrm(iph)*bohr, rmt(iph)*bohr, folp(iph)')
      if (iafolp.ge.0) then
         do 400  iph = 0, nph
c          old algorithm for automatic overlap
c          folp(iph) = 1 + 0.7*(rnrm(iph)/rmt(iph) - 1)
           folp(iph) = folpx(iph)
           rmt(iph) = folp(iph) * rmtx(iph)

  398      format(i5, 1p, 3e13.5)
           write(slog,398) iph, rnrm(iph)*bohr, rmt(iph)*bohr, folp(iph)
           call wlog(slog)
  400    continue

         idmag = 0
         call istprm (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1               edens, edenvl, idmag,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu, xmunew,
     4               rnrmav, qtotel, inters, totvol)

      endif

      return
      end
      subroutine broydn( iscmt, ca, nph, xnvmu,
     1          ilast, xnatph, rnrm, qnrm, edenvl, rhoval, dq)
c     calculates new density using Broyden algorithm
c     (J.Phys.A, 17,L317(1984))
c     
c      Also handes the charge inside each norman sphere properly.
c     INPUT:
c       ca     - convergence accelerator factor
c       rhoval - new density from integration up to mu
c       edenvl - old valence density
c       qnrm   - the charge inside each norman sphere
c       xnvmu  - valence electron counts in getorb.f
c       also some information from feff.inp file.(nph,etc.)
c     Output:
c       rhoval - new valence density after mixing
c                notice that at input rhoval = density*4*pi*r**2
c       dq     - change of the charge inside each norman sphere
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension ilast(0:nphx),xnatph(0:nphx), xnvmu(0:lx, 0:nphx+1)
      dimension ri05(251)
      dimension rhoval(251,0:nphx+1), edenvl(251,0:nphx)
      dimension dq(0:nphx)
      dimension qnrm(0:nphx), rnrm(0:nphx)

c     work space
      dimension xpc(251)
c     work space for Broyden algorithm
      parameter (nbr=30)
      dimension cmi(nbr,nbr), frho(251,0:nphx,nbr), urho(251,0:nphx,nbr)
      dimension xnorm(nbr), wt(251), rhoold(251,0:nphx)
      save cmi, frho, urho, xnorm, wt, rhoold, ri05

c     make  radial grid with 0.05 step
      dx05=0.05d0
      if(iscmt.eq.1) then
        do 10 i=1,251
           ri05(i) = exp(-8.8+dx05*(i-1))
           wt(i) = ri05(i)**3
  10    continue
      endif

c     record F(\rho_i)
      do 30 iph = 0, nph
      do 30 ir = 1, ilast(iph)
        frho(ir,iph,iscmt)=rhoval(ir,iph)*ri05(ir)-edenvl(ir,iph)*wt(ir)
  30  continue

c     dq here is set to the total number of valence electron for
c     the initial (atomic overlap) density inside corresponding
c     norman sphere, and xnferm is  the total number for the cluster.
      xnferm = 0
      do 330 ip= 0,nph
        dq(ip) = 0
        do 320 il = 0,lx
         dq(ip) = dq(ip) + xnvmu(il, ip)
 320    continue
        xnferm = xnferm + dq(ip)*xnatph(ip)
 330  continue 

      if (iscmt.gt.1) then
c       get normalization factor
        xnorm(iscmt) = 0
        do 510 iph = 0, nph
        do 510 ir = 1,ilast(iph)
          xnorm(iscmt) = xnorm(iscmt) +
     1    (frho(ir,iph,iscmt)-frho(ir,iph,iscmt-1))**2
  510   continue

c       calculate c_m,i
        do 530 j = 2, iscmt
          cmi(iscmt,j) = 0
          do 520 iph = 0, nph
          do 520 ir = 1,ilast(iph)
            cmi(iscmt,j) = cmi(iscmt,j) + frho(ir,iph,iscmt) *
     1      (frho(ir,iph,j)-frho(ir,iph,j-1))
  520     continue
          cmi(iscmt,j) = cmi(iscmt,j)/xnorm(j)
  530   continue

c       calculate U_i - vector of lagrange multipliers
        do 550 iph = 0, nph
        do 550 ir = 1,ilast(iph)
         urho(ir,iph,iscmt)=ca*(frho(ir,iph,iscmt)-frho(ir,iph,iscmt-1))
     1     + (edenvl(ir,iph) - rhoold(ir,iph))*wt(ir)
  550   continue

        do 570 j = 2, iscmt-1
        do 570 iph = 0, nph
        do 570 ir = 1,ilast(iph)
          urho(ir,iph,iscmt)= urho(ir,iph,iscmt) - urho(ir,iph,j) *
     1      (cmi(iscmt,j)-cmi(iscmt-1,j))
  570   continue
      endif

c     construct new density, finally
      do 600 iph = 0, nph
      do 600 ir = 1, ilast(iph)
        rhoold(ir,iph) = edenvl(ir,iph)
        rhoval(ir,iph) = edenvl(ir,iph) + ca*frho(ir,iph,iscmt)/wt(ir)
        do 610 j = 2, iscmt
  610   rhoval(ir,iph)=rhoval(ir,iph)-cmi(iscmt,j)*urho(ir,iph,j)/wt(ir)
  600 continue

c     calculate e charge inside norman sphere
c     dq - extra number of e (charge transfer) 
      x0 = 8.8d0
      dqav=0.0d0
      xnat = 0.d0
      do 700 iph = 0, nph
        jnrm =  (log(rnrm(iph)) + x0) / dx05  +  2
        i0=jnrm+1
        xirf = 2
        do 710 ir = 1, ilast(iph)
           xpc(ir) = rhoval(ir,iph)*ri05(ir)**2
  710   continue
        call somm2 (ri05, xpc, dx05, xirf, rnrm(iph),0,i0)
c       dq is how many new electrons are within norman sphere
        dq(iph) = xirf - qnrm(iph) - dq(iph)
        dqav=dqav+xnatph(iph)*dq(iph)
        xnat = xnat + xnatph(iph)
  700 continue


c     to keep charge neutrality add/subtract part of previous density
      aa = dqav/xnferm
      dqav=dqav/xnat
      do 800 iph = 0, nph
        dq(iph) = dq(iph) - dqav
        qnrm(iph) = qnrm(iph) + dq(iph)
        do 810 ir = 1, ilast(iph)
  810   rhoval(ir,iph) = rhoval(ir,iph) - aa*edenvl(ir,iph)
  800 continue

      return
      end
      subroutine corval ( ecv, xnvmu, eorb, norb, xnval, kappa, rgrd,
     1             nohole, nph, edens, edenvl, vtot, vvalgs,
     1             rmt, rnrm, ixc, rhoint, vint, jumprm,
     2             x0, ri, dx, xion, iunf, iz,
     3             adgc, adpc, dgc, dpc, ihole, lmaxsc)

c     Finds the core-valence separation for the cluster of atoms.
c     written by ala 10 1998

c     Input: necessary atomic data and the muffin-tin potential data
c     Output:
c          xnvmu - number of valence atoms for each channel
c          ecv   - core-valence separation energy
c     Algorithm:
c       definite valence electron - above -20 eV;
c       definite core electrons   - below -70 ev;
c       first find suspicious points in LDOS (central atom only)
c       between -20 and -70, which are written in eldos array
c       After sorting, the lowest valence state is found and
c       all core states above this energy are reassigned to valence.
c       The "ecv" should be between the lowest valence energy and
c       the highest core level. Also it should be far enough 
c       (see variable tol) from both of the above levels and V_int.
c       If fails to find "ecv" for a given core-valence separation,
c       then the highest core level is reassigned to valence and
c       attempt to find "ecv' is repeated.

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     input
      dimension dmagx(nrptx), dmag0(251)
      dimension vtot (251,0:nphx), vvalgs (251,0:nphx)
      dimension xnvmu(0:lx,0:nphx+1), rmt(0:nphx),rnrm(0:nphx)
      dimension ri(nrptx), ri05(251)
      dimension iz(0:nphx), xion(0:nphx),xnval(30,0:nphx)
      dimension norb(0:nphx), kappa(30,0:nphx), iiorb(0:lx,0:nphx)
      dimension eorb(30,0:nphx), eldos(0:lx,0:nphx)
      dimension lmaxsc(0:nphx), ival(0:lx, 0:nphx), ifound(0:lx)
c     input and output
      dimension edens(251,0:nphx), edenvl(251,0:nphx)

c     work space
      dimension dum(nrptx), vtotph(nrptx),vvalph(nrptx)
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16 xrhoce(0:lx)
      complex*16 xrhole(0:lx)
      complex*16 yrhoce(251)
      complex*16 yrhole(251,0:lx)
      complex*16 ph(lx+1)
c     dimension 32 = (0:lx)*(0:nphx)
      dimension en(32)
      integer ll(32), ip(32), icv(32)
      complex*16 emg, eref, eimag
      dimension xp(0:lx), xpeak(0:lx)
c     stuff from feff.f for rdinp, pathfinder and genfmt
c     Following passed to pathfinder, which is single precision.
      character*512 slog
      logical ok

      write (slog,10) 
  10  format('              Core-valence separation ')
      call wlog(slog)

c     initialize staff
      do 15 i= 1,251
        dmag0(i) = 0.d0
  15  ri05(i) = exp (-8.8+0.05*(i-1))
      do 20 iph = 0, nphx
      do 20 il = 0, lx
         eldos(il, iph) = 0
         iiorb(il, iph) = 0
         ival(il, iph) = 0
  20  continue

      tol = 5.0d0/hart
      if (vint - ecv.lt.tol) ecv = vint - tol
      elow = -70.0d0/hart
      ehigh = -20.0d0/hart
      eimag = coni*1.5/hart
c     make energy step about 0.5 eV
      ne = 1 + nint((ehigh-elow)*2*hart)
      de = (ehigh-elow)/(ne-1)

c     find out problematic energies for core-valence separation
      do 100 iph = 0, nph
      do 100 iorb = 1, norb(iph)
        if (eorb(iorb,iph).lt.ehigh-tol.and.eorb(iorb,iph).gt.elow) then
          lll = -kappa(iorb,iph) - 1
          if (lll.lt.0) lll = kappa(iorb,iph)
c        skip in special case for Hf,Lu,Ta; treat f-electrons as valence
c        or as core according to UNFREEZEF
          if((iz(iph).ge.71.and.iz(iph).le.73) .and. lll.eq.3) goto 100
          if(iunf.eq.0 .and. lll.eq.3) goto 100

          eldos(lll,iph) = eorb(iorb,iph)
          ival(lll,iph) = 1
          if (xnval(iorb,iph).lt. 0.1) ival(lll,iph)=-1
          iiorb(lll,iph) = iorb
        endif
  100 continue

      do 500  iph = 0, nph
         call fixvar (rmt(iph),edens(1,iph),vtot(1,iph),dmag0,
     1                vint, rhoint, dx, rgrd, jumprm,
     2                vjump, ri, vtotph, dum, 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                dmag0, vint, rhoint, dx, rgrd , jumprm,
     2                vjump, ri, vvalph, dum, dmagx)
            if (jumprm .gt. 0) jumprm = 1
         endif
         call fixdsx (iph, dx, rgrd , dgc, dpc, dgcn, dpcn)

         jri = (log(rmt(iph)) + x0) / rgrd + 2
         jri1 = jri+1
         eref = vtotph(jri1)
         do 40 i = 1, jri1
  40     vtotph(i) = vtotph(i) - eref
         if (ixc.ge.5) then
           do 50 i = 1, jri1
  50       vvalph(i) = vvalph(i) - eref
         else
           do 60 i = 1, jri1
  60       vvalph(i) = vtotph(i)
         endif
         itmp = 0
         if (iph.eq.0 .and. nohole.lt.0) itmp = ihole

         xx = dimag(eimag)
         nfound = 0
         do 80 il = 0,lx
           xpeak(il) = (2*il+1.d0)/(6*xx*pi)
           xp(il) = 0
           ifound(il) = 1
           if (ival(il,iph).ne.0) ifound(il) = 0
           nfound = nfound + ifound(il)
  80     continue
         if (nfound .eq. lx+1) goto 500

c        start the search for suspicious maxima in LDOS for iph
         ie = 0
  200    ie=ie + 1
            emg = elow + de*(ie-1) + eimag
            call rholie( ri05, nr05, rgrd, x0, ri, emg,
     2           ixc, rmt(iph), rnrm(iph),
     3           vtotph, vvalph, xnval(1,iph), dgcn, dpcn, eref,
     4           adgc(1,1,iph), adpc(1,1,iph), xrhole,
     5           xrhoce, yrhole, yrhoce, ph,
     6           iz(iph), xion(iph), iunf, itmp,lmaxsc(iph))

c           find the suspicious peaks on ldos and correct the energy
            nfound = 0
            do 400 il = 0, lx
               if (ival(il,iph).ne.0 .and. ifound(il).eq.0) then
c                suspicious ldos; find the first peak in ldos that
c                contains more than 1 electron is not found yet
                 xx = dimag(xrhoce(il))
                 if ((ie.eq.ne .or. xx.lt.xp(il)) .and.
     1                xp(il).gt.xpeak(il)) then
                   ifound(il) = 1
                   eldos(il,iph) = elow + de*(ie-2)
c      print*,iph,' approx count is ',xp(il)*pi*dimag(eimag),' in l=',il
                 else
                   xp(il) = xx
                 endif
               endif
               nfound = nfound + ifound(il)
  400       continue
         if (nfound.lt.lx+1 .and. ie.lt.ne) goto 200

         if (nfound.lt.lx+1) then 
            call wlog ('WARNING: fatal error in subroutine corval. Try')
            call wlog ('  to reduce ca1 in SCF card. If does not help,')
            call wlog ('SEND bug report to AUTHORS')
            call par_stop('CORVAL-1')
         endif
  500 continue

c     arrange suspicious levels in order
      ne = 0
      do 600 iph = 0,nph
      do 600  il = 0, lx
         if (eldos(il,iph) .lt. 0) then
            ne = ne + 1
c           find in which position to put the new energy
            inew = ne
            do 580 ie = 1,ne-1
               if (en(ie).gt.eldos(il,iph) .and. inew.eq.ne) inew = ie
  580       continue
            do 590 ie = ne-1,inew, -1
               en(ie+1) = en(ie)
               icv(ie+1) = icv(ie)
               ll(ie+1) = ll(ie)
               ip(ie+1) = ip(ie)
  590       continue
            en(inew) = eldos(il,iph)
            icv(inew) = ival(il,iph)
            ll(inew) = il
            ip(inew) = iph
         endif
  600 continue

c     goto exit if there is no suspicious points
      if (ne.eq.0) goto 999
 
c     find the highest core and lowest valence energies
      ic = 0
      iv = ne + 1
      do 700 ie = 1,ne
         if (icv(ie).eq.-1) then
            ic = ie
         else
            if (ie.lt.iv) iv = ie
         endif
  700 continue

c     change assignment from core to valence, if core state above lowest
c     valence
      do 720 ie=iv+1,ic
        if (icv(ie).lt.0) then
           iph = ip(ie)
           icv(ie) = 1
           ival(ll(ie),iph) = 1
c          update occupation number
           xnvmu(ll(ie), iph) = xnvmu(ll(ie), iph) + 4*ll(ie)+2
c          update valence density
           iorb = iiorb(ll(ie),iph)

           do 710 ir = 1,251
             edenvl(ir,iph) =  edenvl(ir,iph) + 2*(ll(ie)+1)*
     1       (dgc(ir,iorb,iph)**2 + dpc(ir,iorb,iph)**2)/ri05(ir)**2
             if (ll(ie).ne.0) then
               edenvl(ir,iph) =  edenvl(ir,iph) + 2*ll(ie)*
     1         (dgc(ir,iorb-1,iph)**2+dpc(ir,iorb-1,iph)**2)/ri05(ir)**2
             endif
  710      continue
        endif
  720 continue
      ic = iv - 1

c     check if suggested ecv is between core and valence
      ok = .false.
      if (ic.gt. 0) then
        if (iv.le.ne) then
          if (ecv-en(ic).gt.tol .and. en(iv)-ecv.gt.tol) ok = .true.
        else
          if (ecv-en(ic).gt.tol) ok = .true.
        endif
      else
        if (iv.le.ne) then
          if (en(iv)-ecv.gt.tol) ok = .true.
        endif
      endif
      if (ok) goto 999

  800 ecv = vint - tol
      if (iv.le.ne) ecv = min(ecv,en(iv)-tol)
      if (ic.eq.0) goto 899
      if (ecv-en(ic).gt.tol) goto 899

c     need to reassign the last core state to valence
      ic = ic - 1
      iv = iv - 1
      icv(iv) = 1
      ival(ll(iv),ip(iv)) = 1
      xnvmu(ll(iv),ip(iv)) =  xnvmu(ll(iv),ip(iv)) + 4*ll(iv)+2
c     update valence density
      iph = ip(iv)
      iorb = iiorb(ll(iv),iph)
      do 810 ir = 1,251
        edenvl(ir,iph) =  edenvl(ir,iph)+ 2*(ll(iv)+1)*
     1  (dgc(ir,iorb,iph)**2 + dpc(ir,iorb,iph)**2)/ri05(ir)**2
        if (ll(iv).ne.0) then
          edenvl(ir,iph) =  edenvl(ir,iph)+ 2*ll(iv)*
     1    (dgc(ir,iorb-1,iph)**2+dpc(ir,iorb-1,iph)**2)/ri05(ir)**2
        endif
  810 continue
      go to 800

899   continue
c     update the core valence separation in array xnval
c     need to do that for second call of 'corval' and for ixc=5,6
      do 900  ie = iv, ne
         iph = ip(ie)
         lll = ll(ie)
         iorb = iiorb(lll,iph)
         if (xnval(iorb,iph).lt.0.1) then
            xnval(iorb,iph) = 2*lll+2
            if (lll.gt.0) xnval(iorb-1,iph) = 2*lll
         endif
  900 continue

999   continue
      return
      end
      subroutine coulom( icoul, npot, ilast, rhoval, edenvl, edens,
     2     nat, rat, iatph, iphat, rnrm, dq, iz, vclap)
c     searches for fermi level in comlex energy plain and 
c     Output:
c       rhoval - new valence density
c       vclap  - coulomb potential
c       qnrm   - charge inside each norman sphere
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension ilast(0:nphx)
      dimension ri05(251)
      dimension rhoval(251,0:nphx+1), edenvl(251,0:nphx)
      dimension edens(251,0:nphx), dq(0:nphx), iz(0:nphx)
      dimension rat(3,natx), iatph(0:nphx), iphat(natx), rnrm(0:nphx)
      dimension vclap(251,0:nphx)

c     work space
      dimension  drho(251), dvcl(251)
      external dist

c     make  radial grid with 0.05 step
      dx05=0.05d0
      do 10 i=1,251
         ri05(i) = exp(-8.8+dx05*(i-1))
  10  continue

      do 600 ip=0,npot
        do 550 ir=1, ilast(ip)
           drho(ir)= (rhoval(ir,ip)-edenvl(ir,ip))*ri05(ir)**2
  550   continue
        call potslw(dvcl,drho, ri05,dx05, ilast(ip))

        do 560 ir = ilast(ip)+1, 251
           dvcl(ir) = 0.0d0
  560   continue

        if (icoul.eq. 1) then
c         find the change of coulomb potential at norman radius for
c         each type of iph
          jnrm = (log(rnrm(ip)) + 8.8) / 0.05  +  2
          dvnrm = dq(ip) / rnrm(ip)
          iat0 = iatph(ip)
          do 570 iat=1,nat
             if (iat.ne.iat0) then
               rr = dist( rat(1,iat), rat(1,iat0))
               if (rr.lt.rnrm(ip)) rr=rnrm(ip)
               dvnrm = dvnrm + dq(iphat(iat)) / rr
             endif
  570     continue

c         transfer condition to r(jnrm) instead of r_nrm.
          dr = ri05(jnrm) - rnrm(ip)
c         xx = dr/rnrm(ip)
c         correction using linear expansion of drho
c         neglecting terms xx**4 and higher
          bb = (drho(jnrm)-drho(jnrm-1)) / (ri05(jnrm)-ri05(jnrm-1))
c         dvnrm = dvnrm - xx* (dq(ip)/ri05(jnrm) + xx* (drho(jnrm)*
c    1    (rnrm(ip)/ri05(jnrm)-0.5) + xx*(drho(jnrm)-bb*rnrm(ip))/3 ))
          dvnrm = dvnrm - dr / 2 * ( dq(ip) / rnrm(ip)**2 + 
     1       (dq(ip)+drho(jnrm)*dr-bb/2*dr**2) / ri05(jnrm)**2 )


c         dvcl is calculated correct up to constant shift which is
c         fixed by the condition at R_nrm
          dvnrm = dvnrm - dvcl(jnrm)

        else
c         now this is default (icoul=0)
c         then do normalization based on norman picture
c         i.e. total density is approximated by a sum of densities
c          which are zero outside each norman sphere. use this
c         approximation only for the difference between 2 potentials
c         This is needed for infinite solid where the algorithm for
c         icoul=1 is unstable due to long range Coulomb potential
c         probably better fix will be to use Ewald summation to figure
c         out the Madelung constants (icoul=2 optinon to be done later).

          call frnrm (edens(1,ip), iz(ip), rnrm1)
          do 710 i = 1,251
  710     drho(i) = edens(i,ip) - edenvl (i,ip) +rhoval(i,ip)
          call frnrm (drho, iz(ip), rnrm2)
          rmin = min (rnrm1, rnrm2)
          inrm = (log(rmin) + 8.8) / 0.05  +  1
          r0 = ri05(inrm)

          delv = 0.d0
          if (rnrm2.gt.rnrm1) then
            aa = (drho(inrm+1)-drho(inrm)) / (ri05(inrm+1)-ri05(inrm))
            bb = drho(inrm) - aa * ri05(inrm)
            delv = delv - fab (aa, bb, r0, rnrm1, rnrm2)
          else
            aa = (edens(inrm,ip)-edens(inrm+1,ip))
     1           / (ri05(inrm+1)-ri05(inrm))
            bb = - edens(inrm,ip) - aa * ri05(inrm)
            delv = delv - fab (aa, bb, r0, rnrm2, rnrm1)
          endif
          aa = (drho(inrm+1)-drho(inrm)+edens(inrm,ip)-edens(inrm+1,ip))
     1          / (ri05(inrm+1)-ri05(inrm))
          bb = drho(inrm) - edens(inrm,ip) - aa * ri05(inrm)
          delv = delv - fab (aa, bb, r0, r0, rmin)

          dvnrm = delv - dvcl(inrm)
        endif

        do 580 ir=1,ilast(ip)
           vclap(ir,ip) = vclap(ir,ip) + dvcl(ir) + dvnrm 
  580   continue
        do 590 ir=ilast(ip)+1,251
  590   vclap(ir,ip)=0.0d0
  600 continue

      return
      end

      double precision function fab (aa,bb,r0,r1,r2)
c     it is the \int_r1^r2 dr 4\pi\rho(r) r**2 (1/r0 - 1/r)
c     where 4\pi\rho(r) = aa*r + bb
c     you arrive to this integral as a result of norman picture
c     for normalization of coulomb potential just below the rmin
      implicit double precision (a-h, o-z)

      a2 = (r2**2-r1**2)/2.d0
      a3 = (r2**3-r1**3)/3.d0
      a4 = (r2**4-r1**4)/4.d0
      fab = aa*(a4/r0-a3) + bb*(a3/r0-a2)
      return
      end

      subroutine ff2g (gtr, iph, ie, ilast, xrhoce, xrhole, xrhocp,
     1             ee, ep, yrhole, yrhoce,  yrhocp, rhoval, xnmues,
     2             xnatph, xntot, iflr, iflrp, fl, fr, iunf)
      implicit double precision (a-h, o-z)
c     the main output is l-dos in xrhoce, and valence density 
c     of states at distance r
c     in yrhoce, which at the input are only embedded atom quantities

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      complex*16 xrhoce(0:lx,0:nphx), xrhocp(0:lx,0:nphx)
      complex*16 yrhoce(251), yrhocp(251)
      complex*16 xrhole(0:lx)
      complex*16 yrhole(251,0:lx)
      complex gtr(0:lx)
      complex*16 ee, ep, del, der, fl, fr
      complex*16 cchi(0:lx)
      dimension xnmues(0:lx), rhoval(251)

c     chi from fms is contained in gtr
      do 200  j = 0, lx
         cchi(j) =  dble( real( gtr(j) )) + coni* dble(aimag( gtr(j) ))
  200 continue

      do 730 il = 0,lx
        xrhoce(il, iph)=xrhoce(il, iph)+
     1                       cchi(il)*xrhole(il) 
        if (ie.eq.1) xrhocp(il,iph) = xrhoce(il,iph)
  730 continue

      del = ee-ep
      der = del
c     if iflr=1 add/subtract integral from point to real axis
c     factor 2 below comes from spin degeneracy
      if (iflr.eq.1) der = der - coni * 2 * dimag(ee)
      if (iflrp.eq.1) del = del + coni * 2 * dimag(ep)
      do 750 il = 0, lx
        if (il.le.2 .or. iunf.ne.0) then
         fl = fl + 2 * xrhocp(il,iph) * xnatph
         fr = fr + 2 * xrhoce(il,iph) * xnatph
         xnmues(il) = xnmues(il) + 
     1        dimag( xrhoce(il,iph) * der + xrhocp(il,iph) * del )
         xntot = xntot + xnmues(il) * xnatph
        endif
  750 continue

cc    calculate r-dependent l-dos for later use
      do 840 il = 0,lx
      do 840 ir = 1,ilast
       if (il.le.2 .or. iunf.ne.0) then
        yrhoce(ir) = yrhoce(ir) + cchi(il)*yrhole(ir,il)
        if (ie.eq.1) yrhocp(ir) = yrhoce(ir)
       endif
  840 continue

      do 850 ir = 1, ilast
         rhoval(ir) = rhoval(ir) + dimag(yrhoce(ir)*der+yrhocp(ir)*del)
  850 continue

      return
      end
      subroutine frnrm (rho, iz, rnrm)
      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension rho(nrptx)
         dimension xpc(251), ri(251)
c#mn
       external rr

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= (9*rho(1)*rr(1)**3+28*rho(2)*rr(2)**3+23*rho(3)*rr(3)**3)/480
c     add initial point (r=0) correction (see subroutine somm2)
      dpas = 0.05
      d1 = 3.0
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=rr(1)/db
      dd=rr(1)*(1.0+1.0/(dd*(d1+1.0)))/d1
      sum = sum + dd*rho(1)*rr(1)**2 - db*rho(2)*rr(2)**2

      fl = rho(4) *rr(4)**3
      fr = rho(5) *rr(5)**3
      frr = rho(6) *rr(6)**3
      sum = sum + (25*fl + 12 *fr -frr)/480
      do 10  i = 7, nrptx
         fll = fl
         fl = fr
         fr = frr
         frr = rho(i) * rr(i)**3
         sumsav = sum
         sum = sum + (13*(fr+fl) -fll -frr)/480
         if (sum .ge. iz)  then
            inrm = i-2
            x= (iz-sumsav)/(sum-sumsav)
            goto 20
         endif
   10 continue
      call wlog(' FRNRM Could not integrate enough charge to reach' //
     1          ' required z.')
      call par_stop('FRNRM-1')
   20 continue
      rnrm = rr(inrm)*(1 + x*0.05)
     
c     add next order correction ALA 3/97
        dx05 = 0.05
        x0 = 8.8
        jnrm =  (log(rnrm) + x0) / dx05  +  2
        i0=jnrm+1
        xirf = 2
        do 710 ir = 1, jnrm+2
           ri(ir) = rr(ir)
           xpc(ir) = rho(ir)*ri(ir)**2
  710   continue

        call somm2 (ri, xpc, dx05, xirf, rnrm,0,i0)
c       dq is how many new electrons are within norman sphere
        dn1 = xirf-iz
        x2 = x - dn1/((1-x)*xpc(inrm) + x*xpc(inrm+1))
        if (abs(x2-x).gt.0.0001) then
          xirf = 2
          rnrm = rr(inrm)*(1 + x2*0.05)
          call somm2 (ri, xpc, dx05, xirf, rnrm,0,i0)
          dn2 = xirf-iz
c         Newton-Raphson methof to find zeroes
          x = x2 - dn2 * (x2-x)/(dn2-dn1)
        endif
        rnrm = rr(inrm)*(1 + x*0.05)

      return
      end
      subroutine  grids ( ecv, xmu, negx, neg, emg , step, nflrx)
c     makes a grid in complex e-plane for scmt calculation
c     add complications for complex cases later. ala
c     emg is comlex energy in hartrees
      implicit double precision (a-h, o-z)

      complex*16 emg(negx), eim, eimmin
      dimension step(nflrx)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     the choice of e_cv should be automated later
c     all l-dos should be zero at ecv
c     fix it by hand if needed below
c     for some complicated materials may need multiple e_cv
c     it may also depend on core-valence separation

c     eimmin = the lowest im energy to search for fermi level
c     may simulate Fermi distr for occ numbers, thus may want
c     to lower eimmin for low temperatures.
      eimmin = coni*0.05/hart
      neg1 = (nflrx+1)/2
      neg3 = nflrx - 1
      neg2mx = negx-neg1-neg3
c     never do calculations on real axis.
      eim = eimmin*neg1**2
      eim = eimmin 
      de = dimag(eim)/4

      do 10 i =1, neg1
c        step linearly increases as one get farther from real axis
         eim = eimmin *i**2
         emg(i) = ecv +eim
  10  continue
      step(nflrx) = dimag(eim)/4

c     set energy step for integration eim above real axis
      de = dimag(emg(neg1))/4
      neg2= nint((xmu-ecv)/de)
      if (neg2.gt.neg2mx) neg2=neg2mx
      if (neg2.lt.neg1) neg2 = neg1
      de = (xmu-ecv) / neg2
      do 20 i = neg1+1,neg1+neg2
  20  emg(i) = emg(i-1) + de

      neg = neg1 + neg2 + neg3
      do 30 i =1, neg3
c        step linearly increases as one get farther from real axis
         eim = eimmin *(i+1)**2 /4.d0
         if (i.le.nflrx) step(i) = dimag(eim)/4
         emg(neg-i+1) = xmu + eim
  30  continue

      return
      end
      subroutine inipot (dgc, dpc, edenvl, vvalgs, xnmues)
c     initialize values of arrays to zero
      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (zero=0.0d0)

      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension edenvl(251,0:nphx), vvalgs (251,0:nphx)
      dimension xnmues(0:lx,0:nphx)

      do 10 iph  = 0,nphx+1
      do 10 iorb = 1,30
      do 10 i = 1,251
   10    dgc(i,iorb,iph) = zero

      do 20 iph  = 0,nphx+1
      do 20 iorb = 1,30
      do 20 i = 1,251
   20    dpc(i,iorb,iph) = zero

      do 30 iph = 0, nphx
      do 30 i = 1, 251
   30    edenvl(i, iph) = zero

      do 40 iph = 0, nphx
      do 40 i = 1, 251
   40    vvalgs(i, iph) = zero

      do 50 iph = 0, nphx
      do 50 ll = 0, lx
   50    xnmues (ll, iph) = zero

      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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 moveh (nat, iphat, iz, rath)
c    Increase length of bonds with hydrogen atoms
c    Move Hydrogens for potentials. Otherwise MT geometry is screwed up.
      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     input is everything; output is modified  atomic coordinates (rath) 
c     nat is number of atoms in cluster
      dimension iphat(natx),  iz(0:nphx)
      dimension rath(3,natx)

      do 970 iat = 1, nat
        if (iz(iphat(iat)) .eq. 1) then
c         find the nearest atom A, units for rat are bohr.
          rah = 100
          ia = 0
          do i = 1,nat
              rattmp = dist(rath(1,iat), rath(1,i) )
              if (rattmp.lt. rah .and. i.ne. iat) then
                 ia = i
                 rah = rattmp
              endif
          enddo
          if (iz(iphat(ia)).eq.1) goto 970

c         set max distance as function of rah ( set by calculations
c         for H2O and GeH4)
          ratmax = rah + 4.d0/rah**2 

c        find shortest AB bond (neither A or B are H)
          rab = 10
          ib = 0
          do i = 1,nat
              rattmp = dist(rath(1,ia), rath(1,i))
              if (i.ne.ia .and. iz(iphat(i)).ne.1 .and.
     1            rab.gt.rattmp) then
                 rab = rattmp
                 ib = i
              endif
          enddo
          if (rab.lt.ratmax) ratmax = 0.95*rab + 0.05*rah
          if (rah .gt. ratmax) goto 970

c         increase rah to ratmax and check that A is still closest to H
          ratmin = rah
  960     do i = 1,3
           rath(i,iat)=rath(i,ia)+ratmax/ratmin*(rath(i,iat)-rath(i,ia))
          enddo
          rbh = 10
          ib = 0
          do i = 1,nat
              rattmp = dist(rath(1,iat), rath(1,i))
              if (i.ne.iat .and. rbh.gt.rattmp) then
                 rbh = rattmp
                 ib = i
              endif
          enddo

          if (ia.ne.ib) then
             rab = dist(rath(1,ia),rath(1,ib))
             rattmp = ratmax*rab**2/(ratmax**2+rab**2-rbh**2)
             ratmin = ratmax
             ratmax = 0.95*rattmp +0.05*rah
             goto 960
          endif
        endif
  970 continue

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

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)
      dimension iz(0:nphx)
      dimension rho(251,0:nphx+1), dmag(251,0:nphx+1)
      dimension vcoul(251,0:nphx+1), rhoval(251,0:nphx+1)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension rnrm(0:nphx)
c#mn
       external dist

c     start with free atom values for current atom
      do 100  i = 1, 251
         vclap(i,iph) = vcoul(i,iph)
         edens(i,iph) = rho  (i,iph)
         
cc       investigate effect of central atom spin only
c        if (iph.ge.1) dmag(i,iph) = 0.0

         edenvl(i,iph) = rhoval  (i,iph)
  100 continue

      if (novr(iph) .gt. 0)  then
         do 104  iovr = 1, novr(iph)
            rnn  = rovr(iovr,iph)
            ann  = nnovr(iovr,iph)
            infr = iphovr(iovr,iph)
            call sumax (rnn, ann, vcoul(1,infr), vclap(1,iph))
            call sumax (rnn, ann, rho  (1,infr), edens(1,iph))
            call sumax (rnn, ann, rho  (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 = iphat(inat)
            call sumax (rnn, one, vcoul(1,infr), vclap(1,iph))
            call sumax (rnn, one, rho  (1,infr), edens(1,iph))
            call sumax (rnn, one, rho  (1,infr), edenvl(1,iph))
cala        call sumax (rnn, one, rhoval(1,infr), edenvl(1,iph))
  110       continue
      endif

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

c     remember ratio dmag/edens , not dmag itself
      do 200 i = 1,251
        if (edens(i,iph) .gt. 0.d0) then
          dmag(i,iph) = dmag(i,iph) / edens(i,iph)
        else
          dmag(i,iph) = 0.d0
        endif
 200  continue

      return
      end
      subroutine reapot (mpot, rgrd, ntitle, title, ipr1, ispec,
     1           nohole, ihole, gamach, nph, iz, lmaxsc, xnatph,
     2           xion, iunf, ixc, jumprm, iafolp, folp, inters, totvol,
     3           rfms1, lfms1, nscmt, ca1, nmix, ecv, icoul,
     4           novr, iphovr, nnovr, rovr,
     5           nat, rat, iphat, iatph)
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

cc    geom.dat
        integer  nat, iatph(0:nphx), iphat(natx)
        double precision  rat(3,natx)
cc    mod1.inp
        character*80 title(nheadx), head(nheadx)
        integer lhead(nheadx)
        integer mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec,
     1     iunf, nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
        integer iz(0:nphx), lmaxsc(0:nphx)
        real rfms1
        double precision gamach, rgrd, ca1, ecv, totvol
        double precision  xnatph(0:nphx), folp(0:nphx), xion(0:nphx)
c       for OVERLAP option
        integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
        double precision  rovr(novrx,0:nphx)

c     Local stuff
      character*512 slog
      character*32 s1, s2, s3

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)


c     Read  geom.dat file
      open (file='geom.dat', unit=3, status='old',iostat=ios)
c       read header from geom.dat 
        nhead = nheadx
        call rdhead (3, nhead, head, lhead)
        nat = 0
        nph = 0
        do 40 iph = 0, nphx
  40    iatph(iph) = 0
  50    continue
           if (nat .gt. natx)  then
              write(slog,55) ' nat, natx ', nat, natx
              call wlog(slog)
  55          format(a, 2i10)
              stop 'Bad input'
           endif
           nat = nat+1
           read(3,*,end=60)  idum, (rat(j,nat),j=1,3), iphat(nat), i1b
           if (iphat(nat).gt.nph) nph = iphat(nat)
           if ( iatph(iphat(nat)).eq.0) iatph(iphat(nat)) = nat
        goto 50
  60    continue
        nat = nat-1
      close(3)

c     read mod1.inp
      open (file='mod1.inp', unit=3, status='old',iostat=ios)
      call chopen (ios, 'mod1.inp', 'reapot')
        read (3,10) slog
        read (3,20) mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec
        read (3,10) slog
        read (3,20)  nmix, nohole, jumprm, inters, nscmt, icoul, lfms1,
     1     iunf
        do 110 ititle = 1, ntitle
  110   read (3,10) title(ititle)
        read (3,10) slog
        read (3,30)  gamach, rgrd, ca1, ecv, totvol, rfms1
        read (3,10) slog
  120   format ( 2i5, 4f13.5)
        do 130 ip = 0, nph
  130   read (3,120) iz(ip), lmaxsc(ip), xnatph(ip), xion(ip), folp(ip)
c       for OVERLAP option
        read (3,10) slog
        read (3,20) ( novr(iph), iph=0,nph)
        read (3,10) slog
  140   format ( 2i5, f13.5)
        do 150 iph = 0, nph
        do 150 iovr = 1, novr(iph)
  150   read (3,140) iphovr(iovr, iph), nnovr(iovr,iph), rovr(iovr,iph)
      close(3)

c     transform to code units (bohrs and hartrees - atomic unuts)
      rfms1 = rfms1 / bohr
      gamach = gamach / hart
      ecv   = ecv   / hart
      totvol = totvol / bohr**3
      do 210 iat = 1, nat
      do 210 i = 1,3
        rat(i,iat) = rat (i, iat) / bohr
  210 continue
      do 220 iph = 0, nph
      do 220 iovr = 1, novr(iph)
         rovr(iovr,iph) = rovr(iovr,iph) / bohr
  220 continue

c     add lines to the title
      if (mpot.eq.1) then
         ntitle = ntitle + 1
         if (nat.gt.1) then
           if (rfms1.lt.0) rfms1 = 0
           if (nscmt.gt.0) then
             write(s1, 230) nscmt, rfms1*bohr, lfms1
  230        format(' POT  SCF', i4, f8.4, i4)
           else
             write(s1, 235) 
  235        format(' POT  Non-SCF' )
           endif
         else
           write(s1, 240) 
  240      format(' POT  used OVERLAP geometry,')
         endif
         if (nohole.eq.0) then
           write(s2, 310) 
  310      format(', NO core-hole,')
         elseif (nohole.eq.2) then
           write(s2, 315) 
  315      format(', screened core-hole,')
         else
           write(s2, 320) 
  320      format(', core-hole,')
         endif
         if (iafolp.lt.0) then
           write(s3, 330) folp(0)
  330      format(' FOLP (folp(0)=', f6.3, ')' )
         else
           write(s3, 340) folp(0)
  340      format(' AFOLP (folp(0)=', f6.3, ')' )
         endif
c        concatenate 3 strings into 1
         title(ntitle) = ' '
         ilen = istrln(s1)
         istart = 1
         iend = ilen
         title(ntitle)(istart:iend) = s1(1:ilen)
         ilen = istrln(s2)
         istart = iend + 1
         iend = iend + ilen
         title(ntitle)(istart:iend) = s2(1:ilen)
         ilen = istrln(s3)
         istart = iend + 1
         iend = iend + ilen
         title(ntitle)(istart:iend) = s3(1:ilen)
      endif

      return
      end
      subroutine rholie ( ri05, nr05, dx, x0, ri, em,
     2                  ixc, rmt, rnrm,
     3                  vtot, vvalgs, xnval, dgcn, dpcn, eref,
     4                  adgc, adpc, xrhole, xrhoce, yrhole, yrhoce, ph,
     i                  iz, xion, iunf, ihole, lmaxsc)

      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,  complex energy grid
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     rmt          r muffin tin
c     rnrm         r norman
c     vtot(nr)     total potential, including gsxc, final state
c     dgcn(dpcn)   large (small) dirac components for central atom
c     adgc(adpc)   their development coefficients
c
c     OUTPUT
c     xrhole(0:lx)  integral over r of density function
c     xrhoce(0:lx)  the same integral for embedded atom only
c     yrhole(251,0:lx)   density function
c     yrhoce(251)        density function for embedded atom


c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     max number allowed in xsect r-grid
      parameter (nrx = nrptx)

c     output
      complex*16  xrhole(0:lx)
      complex*16  xrhoce(0:lx)
      complex*16  yrhole(251,0:lx), yrhoce(251)
      complex*16  ph(lx+1)

      dimension ri(nrptx), ri05(251)
      dimension  vtot(nrptx), vvalgs(nrptx)
      complex*16 vtotc(nrptx), vvalc(nrptx)
      dimension xnval(30), dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30)

c     energy grid in complex e-plane
      complex*16 em, eref

c     work space for dfovrg: regular and irregular solutions
      complex*16 pr(nrx), qr(nrx), pn(nrx), qn(nrx)

      complex*16  p2, xkmt, ck, xck
      complex*16  pu, qu
      complex*16  xfnorm, xirf
      complex*16  temp,  phx, tempc

      complex*16 jl,jlp1,nl,nlp1
      complex*16  xpc(nrx)

c     initialize
      lmax=lmaxsc
      if (lmax.gt.lx) lmax = lx
      if (iz.le.4) lmax=2
      if (iz.le.2) lmax=1
      do 20 i = 1, nrptx
         vtotc(i)=vtot(i)
         vvalc(i)= vvalgs(i)
  20  continue
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
      if (jri .gt. nrptx)  call par_stop('jri .gt. nrptx in phase')
      inrm = (log(rnrm) + x0) / dx  +  1
      jnrm = inrm+1

c     set limits for tabulations
      nr05= (log(rnrm) + x0) / 0.05d0 + 5
      if (nr05.gt.251) nr05 = 251
c     ilast is the last integration point
c     it is larger than jnrm for better interpolations
      ilast = nint( (nr05-1) *0.05d0 / dx ) + 1
      if (ilast.gt.nrptx) ilast=nrptx

      do 10 lll = 0, lx
      do 10 j = 1, 251
         yrhole(j,lll) = 0
  10  continue
      do 30 j = 1, 251
  30  yrhoce(j) = 0

c     p2 is 0.5*(complex momentum)**2 referenced to energy dep xc
c     need hartree units for dfovrg
      p2 = em - eref
      if (mod(ixc,10) .lt. 5) then
        ncycle = 0
      else
        ncycle = 3
      endif
      ck = sqrt(2*p2 + (p2*alphfs)**2)
      xkmt = rmt * ck

      do 200 lll=0,lx
        if (lll.gt.lmax) then
           ph(lll+1) = 0
           xrhoce(lll) = 0
           xrhole(lll) = 0
           do 110 i = 1,251
  110      yrhole(i,lll) = 0
           goto 200
        endif

c       may want to use ihole=0 for new screening. 
c       don't want ro use it now
c       ihole = 0
        ikap = -1-lll
        irr = -1
        ic3 = 1
        if (lll.eq.0) ic3 = 0
        call dfovrg ( ncycle, ikap, rmt, ilast, jri, p2, dx,
     $                ri, vtotc, vvalc, dgcn, dpcn, adgc, adpc,
     $                xnval, pu, qu, pn, qn,
     $                iz, ihole, xion, iunf, irr, ic3)
        call exjlnl (xkmt, lll, jl, nl)
        call exjlnl (xkmt, lll+1, jlp1, nlp1)
        call phamp (rmt, pu, qu, ck,  jl, nl, jlp1, nlp1, ikap,
     1                  phx, temp)
        ph(lll+1)=phx

c     Normalize final state  at rmt to
c     rmt*(jl*cos(delta) - nl*sin(delta))
        xfnorm = 1 / temp
c     normalize regular solution
        do 133  i = 1,ilast
          pr(i)=pn(i)*xfnorm
          qr(i)=qn(i)*xfnorm
  133   continue

c      find irregular solution
        irr = 1
        pu = ck*alphfs
        pu = - pu/(1+sqrt(1+pu**2))
c       set pu, qu - initial condition for irregular solution at ilast
c       qu=(nlp1*cos(phx)+jlp1*sin(phx))*pu *rmt
c       pu = (nl*cos(phx)+jl*sin(phx)) *rmt
        qu=(nlp1*cos(phx)+jlp1*sin(phx))*pu *rmt 
        pu = (nl*cos(phx)+jl*sin(phx)) *rmt 

        call dfovrg (ncycle, ikap, rmt, ilast, jri, p2, dx,
     1              ri, vtotc,vvalc, dgcn, dpcn, adgc, adpc,
     1              xnval, pu, qu, pn, qn,
     1              iz, ihole, xion, iunf, irr, ic3)
cc      set N- irregular solution , which is outside
cc      N=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1
cc      N = i*R - H*exp(i*ph0)
        temp = exp(coni*phx)
c       calculate wronskian
        qu = 2 * alpinv * temp * ( pn(jri)*qr(jri) - pr(jri)*qn(jri) )
        qu = 1 /qu / ck
c       qu should be close to 1
        do i = 1, ilast
          pn(i) = coni * pr(i) - temp * pn(i)*qu
          qn(i) = coni * qr(i) - temp * qn(i)*qu
        enddo

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    combine all constant factors to temp
c    add relativistic correction to normalization and factor 2*lll+1
        pu = ck*alphfs
        pu = - pu/(1+sqrt(1+pu**2))
        temp = (2*lll+1.0d0)/(1+pu**2) /pi *ck * 2
c    also scale by appropriate step in complex energy
        do 190  i = 1, ilast
          xpc(i) = pr(i) * pr(i) + qr(i) * qr(i) 
 190    continue
          
        do 191 ir=1,nr05
           call terpc(ri, xpc, ilast, 3, ri05(ir), tempc)
           tempc = tempc * temp
           yrhole(ir,lll)= tempc
 191    continue

        xirf = lll*2 + 2
c       i0 should be less or equal to  ilast
        i0=jnrm+1
        call csomm2 (ri, xpc, dx, xirf, rnrm, i0)
c       print out xirf for Bruce
        xrhole(lll) = xirf*temp

c     only central atom contribution needs irregular solution
        do 195  i = 1, ilast
          xpc(i) = pn(i)*pr(i)-coni*pr(i)*pr(i)
     1           + qn(i)*qr(i)-coni*qr(i)*qr(i)
c         yrhoce(i)=yrhoce(i) - temp*xpc(i)
 195    continue
        do 196 ir=1,nr05
           call terpc(ri, xpc, ilast, 3, ri05(ir), tempc)
           yrhoce(ir)=yrhoce(ir) - temp*tempc
 196    continue

        xirf =  1
        call csomm2 (ri, xpc, dx, xirf, rnrm, i0)
        xrhoce(lll) =  - xirf* temp
 200  continue 

      return
      end
      subroutine scmt ( iscmt, ecv, nph, nat, vclap,
     2                edens, edenvl, vtot, vvalgs, rmt, rnrm,qnrm,
     2                ixc, rhoint, vint, xmu, jumprm,
     3                xnferm, xnvmu, xnval,
     4                x0, ri, dx, xnatph, xion, iunf, iz,
     5                adgc, adpc, dgc,dpc, ihole,
     7                rat,iatph,iphat, lmaxsc, rhoval, xnmues, ok,
     8                rgrd, nohole, nscmt, icoul, ca1, rfms1, lfms1)

c     Finds new Fermi level (xmu), electron counts (qnrm) 
c     and new valence densities (rhoval).

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     input
      dimension dmagx(nrptx), dmag0(251)
      dimension vclap(251,0:nphx)
      dimension vtot (251,0:nphx), vvalgs (251,0:nphx)
      dimension xnvmu(0:lx,0:nphx+1), rmt(0:nphx),rnrm(0:nphx)
      dimension xnval (30,0:nphx)
      dimension qnrm(0:nphx), dq(0:nphx)
      dimension ri(nrptx), ri05(251), nr05(0:nphx)
      dimension xnatph(0:nphx), iz(0:nphx), xion(0:nphx)
      dimension rat(3,natx),iatph(0:nphx),iphat(natx), lmaxsc(0:nphx)
      real  rfms1
c     input and output
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension rhoval(251,0:nphx+1)

c     work space
      dimension xnmues(0:lx, 0:nphx)
      complex gtr(0:lx, 0:nphx)
      dimension dum(nrptx), vtotph(nrptx),vvalph(nrptx)
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16 xrhoce(0:lx,0:nphx), xrhocp(0:lx,0:nphx)
      complex*16 xrhole(0:lx,0:nphx)
      complex*16 yrhoce(251,0:nphx), yrhocp(251,0:nphx)
      complex*16 yrhole(251,0:lx,0:nphx)
      complex*16 ph(lx+1, 0:nphx)
      integer iph
c     complex energy grid emg is decomposed into em and eref
      parameter (negx = 80)
      complex*16 emg(negx), em, eref, ee, ep, fl, fr, fxa
c     nflrx should be odd and defines the max of Im energy for
c     the countour 
      parameter (nflrx = 17)
      dimension step(nflrx)
c     stuff from feff.f for rdinp, pathfinder and genfmt
      logical wnstar, upok, ok
c     Following passed to pathfinder, which is single precision.
      character*512 slog
      integer ient
      data ient /0/

c     save staff from rdinp, so no need to call it again
      save   ri05, ient

      ient = ient + 1
      if (ient.eq.1) then
         do 15 i= 1,251
  15     ri05(i) = exp (-8.8+0.05*(i-1))
      endif

      write (slog,10) iscmt, nscmt
  10  format('              SCF ITERATION NUMBER',i3,'  OUT OF',i3)
      call wlog(slog)

      call wlog (' Calculating energy and space dependent l-DOS.')
      call wlog (' It takes time ...')

c     initialize new valence density
      do 16 iph=0,nphx
      do 16 ir=1,251
  16  rhoval(ir,iph) = 0

c     polarization average in scmt and ldos

      call grids (ecv, xmu, negx, neg, emg, step, nflrx)

c     ie - is number of energy points calculated
      ie = 0
      ee = emg(1)
      ep = dble(ee)
      do 22 iph=0,nphx
      do 22 il=0,lx
        xrhoce(il,iph) = 0
        xnmues(il,iph) = 0
  22  continue
      do 23 iph=0,nphx
      do 23  ir = 1,251
  23  yrhoce(ir,iph) = 0
      iflr = nflrx
      iflrp = nflrx

c     Start the cycle over energy points (ie)
  25  continue
      ie = ie + 1

      do 29 iph = 0,nph
        do 860 il = 0,lx
  860     xrhocp(il,iph) = xrhoce(il,iph)
        do 870 i = 1,251
  870     yrhocp(i,iph) = yrhoce(i,iph)
  29  continue

      if (ie.eq.1 .or. mod(ie,20).eq.0) then
         write(slog,30) ie, dble(ee)*hart
   30    format('     point # ', i3, '  energy = ', f7.3)
         call wlog(slog)
      endif

      do 100  iph = 0, nph

         do 35 i=1, 251
  35     dmag0(i) = 0.d0
cc       use spin-unpolarized case to get SCF. set dmagx to zero
cc       may want to replace dmag0 with dmag(1,iph) for spin-dependent
cc       extension of SCF procedure.
         call fixvar (rmt(iph),edens(1,iph),vtot(1,iph),dmag0,
     1                vint, rhoint, dx, rgrd, jumprm,
     2                vjump, ri, vtotph, dum, 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                dmag0, vint, rhoint, dx, rgrd , jumprm,
     2                vjump, ri, vvalph, dum, dmagx)
            if (jumprm .gt. 0) jumprm = 1
         endif

         call fixdsx (iph, dx, rgrd , dgc, dpc, dgcn, dpcn)
        jri = (log(rmt(iph)) + x0) / rgrd + 2
        jri1 = jri+1
        eref = vtotph(jri1)
        do 40 i = 1, jri1
  40    vtotph(i) = vtotph(i) - eref
        if (ixc.ge.5) then
           do 50 i = 1, jri1
  50       vvalph(i) = vvalph(i) - eref
        else
           do 60 i = 1, jri1
  60       vvalph(i) = vtotph(i)
        endif

         itmp = 0
         if (iph.eq.0 .and. nohole.lt.0) itmp = ihole
         call rholie( ri05, nr05(iph), rgrd, x0, ri, ee,
     2           ixc, rmt(iph), rnrm(iph),
     3           vtotph, vvalph, xnval(1,iph), dgcn, dpcn, eref,
     4           adgc(1,1,iph), adpc(1,1,iph), xrhole(0,iph),
     5          xrhoce(0,iph),yrhole(1,0,iph),yrhoce(1,iph),ph(1,iph),
     6           iz(iph), xion(iph), iunf, itmp,lmaxsc(iph))
  100 continue

c     Write out phases for fmsie
c     transform neg,emg to em,ne,eref first
       em= dble(ee)
       eref=dble(eref)-coni*dimag(ee)

cc    call fms for a cluster around central atom
       do 195 iph0 = 0,nph
       do 195 il = 0, lx
  195  gtr(il,iph0) = 0
      if (rfms1 .gt. 0) then
        if (lfms1 .ne. 0) then
          iph0 = 0
          call fmsie( iph0, nph, lmaxsc, ie,  em, eref, ph, iz,
     1                rfms1, lfms1, nat, iphat, rat, gtr)
        else
          do 190 iph0 = 0, nph 
  190     call fmsie( iph0, nph, lmaxsc, ie, em, eref, ph, iz,
     1                rfms1, lfms1, nat, iphat, rat, gtr)
        endif
      endif

      xntot = 0
      fl = 0
      fr = 0
      do 300 iph = 0,nph
c       calculate density and integrated number of electrons in each
c       channel for each type of atoms density, etc., find xntot. 
        call ff2g (gtr(0,iph), iph, ie, nr05(iph), xrhoce, 
     1     xrhole(0,iph), xrhocp, ee, ep, 
     2     yrhole(1,0,iph), yrhoce(1,iph), yrhocp(1,iph), rhoval(1,iph),
     3     xnmues(0,iph), xnatph(iph), xntot, iflr, iflrp, fl, fr, iunf)
  300 continue

      if (ie.ne.1) xndifp = xndif
      xndif = xntot - xnferm

c     decide on next energy point; there are nflrx floors, defined
c     by the magnitude of Im part. Each floor has it's height and
c     horizontal step to search for Fermi level associated with it.
c     The driver below will decide whether to go left or right on
c     the current floor, go one floor up or down.

      if ((ie.lt.neg .and. ient.gt.1) .or. 
     1    (ient.eq.1.and.ie.lt.nflrx)) then
         ep = ee
         ee = emg(ie+1)
         if (ie.eq.neg-1) then
c          reset iflr variables
           iflrp = 2
           iflr  = 1
         endif
         goto 25
      elseif (ient.eq.1 .and. ie.eq.nflrx) then
         upok = .false.
         idir = 1
         if (xntot.gt. xnferm) idir = -1
         ep = ee
         ee = ee + idir * step(iflr)
         goto 25
      elseif (ient.gt.1 .and. ie.eq.neg) then
         upok = .true.
         iflrp = 1
         iflr  = 1
         idir = -1
         if (xntot.lt. xnferm) idir = 1
         ep = ee
         ee = ee + idir * step(iflr)
         goto 25
      else
c       check if the fermi level is found
        if (iflrp.eq.1 .and. iflr.eq.1 .and.
     1                xndifp*xndif .le. 0.e0) then
c          Fermi level is found ; do not goto 25
           if (xndif.eq.0) then
              xmunew = dble(ee)
              a=0
           else
              a = xndif/(xndif-xndifp)
              do 220 i = 1,4
                fxa = a*fl + (1-a)*fr
                bb = dimag((ep-ee)*(fr+fxa)/2 + coni*dimag(ee)*(fr-fl))
                xndif1 = xndif + a * bb
                a = a - xndif1 / bb
  220         continue
              xmunew = dble((1-a)*ee+a*ep)
           endif

c          add end cap corrections to the configuration and density
c          factor 2 for spin degeneracy
           do 250 iph = 0,nph
              do 230 il = 0,lx
               if (il.le.2 .or. iunf.ne.0) then
                fl = xrhocp(il,iph) * 2
                fr = xrhoce(il,iph) * 2
                fxa = a*fl + (1-a)*fr
                bb = dimag((ep-ee)*(fr+fxa)/2 + coni*dimag(ee)*(fr-fl))
                xnmues(il,iph) = xnmues(il,iph) + a * bb
               endif
  230         continue
              do 240 ir = 1,nr05(iph)
                fl = yrhocp(ir,iph) * 2
                fr = yrhoce(ir,iph) * 2
                fxa = a*fl + (1-a)*fr
                bb = dimag((ep-ee)*(fr+fxa)/2 + coni*dimag(ee)*(fr-fl))
                rhoval(ir,iph) = rhoval(ir,iph) + a * bb
  240         continue
  250      continue
        else
c          continue search ; goto 25 eventually
           if (iflr.eq.iflrp) then
c            previous step was gorizontal
             if (xndifp*xndif.le.0) then
c               need to step down
                upok =.false.
                iflrp = iflr
                iflr = iflr - 1
                ep = ee
                ee = dble(ee) + coni*4*step(iflr)
             elseif (abs(xndif).gt.10.d0*abs(xndif-xndifp)
     1          .and. upok) then
c               need to go up one floor since too far from fermi level
                iflrp = iflr
                if (iflr.lt.nflrx) then
                  iflr = iflr+1
                  ep = ee
                  ee = dble(ee) +  coni*4*step(iflr)
                else
                  ep = ee
                  ee = ee + idir* step(iflr)
                endif
             else
c               keep the same floor and direction
                ep = ee
                ee = ee + idir* step(iflr)
             endif
           else
c            previous step was up or down (vertical)
c            check the direction of search
             idir = -1
             if (xndif.lt.0) idir = 1
             iflrp = iflr
             ep = ee
             ee = ee + idir* step(iflr)
           endif
           goto 25
        endif
      endif
c     END of the loop over energy in comlex plane.
c     new fermi level and densities are calculated.

c     report configuration; repeat iteration if found bad counts.
      ok = .true.
      call wlog('  Electronic configuration')
      call wlog('   iph    il      N_el')
 310  format (2i6, f9.3)
      do 320 ip= 0,nph
      do 320 il = 0,lx
         write (slog,310) ip,il,xnmues(il,ip)
         call wlog(slog)
c        check that occupation numbers are consistent with those
c        set in getorb.f
         diff = abs(xnmues(il,ip) - xnvmu(il,ip))
         if (diff.gt.13.1 .or. (il.eq.2 .and. diff.gt. 9.1) .or.
     1   (il.eq.1 .and. diff.gt.5.1) .or.
     2   (il.eq.0 .and. diff.gt.1.95)) then
            call wlog (' Found bad counts.')
            write (slog,311) xnvmu(il,ip)
  311       format('  Occupation number in getorb is ', f9.3)
            call wlog(slog)
            call wlog ('  Will repeat this iteration ')
c            if (ient.gt.1) ok = .false.
         endif
 320  continue

c     if (.not. ok) then will restart SCF loop 
      if (ok) then
         xmu = xmunew
c        find rhoval via Broyden algorithm
         call broydn( iscmt, ca1, nph, xnvmu,
     1         nr05 , xnatph, rnrm, qnrm, edenvl, rhoval, dq)

c        calculate new vclap - overlap coulomb potential
         call coulom (icoul, nph, nr05 , rhoval, edenvl, edens,
     2     nat, rat, iatph, iphat, rnrm, dq, iz, vclap)

c       update array edens
        do 350 ip=0,nph
           do 330 ir=1,nr05 (ip)
             edens(ir,ip)=edens(ir,ip)-edenvl(ir,ip)+rhoval(ir,ip)
  330      continue
           do 340 ir=nr05 (ip)+1,251
             edens(ir,ip)=0.0d0
             edenvl(ir,ip)=0.0d0
  340      continue
  350   continue
      endif

      return
      end
c SUBROUTINE SUMAX (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:  
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 (rn, ann, aa2, aasum)
      implicit double precision (a-h, o-z)
      parameter (nptx=250)
      dimension aa2(nptx), aasum(nptx)
      dimension stor(nptx)
c#mn
       external ii, xx

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
      subroutine wpot (nph, edens, imt, inrm,
     1                 rho, vclap, vcoul, vtot, ntitle, title)

c     Writes potentials to file name POTxx.DAT for each unique pot.

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension rho(251,0:nphx+1)
      dimension vcoul(251,0:nphx+1)
      dimension edens(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension vtot (251,0:nphx)
      dimension imt(0:nphx)
      dimension inrm(0:nphx)
      character*80 title(ntitle)

      character*30 fname
c#mn
       external rr

c     note units --
c     potentials in hartrees, so that v * 27.2 -> eV
c     density in #/(bohr)**3, so rho * e / (.529)**3 -> e/(Ang)**3

      do 180  iph = 0, nph
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, ntitle, title)
         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,*) ' iph ', iph
         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,iph), rho(i,iph)/(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 wrpot ( nph, ntitle, title, rnrmav, xmu, vint, rhoint,
     1                  emu, s02, erelax, wp, ecv,rs,xf, qtotel, 
     2                  imt, rmt, inrm, rnrm, folp, folpx, xnatph,
     3                  dgc0, dpc0, dgc, dpc, adgc, adpc,
     3                  edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     4                  eorb, kappa, iorb, qnrm, xnmues, nohole, ihole,
     5                  inters, totvol, iafolp, xion, iunf, iz, jumprm)
c  opens pot.bin file and writes following information
c  General:
c     ntitle - number of title lines
c     title  - title itself
c     emu    - edge position (x-ray energy for final state at Fermi level)
c  Muffin-tin geometry
c     rmt    - muffin-tin radii
c     imt    - index of radial grid just below muffin-tin radii
c     rnrm   - Norman radii
c     inrm   - index of radial grid just below Norman radii
c     rnrmav - average Norman radius
c     folp   - overlap parameter for rmt
c     folpx  - maximum value for folp
c  Atomic orbitals info (Dirac spinors)
c     dgc0   - upper component for initial orbital
c     dpc0   - lower component for initial orbital
c     dgc    - upper components for all atomic orbitals
c     dpc    - lower components for all atomic orbitals
c     adgc   - development coefficient for upper components
c     adpc   - development coefficient for lower components
c     xnval  - number of valence electrons for each atomic orbital
c     eorb   - atomic energy of occupied orbitals
c     kappa  - quantum number kappa of occupied orbitals
c     iorb   - index of last occupied orbital for each kappa
c              used for core-valence separation and non-local exchange
c  Electron density information 
c     rhoint - interstitial density
c     rs     - r_s estimate from rhoint (4/3 r_s**3 * rhoint = 1)
c     xf     - estimate of momentum at Fermi level from rhoint
c     edens  - total electron density
c     edenvl - density from valence electrons
c     dmag   - density for spin-up minus density for spin-down
c     qtotel - total charge of a cluster
c     qnrm   - charge accumulated inside Norman sphere as result of SCF
c     xnmues - occupation numbers of valence orbitals from SCF procedure
c  Potential information
c     xmu    - Fermi level position
c     ecv    - core-valence separation energy
c     vint   - muffin-tin zero energy (interstitial potential)
c     vclap  - Coulomb potential
c     vtot   - vclap + xc potential from edens
c     vvalgs - vclap + xc potential from edenvl (EXCHANGE 5 model)
c  Specific data for convolution with excitation spectrum (see mbconv)
c     s02    - many body reduction factor S_0^2 
c     erelax - estimate of relaxation energy = efrozen - emu, where
c              efrozen is edge position estimate from Koopmans theorem
c     wp     - estimate of plasmon frequency from rhoint

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (npadx=8)
      dimension imt(0:nphx), rmt(0:nphx), inrm(0:nphx),  rnrm(0:nphx)
      dimension folp(0:nphx), folpx(0:nphx), dgc0(251), dpc0(251)
      dimension dgc(251, 30, 0:nphx), dpc(251, 30, 0:nphx)
      dimension adgc(10, 30, 0:nphx), adpc(10, 30, 0:nphx)
      dimension edens(251, 0:nphx), vclap(251, 0:nphx)
      dimension vtot(251, 0:nphx), edenvl(251, 0:nphx)
      dimension vvalgs(251, 0:nphx), dmag(251, 0:nphx)
      dimension xnval(30,0:nphx), qnrm(0:nphx), xnmues(0:lx,0:nphx)
      dimension eorb(30), kappa(30)
      dimension iorb(-4:3,0:nphx), iz(0:nphx), xion(0:nphx)
      dimension xnatph(0:nphx)
      character*80 title(nheadx)

      dimension dum(13)
      character*75 wfmt

  10  format(a)
      write (wfmt, 35) nph + 1
  35  format( '(', i3, '(1x,i4))' )

      open (unit=3, file='pot.bin', status='unknown', iostat=ios)
      call chopen (ios, 'pot.bin', 'pot')
      write(3,20) ntitle, nph, npadx, nohole, ihole, inters, iafolp,
     1            jumprm, iunf
  20  format (9(1x,i4))
      do 133  i  = 1, ntitle
         ll = istrln(title(i))
         write(3,10) title(i)(1:ll)
  133 continue
c     Misc stuff from pot.bin
      dum(1)  = rnrmav
      dum(2)  = xmu
      dum(3)  = vint
      dum(4)  = rhoint
      dum(5)  = emu
      dum(6)  = s02
      dum(7)  = erelax
      dum(8)  = wp
      dum(9)  = ecv
      dum(10)  = rs
      dum(11)  = xf
      dum(12)  = qtotel
      dum(13)  = totvol
      call wrpadd(3, npadx, dum(1), 13)

      write (3, 40) (imt(i),i=0,nph)
  40  format(20(1x,i4))
      
      call wrpadd(3, npadx, rmt(0), nph+1)

      write (3, 40) (inrm(i),i=0,nph)
      write (3, 40) (iz(i),i=0,nph)
      write (3, 40) (kappa(i),i=1,30)
      
      call wrpadd(3, npadx, rnrm(0), nph+1)
      call wrpadd(3, npadx, folp(0), nph+1)
      call wrpadd(3, npadx, folpx(0), nph+1)
      call wrpadd(3, npadx, xnatph(0), nph+1)
      call wrpadd(3, npadx, xion(0), nph+1)
      call wrpadd(3, npadx, dgc0(1), 251)
      call wrpadd(3, npadx, dpc0(1), 251)
      call wrpadd(3, npadx, dgc(1,1,0), 251*30*(nph+1) )
      call wrpadd(3, npadx, dpc(1,1,0), 251*30*(nph+1) )
      call wrpadd(3, npadx, adgc(1,1,0), 10*30*(nph+1) )
      call wrpadd(3, npadx, adpc(1,1,0), 10*30*(nph+1) )
      call wrpadd(3, npadx, edens(1,0), 251*(nph+1) )
      call wrpadd(3, npadx, vclap(1,0), 251*(nph+1) )
      call wrpadd(3, npadx, vtot(1,0), 251*(nph+1) )
      call wrpadd(3, npadx, edenvl(1,0), 251*(nph+1) )
      call wrpadd(3, npadx, vvalgs(1,0), 251*(nph+1) )
      call wrpadd(3, npadx, dmag(1,0), 251*(nph+1) )
      call wrpadd(3, npadx, xnval(1,0), 30*(nph+1) )
      call wrpadd(3, npadx, eorb(1), 30)
      
      do 50 iph=0,nph
        write (3, 60) (iorb(i,iph),i=-4,3)
 50   continue
 60   format(8(1x,i2))
      call wrpadd(3, npadx, qnrm(0), nph+1 )
      call wrpadd(3, npadx, xnmues(0,0), (lx+1)*(nph+1) )
      close (unit=3)

      return
      end
      subroutine istprm ( nph, nat, iphat, rat, iatph, xnatph,
     1                novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1                edens, edenvl, idmag,
     2                dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm, 
     2                ixc, rhoint, vint, rs, xf, xmu, xmunew,
     3                rnrmav, qtotel, inters, totvol)

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      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), folpx(0:nphx)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension dmag(251,0:nphx+1)
      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)
      parameter (big = 5000)
      character*512 slog
      logical lnear
      dimension lnear(0:nphx), inn(0:nphx), rnnmin(0:nphx)
c#mn
       external dist

c     work space for linear algebra
      dimension ri(251)
      parameter (novp=40)
      complex cmovp(novp*(nphx+1)+1,novp*(nphx+1)+1)
      integer ipiv(novp*(nphx+1)+1)
      save lnear

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)

c     find rmt from rnrm only on first call of istprm (rmt(0)=-1)
      if (rmt(0).le.0.0) then
      do 10 iph=0,nph
  10  lnear(iph)=.false.
      do 140  iph = 0, nph
         voltot = 0
         rmtavg = 0
         inrm(iph) = ii(rnrm(iph))
         if (novr(iph) .gt. 0)  then
c           Overlap explicitly defined by overlap card
            rnear = big
            inters = mod(inters,6)
c           use Norman prescription only in this case

            do 124  iovr = 1, novr(iph)
               rnn  = rovr(iovr,iph)
               inph = iphovr(iovr,iph)
               if (rnn .le. rnear) then
                  rnear = rnn
                  rnnmin(iph) = rnn
                  inn(iph) = inph
               endif
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
            rmt(iph) = big
            do 130  inat = 1, nat
               if (inat .eq. iat)  goto 130
               rnn = dist (rat(1,inat), rat(1,iat))
               inph = iphat(inat)
               if (rnn .le. rnear) then
                  rnear = rnn
                  rnnmin(iph) = rnn
                  inn(iph) = inph
               endif
c              Don't avg if norman spheres don't overlap
               if (rnrm(iph)+rnrm(inph) .lt. rnn)  goto 130

               if (inters.lt.6) then
c                Norman prescription
                 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
               else
c                Matching point prescription
                 do 125 i=inrm(iph),1,-1
                   j=ii(rnn-rnrm(iph))
                   if (vclap(i,iph).le.vclap(j,inph)) then
                     d1 = (vclap(i+1,iph)-vclap(i,iph))/(rr(i+1)-rr(i))
                     d2 =(vclap(j,inph)-vclap(j-1,inph))/(rr(j)-rr(j-1))
                     rmtavg = rr(i) + 
     1               (vclap(j,inph)+d2*(rnn-rr(i)-rr(j))-vclap(i,iph))
     2               /(d1+d2)
                     goto 127
c                    exit from the loop
                   endif
  125            continue
  127            continue
                 if (rmtavg.lt.rmt(iph)) rmt(iph) = rmtavg
               endif
  130       continue
         endif

c        special situation if rnrm is too close or larger than
c        the nearest neighbor distance
         if (rnrm(iph).ge.rnear) lnear(iph) = .true.

         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)
         elseif(inters.lt.6) then
c           Norman prescription
            rmt(iph) = rmtavg / voltot
            if (rmt(iph) .ge. rnear)  then
c              print*,iph, rmt(iph), rnear
               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
            if (rnrm(iph) .ge. rnear) then
              imax = ii(rnear) - 1
c             begin until loop
 133            if (vclap(imax,iph).lt.vclap(imax+1,iph)) goto 134
                imax = imax-1
                goto 133
c             end of until loop
 134          continue
              rmt(iph) = exp(xx(imax)) - 0.0001
            endif
         endif

  140 continue

c     set maximum value for folp(iph) if AFOLP is in use
c     LMTO lore says no more than 15% overlap
c     do 144 iph = 0, nph
c 144 folpx(iph) = 1.15
c     already done in pot.f

      do 145 iph = 0, nph
         if (iafolp. gt. 0 ) then
            temp = 0.2 + 0.8 * rnrm(iph) / rmt(iph)
         else
            temp = 0.3 + 0.7 * rnrm(iph) / rmt(iph)
         endif
         if (temp.lt.folpx(iph)) folpx(iph) = temp
         temp = rnnmin(iph)/rmt(iph)/1.06d0
         if (temp.lt.folpx(iph)) folpx(iph) = temp
         temp = exp( -(novp-3)*0.05d0)
c      make sure that with given folpx(iph) the construction
c      of the overlapping matrix in movrlp will not fail
         if (lnear(iph)) then
c           lnear=.true. only when hydrogens are present in the system.
c           want to scale both rmt for iph and inn, so that overlapping
c           matrix calculations will not fail
            temp = rnnmin(iph) / (rmt(iph)*1.05d0 + temp*rmt(inn(iph)))
            if (temp.lt.folpx(iph)) folpx(iph) = temp
            if (temp.lt.folpx(inn(iph))) folpx(inn(iph)) = temp
         else
            temp = (rnnmin(iph) - rnrm(iph))/ (temp*rmt(inn(iph)))
            if (temp.lt.folpx(inn(iph))) folpx(inn(iph)) = temp
         endif
  145 continue

      endif
c     end of finding rmt from rnrm on first call of istprm.

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
            if (edens(i,iph).le.0) then
             if(mod(i,10).eq.0) then
               write(slog, 149) 'negative dens ', i,iph
  149          format (a, 2i3)
               call wlog(slog)
             endif
             rs = 100
             xmag=1.0
            else
              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 + idmag*dmag(i,iph)
            endif
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 + idmag * dmag(i,iph) 
     1                      * edens(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)*(1+idmag*dmag(i,iph)) / 3)**(-third)
              xfmag = fa/rsmag
              call edp(rscore,xfmag,vrdh)
              vvalgs(i,iph) = vclap(i,iph) + vvbh - vrdh
            else
              vvalgs(i,iph) = 0.d0
            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
c     volint is total interstitial volume
      volint = 0
      do 180  iph = 0, nph
         rnrmav = rnrmav + xnatph(iph) * rnrm(iph)**3
         volint=volint-xnatph(iph) * rmt(iph)**3
         xn = xn + xnatph(iph)
  180 continue
      if (totvol.le.0.0d0) then
         volint=4*pi/3 *(volint+rnrmav)
      else
         volint=4*pi/3 *volint + totvol
      endif
c     volume of lenses from overlapping mt spheres is added in movrlp.
      rnrmav = (rnrmav/xn) ** third

      rs = 0
      vint   = 0
      rhoint = 0
      rsval = 0

      call movrlp(nph, nat, iphat, rat, iatph, xnatph,
     1            novr, iphovr, nnovr, rovr,
     2            imt, rmt, rnrm, ri, lnear,
     3            cmovp,ipiv, volint,inters)

c     If no contribution to interstitial from any atom, die.
      if (volint .le. 0)  then
         call wlog(' No interstitial density.  Check input file.')
         call par_stop('ISTPRM')
      endif

c     find interstitial density

      call ovp2mt(nph, edens, 0, qtotel, ri, xnatph, lnear,
     1            inrm, imt, rnrm, rmt, cmovp,ipiv, rhoint,inters)
      rhoint = 4*pi * rhoint / volint

      if (ixc.ge.5) then
c        find valence potential inside mt sphere (vintvl -dummy)
         call ovp2mt(nph, vvalgs, 1, qtotel, ri, xnatph, lnear,
     1           inrm, imt, rnrm, rmt, cmovp, ipiv, vintvl,inters)
      endif

c     find potential inside mt sphere and vint
      call ovp2mt(nph, vtot, 1, qtotel, ri, xnatph, lnear,
     1            inrm, imt, rnrm, rmt, cmovp, ipiv, vint,inters)

      if (vint.ge.xmu) then
        write(slog,'(a)')
     1  ' WARNING:interstitial level found above Fermi level'
        call wlog(slog)
        write(slog,'(a)')
     1  '  Results may be unreliable. See manual for details'
        call wlog(slog)
        vint = xmu - 0.05d0
        call ovp2mt(nph, vtot, 2, qtotel, ri, xnatph, lnear,
     1            inrm, imt, rnrm, rmt, cmovp, ipiv, vint,inters)
      endif
      call fermi (rhoint, vint, xmunew, rs, xf)

      return
      end

      double precision function calcvl (r1, r2, r)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      xl = (r1**2 - r2**2 + r**2) / (2*r)
      h = r1 - xl
      calcvl = (pi/3) * h**2 * (3*r1 - h)
      return
      end
      subroutine movrlp ( nph, nat, iphat, rat, iatph, xnatph,
     1                novr, iphovr, nnovr, rovr,
     2                imt, rmt, rnrm, ri, lnear,
     3                cmovp, ipiv, volint, inters)

c     Constructs overlap matrix based on geometry of overlapped
c     muffin-tin spheres. Uses LU decomposition for inversion of matrix
c     
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      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 imt(0:nphx)
      dimension rmt(0:nphx)
      dimension rnrm(0:nphx)
      logical lnear
      dimension lnear(0:nphx)
c     local
      character*512 slog
c     work space for linear algebra
      dimension ri(251)
      parameter (novp=40)
      complex cmovp(novp*(nphx+1)+1,novp*(nphx+1)+1)
      real bmat(nphx+1,novp*(nphx+1))
      integer ipiv(novp*(nphx+1)+1)
c#mn
       external dist, ii

c     get ipot and irav from inters
      ipot = mod(inters,2)
      irav = (inters-ipot) / 2
      do 20 i=1,251
  20  ri(i)=exp(-8.8d0+(i-1)*0.05d0)
      exphx=exp(0.025d0)

c     initiallly cmovp is a unit matrix up to ncp
      ncp = novp*(nph+1)+1
      do 30 i2=1,ncp
      do 30 i1=1,ncp
        cmovp(i1,i2) = 0.d0
        if ( i1.eq.i2 ) cmovp(i1,i2) = 1.d0
        if (i2.eq.ncp) cmovp(i1,i2) = 0.01d0
  30  continue
      do 40 i2=1,ncp-1
      do 40 i1=1,nph+1
        bmat (i1,i2) = 0.d0
  40  continue
      xn = 0.d0

      do 200 ip1=0,nph
        if (novr(ip1) .gt. 0 ) then
           nlast = novr(ip1)
        else
           iat0 = iatph(ip1)
           ntmp = 1
           nlast = nat
        endif
        if (irav.eq.1) then
          rav = (rmt(ip1) + rnrm(ip1)) / 2
        elseif (irav.eq.0) then
          rav =  rnrm(ip1)
        else
          rav=ri(imt(ip1)+1)
        endif
        if (lnear(ip1)) rav=ri(imt(ip1)+1)

        do 190 iat = 1,nlast
          if (novr(ip1) .gt. 0 ) then
             ntmp = nnovr(iat,ip1)
             ip2 = iphovr(iat,ip1)
             rnn = rovr(iat,ip1)
          else
            if (iat.eq.iat0) goto 190
            ip2 = iphat(iat)
            rnn = dist (rat(1,iat0), rat(1,iat))
          endif

c         correct for double counting volume and area
          if (rnn .lt. rmt(ip1)+rmt(ip2)) then
c            correct interstitial volume
             volint = volint + xnatph(ip1) * ntmp *
     1       (calcvl( rmt(ip1), rmt(ip2), rnn) +
     2       calcvl(rmt(ip1), rmt(ip2), rnn)) / 2.d0
          endif

c         using expression for vtot(jri) ,(jri=i1)
c         first fill  matrix bmat
          ix1 = ip1+1

          if (rav+rmt(ip2) .le. rnn) goto 100
          imin2 = ii( rnn-rav )
          if (imt(ip2)-imin2 .ge. novp-1) then
             write(slog,132) ip1
  132        format(' FOLP for POTENTIAL type ',i3,' is too big.')
             call wlog (slog)
             write(slog,'(a)') ' Reduce overlap using FOLP and rerun'
             call wlog (slog)
             call par_stop('MOVRLP-1')
          endif
          imin2=imt(ip2)-novp+1

          do 80 i2 = imin2,imt(ip2)
             r1=ri(i2)/exphx
             r2=ri(i2)*exphx
             if (i2.eq.imt(ip2)) r2=rmt(ip2)
             if (i2.eq.imt(ip2))   r1=(r1+2*ri(imt(ip2))-rmt(ip2))/2.d0
             if (i2.eq.imt(ip2)-1) r2=(r2+2*ri(imt(ip2))-rmt(ip2))/2.d0
             if (r2+rav .lt. rnn) goto 80
             if (r1+rav .lt. rnn) then
c               use linear interpolation between cases xr=0, xr=1
                xr = (rnn-rav-r1)/ (r2-r1)
                r1 = rnn-rav   
                temp =  (r2**2 - r1**2) / (4*rnn*rav) * ntmp
                ind2=i2+1
                if (i2.eq.imt(ip2))  ind2=i2-1
                xr = xr * (r2-ri(i2)) / (ri(ind2)-ri(i2))
                ix2 = ip2*novp + i2 - imin2 + 1
                bmat (ix1,ix2) = bmat (ix1,ix2) + real(temp*(1-xr))
                ix2 = ip2*novp + ind2 - imin2 + 1
                bmat (ix1,ix2)=bmat (ix1,ix2) + real(temp*xr)
             else
                temp = (r2**2 - r1**2) / (4*rnn*rav   ) * ntmp
                ix2 = ip2*novp + i2 - imin2 + 1
                bmat (ix1,ix2) = bmat (ix1,ix2) + real( temp)
             endif
  80      continue

c         using expression for vtot(i) ,(i<jri)
c         construct matrix  cmovp
 100      if (rmt(ip1)+rmt(ip2) .le. rnn) goto 190

          imin1=ii(rnn-rmt(ip2))
          imin2=ii(rnn-rmt(ip1))
          if (imt(ip1)-imin1.ge.novp-1 .or. imt(ip2)-imin2.ge.novp-1) 
     1               call par_stop('tell authors to INCREASE NOVP')
          imin1=imt(ip1)-novp+1
          imin2=imt(ip2)-novp+1

          do 180 i1 = imin1,imt(ip1)
            ri1=ri(i1)/exphx
            ri2=ri(i1)*exphx
            if (i1.eq.imt(ip1)) ri2=rmt(ip1)
            if (i1.eq.imt(ip1)) ri1=(ri1+2*ri(imt(ip1))-rmt(ip1))/2.d0
            if (i1.eq.imt(ip1)-1)
     1                         ri2=(ri2+2*ri(imt(ip1))-rmt(ip1))/2.d0
            ix1 = i1-imin1+1  + ip1*novp
            do 170 i2 = imin2,imt(ip2)
              r1=ri(i2)/exphx
              r2=ri(i2)*exphx
              if (i2.eq.imt(ip2)) r2=rmt(ip2)
              if (i2.eq.imt(ip2))   r1=(r1+2*ri(imt(ip2))-rmt(ip2))/2.d0
              if (i2.eq.imt(ip2)-1) r2=(r2+2*ri(imt(ip2))-rmt(ip2))/2.d0
              if (r2+ri2.lt.rnn) goto 170

c             calculate volume of intersection
              temp = calcvl(ri2,r2,rnn) + calcvl(r2,ri2,rnn)
              if (ri1+r2.gt.rnn)
     1          temp = temp - calcvl(ri1,r2,rnn) - calcvl(r2,ri1,rnn)
              if (ri2+r1.gt.rnn)
     1          temp = temp - calcvl(ri2,r1,rnn) - calcvl(r1,ri2,rnn)
              if (ri1+r1.gt.rnn)
     1          temp = temp + calcvl(ri1,r1,rnn) + calcvl(r1,ri1,rnn)
c             volume of intersection (temp) should be devided by volume
c             volume between spheres ri1 and ri2
              temp=temp / ( 4.d0/3.d0*pi * (ri2**3-ri1**3) ) * ntmp

              if (r1+ri2.lt.rnn) then
c               use linear interpolation between cases xr=0, xr=1
                xr = (rnn-ri(i1)-r1)/ (r2-r1)

                ind2=i2+1
                if (i2.eq.imt(ip2))  ind2=i2-1
                xr = xr * (r2-ri(i2)) / (ri(ind2)-ri(i2))
                ix2 = i2-imin2+1 + ip2*novp
                cmovp(ix1,ix2)=cmovp(ix1,ix2) 
     1                              +cmplx (temp*(1-xr))
                ix2 = ind2-imin2+1 + ip2*novp
                cmovp(ix1,ix2)=cmovp(ix1,ix2) 
     1                               +cmplx (temp*xr)
                r1=rnn-ri2
              else
                ix1 = i1-imin1+1 + ip1*novp
                ix2 = i2-imin2+1 + ip2*novp
                cmovp(ix1,ix2)=cmovp(ix1,ix2)  +cmplx (temp)
              endif
 170        continue
 180      continue

 190     continue
         xn = xn + xnatph(ip1)
  200 continue

c     using matrix bmat fill in the last row of matrix cmvovp
c     this is additional equation to find Vint.
c     switch to local equation from average over all atoms
      if (ipot .eq. 0) then
         do 260 iph=0, nph
c          xn may differ from nat, if atom list have more natx atoms
c          see rdinp.f
           aa = xnatph(iph)/xn
           do 250 ix1 = 1, ncp-1
  250      cmovp(ncp,ix1) = cmovp(ncp, ix1) + aa*bmat(iph+1,ix1)
  260    continue
      else  
         iph=0
         do 270 ix1 = 1, ncp-1
  270    cmovp(ncp,ix1) = cmovp(ncp, ix1) + bmat(iph+1,ix1)
      endif

c --- invert matrices by LU decomposition
c     call cgetrf from lapack.  this performs an LU decomposition on
c     the matrix 
      istatx=novp*(nphx+1) + 1
      call cgetrf( ncp, ncp, cmovp, istatx, ipiv, info )
      if (info.ne.0) then
          call wlog('    *** Error in cgetrf when computing cmovp')
      endif

c     have to check that the last was not permuted, otherwise
c     the density calculation will be wrong
c     this is also why we put 0.01 in last column and not 1.0
      if (ipiv(ncp).ne.ncp) 
     .  call par_stop('illegal permutation in ipiv ')

      return
      end
      subroutine ovp2mt( nph, vtot, lrewr, qtot,ri,xnatph,lnear,
     1             inrm, imt, rnrm, rmt, cmovp, ipiv, vint, inters)
c  INPUT: nph - number of diferent potentials
c   vtot(i,iph) - potential OR density at point i for potential iph
c   lrewr       - if lrewr .gt. 0 potential will be overwritten
c                   density is never overwritten (lcoul.lt.0)
c                  lrewr=0 density calculation
c                  lrewr=1 potential calculation, vint estimated
c                  lrewr=2 potential calculation, vint is fixed
c   lcoul       -  .gt.0  (potential only) calculate charge for each iph
c                  .eq.0  (potential only) flat interstitial potential 
c                  .lt.0  (density only) calc charge inside MT spheres
c   qtot       -  for density only, total electron charge of cluster
c   ri         -  loucks radial grid
c   xnatph     -  number of atoms of type iph in the cluster
c   cmovp      -  LU decomposed overlapped matrix from movrlp.f
c   ipiv       -  pivoting indices for matrix cmovp
c  OUTPUT
c    vtot    if lrewr.gt.0  decomposed overlapped potential
c            if lrewr.le.0  old prescription for potential inside MT
c              spheres or don't want to overwrite densities
c    vint    mt zero level for potentials; charge outside mt spheres for
c            densities

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension vtot(251,0:nphx), xnatph(0:nphx)
      dimension inrm(0:nphx), imt(0:nphx), rmt(0:nphx), rnrm(0:nphx)
      dimension vtotav(0:nphx)
c     work space for linear algebra
      parameter (novp=40)
      complex cmovp(novp*(nphx+1)+1,novp*(nphx+1)+1)
      complex cvovp(novp*(nphx+1)+1)
      integer ipiv(novp*(nphx+1)+1)
      dimension  ri(251)
      character*13 trans
      dimension  crho(251)
      logical lnear
      dimension lnear(0:nphx)
cpot      character*30 fname

c      get ipot and irav from inters
      ipot = mod(inters,2)
      irav = (inters-ipot) / 2
c     prepare cvovp and bvec from vtot
      ncp=0
      do 25 ip1=0,nph
      do 25 i=1,novp
        ncp = ncp + 1
        ix1 = imt(ip1)-novp + i
        cvovp(ncp)= real( vtot(ix1,ip1) )
       if (lrewr.eq.2) cvovp(ncp) = cvovp(ncp) - vint
  25  continue
      do 27 ip1=0,nph
         if (irav .eq. 1) then
           rav = (rmt(ip1) + rnrm(ip1)) / 2
         elseif(irav.eq.0) then
           rav =  rnrm(ip1)
         else
           rav = ri(imt(ip1)+1)
         endif
         if (lnear(ip1)) rav = ri(imt(ip1)+1)
         call terp(ri,vtot(1,ip1),inrm(ip1)+2,3,rav,vtotav(ip1))
  27  continue
      istatx=novp*(nphx+1)+1
      trans = 'NotTransposed'
      nrhs = 1

c     find parameters for interstitial potential
      if (lrewr.gt.0) then
c        dealing with potentials
         if (lrewr.eq.1) then
c           additional equation to find vint
            ncp = ncp + 1
            cvovp(ncp) = 0
            bsum = 0
c           switch from average equation for vint to the local one
            nphlst = 0
            if (ipot .eq. 0) nphlst = nph
            do 430 iph=0,nphlst
               cvovp(ncp) = cvovp(ncp) + vtotav(iph)*xnatph(iph)
               bsum = bsum + xnatph(iph)
  430       continue
            cvovp(ncp) = cvovp(ncp) / bsum
         endif

         call cgetrs(trans, ncp, nrhs, cmovp, istatx,
     $               ipiv, cvovp, istatx, info)
         if (info.lt.0) then
             call par_stop('    *** Error in cgetrf')
c            stop
         endif

         if (lrewr.eq.1) vint = dble(real(cvovp(ncp))) /100.0

c        rewrite vtot
         do 550 iph=0,nph
 
cpot  to write out ovp tot pot and it's mt approxim, comment out cpot
cpot         write(fname,172)  iph
cpot  172    format('potp', i2.2, '.dat')
cpot         open (unit=1, file=fname, status='unknown', iostat=ios)
cpot         call chopen (ios, fname, 'wpot')

            do 500 i=1,novp
              index1=imt(iph)-novp + i
              index2=i+novp*iph

cpot            write(1,176) i, ri(index1), 
cpot     1             vtot(index1,iph),  dble(real(cvovp(index2)))+vint
cpot  176       format (1x, i4, 1p, 3e12.4)

              vtot(index1,iph) = dble(real(cvovp(index2)))+vint
  500       continue

cpot         close (unit=1)

c           use second order extrapolation
            j=imt(iph)+1
            call terp (ri,vtot(1,iph),imt(iph),2,ri(j),vtot(j,iph))
            do 505 j=imt(iph)+2, 251
  505       vtot(j,iph) = vint
  550    continue
      else
c        dealing with  density calculations. vint  is the total
c        charge inside mt spheres.
c        Divided by interstitial volume in istprm

         call cgetrs(trans, ncp, nrhs, cmovp, istatx,
     $            ipiv, cvovp, istatx, info)
         if (info.lt.0) then
             call par_stop('    *** Error in cgetrf')
c            stop
         endif

         vint = 0
         do 450 iph=0,nph
            do 440 i=1,imt(iph)+2
               if (i.lt.imt(iph)-novp+1) then
                 crho(i) =  vtot(i,iph)*ri(i)**2
               elseif (i.le. imt(iph)) then
                 ix1 = novp*iph +i-imt(iph)+novp
                 crho(i) = real(cvovp(ix1)) * ri(i)**2
c                crho(i) =  vtot(i,iph)*ri(i)**2
               else
                 call terp(ri,crho,imt(iph),2,ri(i), crho(i) )
               endif
  440       continue
            np = imt(iph) + 2
            cdum = 0
            dpas = 0.05d0
            call somm2 (ri,crho,dpas,cdum,rmt(iph),0,np)
            vint = vint + xnatph(iph) * cdum
  450    continue
         vint=qtot-vint
      endif

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

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

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 hartrees

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

      return
      end
      subroutine sidx (rholap, npts, rmt, rnrm, imax, imt, inrm)

      implicit double precision (a-h, o-z)
      dimension rholap (npts)
      character*512 slog
c#mn
      external ii, rr

      imt = ii (rmt)
      inrm = ii (rnrm)

c     Set imax (last non-zero rholap data)
      do 220  i = imt, 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
      subroutine pot (rgrd, nohole, inters, totvol, ecv0,
     $             nscmt, nmix, ntitle, title,
     $             nat, nph, ihole, gamach, iafolp,
     $             ixc, iphat, rat, iatph,
     $             xnatph, novr,
     $             iphovr, nnovr, rovr, folp0, xion, iunf, iz, ipr1,
     $             ispec, jumprm,
     $             lmaxsc, icoul, ca1, rfms1, lfms1)

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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      Parameter (Maxprocs = 1)

c     Notes:
c        nat    number of atoms in problem
c        nph    number of unique potentials
c        ihole  hole code of absorbing atom
c        iph=0 for central atom

c     Specific atom input data
c     iphat - given specific atom, which unique pot?
      dimension iphat(natx)
c     rat(3,natx)  -  cartesian coords of specific atom
      dimension rat(3,natx)
      real rfms1

c     Unique potential input data
c     iatph(0:nphx) - given unique pot, which atom is model?
c                   (0 if none specified for this unique pot)
      dimension iatph(0:nphx)
c     xnatph(0:nphx) - given unique pot, how many atoms are there
c                      of this type? (used for interstitial calc)
      dimension xnatph(0:nphx)

c     folp(0:nphx)  - overlap factor for rmt calculation
      dimension folp(0:nphx), folp0(0:nphx), folpx(0:nphx)
c     novr(0:nphx)  - number of overlap shells for unique pot
      dimension novr(0:nphx)
c     iphovr(novrx,0:nphx)  - unique pot for this overlap shell
      dimension iphovr(novrx,0:nphx)
c     nnovr(novrx,0:nphx)  -  number of atoms in overlap shell
      dimension nnovr(novrx,0:nphx)
c     rovr(novrx,0:nphx)   -  r for overlap shell
      dimension rovr(novrx,0:nphx)

c     Free atom data
c     xion(0:nphx)  - ionicity, input
      dimension xion(0:nphx)
c     iz(0:nphx)  -   atomic number, input
      dimension iz(0:nphx)

c     ATOM output
c     Note that ATOM output is dimensioned 251, all other r grid
c     data is set to nrptx, currently 250
c     rho(251,0:nphx+1)     -   density*4*pi
      dimension rho(251,0:nphx+1)
c     vcoul(251,0:nphx+1)   -   coulomb potential
      dimension vcoul(251,0:nphx+1)
      dimension dr(251), drho(251), dvcoul(251)

c     Overlap calculation results
c     overlapped density*4*pi
      dimension edens(251,0:nphx)
c     overlapped coul pot
      dimension vclap(251,0:nphx), vclapp(251,0:nphx)
c     overlapped total potential
      dimension vtot (251,0:nphx)

c     Muffin tin calculation results
c     r mesh index just inside rmt
      dimension imt(0:nphx)
c     r mesh index just inside rnorman
      dimension inrm(0:nphx)
c     muffin tin radius
      dimension rmt(0:nphx)
c     norman radius
      dimension rnrm(0:nphx), qnrm(0:nphx), qold(0:nphx), lmaxsc(0:nphx)
      dimension xnmues(0:lx,0:nphx)
      character*80 title(nheadx)

      logical ok

      complex gtr((lx + 1) * (nphx + 1) * Maxprocs)
      complex*16 xrhoce((lx + 1) * (nphx + 1) * Maxprocs)
      complex*16 xrhole((lx + 1) * (nphx + 1) * Maxprocs)
      complex*16 yrhoce(251 * (nphx + 1) * Maxprocs )
      complex*16 yrhole(251 * (lx + 1) * (nphx + 1) * Maxprocs )
c     need irregular solution for complex potential. fix later
      dimension dgc0(251), dpc0(251)

c     additioal data needed for relativistic version
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
      dimension rhoval(251,0:nphx+1), edenvl(251,0:nphx)
      dimension vvalgs (251,0:nphx)

c     nrx = max number of r points for phase and xsect r grid
      parameter (nrx = nrptx)
      dimension ri(nrptx)
      dimension  dmag(251,0:nphx+1), xnvmu(0:lx,0:nphx+1)
      dimension  xnval(30,0:nphx+1), norb(0:nphx+1), eorb(30,0:nphx+1)
      dimension kappa(30,0:nphx+1), iorb(-4:3,0:nphx+1)
c       criteria for self-consistency
      parameter (tolq = 1.D-3)
      parameter (tolmu = 3.D-3)
      logical lpass
      character*512 slog
c     Josh use nhtmp to save nohole value
      integer nhtmp
   10 format (4x, a, i5)

c     Josh - for now if nohole=2 reset to 0 so that regular nohole
c     potential is used
      nhtmp = nohole
      if (nohole.eq.2) nohole = 0
c     Josh

c     variables ecv0 and folp0 serve as input only; do not change them
c     since it will change file feff.ior content
c     ecv and folp are passed through pot.bin to next modules.
      ecv = ecv0
      do 12 i = 0, nph
   12 folp(i) = folp0(i)

      call inipot (dgc, dpc, edenvl, vvalgs, xnmues)

c     increase the length of hydrogen bonds for potential only
      call moveh (nat, iphat, iz, rat)

      nfree = 1
      do 17 i=0,nph
        if (abs(xion(i)) .gt. 1.d-3) nfree = 2
  17  continue

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
c     Call twice if any of xion.neq.0 ( first time with xion=0 to set
c     rnrm)

      do 99 ifree = 1, nfree

      ispinr = 0
      do 20  iph = 0, nph
         write(slog,10) 
     1     'free atom potential and density for atom type', iph
         call wlog(slog)
c        Include corehole if absorber (unless user says nohole)
         if (iph .eq. 0)  then
            itmp = ihole
         else
            itmp = 0
         endif
         if (nohole.ge.0 .and. iph.eq.0) then
           xionp = xion(0)
           if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
           call scfdat ( ipr1, nph+1, nph, iz(0), itmp, xionp, iunf,
     1     vcoul(1,nph+1), rho(1,nph+1), dmag(1,nph+1), rhoval(1,nph+1),
     2     ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc, 
     3     s02, efrozn, et, xnvmu(0,nph+1),
     4     xnval(1,nph+1), iorb(-4,nph+1), norb(nph+1),
     5     eorb(1,nph+1), kappa(1,nph+1) )
         else
           xionp = xion(iph)
           if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
           call scfdat ( ipr1, iph, nph, iz(iph), itmp, xionp, iunf,
     1         vcoul(1,iph), rho(1,iph), dmag(1,iph), rhoval(1,iph),
     2         ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc, 
     3         s02, efrozn, et, xnvmu(0,iph),
     4         xnval(1,iph), iorb(-4,iph), norb(iph),
     5         eorb(1,iph), kappa(1,iph) )
         endif
c        etfin is absorbing atom final state total energy, see nohole
c           case below
         if (iph .eq. 0) etfin = et
   20 continue

      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, except for nohole.
      ispinr = ihole
      itmp = 0
      if (nohole.ge.0) then
         iph = 0
         xionp = xion(iph)
         if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
         call scfdat ( ipr1, iph, nph, iz(iph), itmp, xionp, iunf,
     1         vcoul(1,iph), rho(1,iph), dmag(1,iph), rhoval(1,iph),
     2         ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc, 
     3         s02, efrozn, etinit, xnvmu(0,iph),
     4         xnval(1,iph), iorb(-4,iph), norb(iph),
     5         eorb(1,iph), kappa(1,iph) )
      else
         xionp = xion(0)
         if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
         call scfdat ( ipr1, nph+1, nph, iz(0), itmp, xionp, iunf,
     1     vcoul(1,nph+1), rho(1,nph+1), dmag(1,nph+1), rhoval(1,nph+1),
     2     ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc, 
     3     s02, efrozn, etinit, xnvmu(0,nph+1),
     4     xnval(1,nph+1), iorb(-4,nph+1), norb(nph+1),
     5     eorb(1,nph+1), kappa(1,nph+1) )
      endif

c     testing new potential for the final state. ala
      hx = 0.05
      x0 = -8.8
      if (nohole.gt.0) then
         idim = 251
         do 30 i = 1,idim
  30     dr(i) = exp(x0+hx*(i-1))
         if (nohole.eq.1) then
            do 40 i = 1,idim
  40        drho(i) = dgc0(i)**2 + dpc0(i)**2
         else
            do 50 i = 1,idim
               drho(i)=dr(i)**2 *
     1         (rho(i,0)-rhoval(i,0)-rho(i,nph+1)+rhoval(i,nph+1))
  50        continue
         endif
         call potslw ( dvcoul, drho, dr, hx,idim)
         do 60 i=1,idim
c           drho(i) = drho(i)/ dr(i)**2
c           use 1/2 of core-hole as in transition state
            drho(i) = drho(i)/2.0d0/ dr(i)**2
  60     continue
      else
         do 70 i=1,251
            drho(i) = 0
            dvcoul(i) = 0
  70     continue
      endif

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

c     Overlap potentials and densitites
      do 90  iph = 0, nph
         write(slog,10)
     1    'overlapped potential and density for unique potential', iph
         call wlog(slog)
         call ovrlp (iph, iphat, rat, iatph, novr, iphovr,
     1               nnovr, rovr, iz, nat, rho, dmag,
     2               rhoval, vcoul, edens, edenvl, vclap, qnrm)
         if (iph.eq.0) emu = emu - vclap(1,0)+vcoul(1,0)
   90 continue
      if (ifree.eq.1) then
c       Set the Norman radii 
        do 92 iph =0, nph
   92   rnrm(iph) = qnrm(iph)
      endif

   99 continue
c  end of free atom calculations (might be done twice if ION used)

cc new patch
c     itest = 1
c     if (itest.eq.1) then
cc      use orbitals with core-hole for initial orbitals
cc      orthogonaliztion problem for NRIXS calculations
c       do i = 1, 251
c         dgc0(i) = dgc(i,0)
c         dpc0(i) = dpc(i,0)
c       enddo
c     endif
cc end new patch
     
c     Find total charges for istprm
c     qtotel - total number of e in a cluster
      qtotel = 0
      do 80 iph = 0,nph
         qtotel = qtotel + (iz(iph)-xion(iph)) * xnatph(iph)
  80  continue
c     photoelectron moves out of the system
c     do not remove now since we are putting screening electron back


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)

      rmt(0) = -1
      xmu = 100.d0
      if (iafolp.ge.0) then
        do 101 iph=0,nph
          folpx(iph) = folp(iph)
          folp(iph) = 1
  101   continue
      endif
        
      idmag = 0
      call istprm (nph, nat, iphat, rat, iatph, xnatph,
     1            novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1            edens, edenvl, idmag,
     2            dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3            ixc, rhoint,vint, rs, xf, xmu, xmunew,
     4            rnrmav, qtotel, inters, totvol)
      xmu = xmunew

c     Automatic max reasonable overlap
      if (iafolp .ge. 0)  then
         call afolp (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1               edens, edenvl,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu, xmunew,
     4               rnrmav, qtotel, inters, totvol)
         xmu =xmunew
      endif

c     wp is plasmon frequency in hart
      wp = sqrt(12.*rs/fa**4) * xf**2 / 2.d0

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

c     Find self-consistent muffin-tin potential.
      do 105 iph=0,nph
         qnrm(iph) = 0
         qold(iph) = 0
  105 continue

  100 continue
      if (nscmt.gt.0 .or. (ispec.ne.0 .and. ispec.lt.4)) call corval
     1                 ( ecv, xnvmu, eorb, norb, xnval,
     1                  kappa, rgrd, nohole,
     2                  nph, edens, edenvl, vtot, vvalgs,
     3                  rmt, rnrm, ixc, rhoint, vint, jumprm,
     4                  x0, ri, dx, xion, iunf, iz,
     5                  adgc, adpc, dgc, dpc, ihole, lmaxsc)


c     find a total number of valence electrons
c     xntot - required number of valence electrons below fermi level
c     xnvmu(iph) = xnvmu(iph)-xion(iph)
c     xnvmu - number of valence electron within norman sphere
      xntot=0.0d0
      do 120 iph=0,nph
         xnvmup = 0
         do 110  i = 0,lx
  110    xnvmup = xnvmup + xnvmu(i,iph)
c x35 and earlier   xntot = xntot + xnatph(iph)*(xnvmup+xion(iph))
         xntot = xntot + xnatph(iph) * xnvmup
  120 continue

c     need to update vxcval in case if the core-valence separation was
c     made in subroutine corval. Need vxcval only for nonlocal exchange.
      if (mod(ixc,10).ge.5) then
         call  istprm (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1               edens, edenvl, idmag,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu, xmunew,
     5               rnrmav, qtotel, inters, totvol)
         xmunew = xmu
      endif

      write(slog,130) xmu*hart
  130 format(' mu_old= ',f9.3)
      call wlog(slog)

c     do first nmix iterations with mixing scheme. Need for f-elements.
  140 nmix=nmix-1

c     number of processors for parallel execution
      npr = numprocs
      do 200 iscmt =1,nscmt
c        need to store coulomb potential
         do 145 ip=0,nph
         do 145 ir=1,251
  145    vclapp(ir,ip) = vclap(ir,ip)

         if (npr.le.1) then
           call scmt (  iscmt, ecv, nph, nat, vclap, edens,
     1                edenvl, vtot, vvalgs, rmt, rnrm, qnrm,
     2                ixc, rhoint, vint, xmunew, jumprm,
     3                xntot, xnvmu, xnval,
     4                x0, ri, dx, xnatph, xion, iunf, iz,
     5                adgc, adpc, dgc,dpc, ihole,
     7                rat, iatph, iphat, lmaxsc, rhoval, xnmues, ok,
     8                rgrd, nohole, nscmt, icoul, ca1, rfms1, lfms1)
         else
           call scmtmp (npr,  iscmt, ecv, nph, nat, vclap, edens,
     1                edenvl, vtot, vvalgs, rmt, rnrm, qnrm,
     2                ixc, rhoint, vint, xmunew, jumprm,
     3                xntot, xnvmu, xnval,
     4                x0, ri, dx, xnatph, xion, iunf, iz,
     5                adgc, adpc, dgc,dpc, ihole,
     7                rat, iatph, iphat, lmaxsc, rhoval, xnmues, ok,
     8                rgrd, nohole, nscmt, icoul, ca1, rfms1, lfms1,
     9                gtr, xrhole, xrhoce, yrhole, yrhoce )
         endif

         if (.not. ok) goto 100
c        if need to change core-valence separation then
c        start scmt loop all over again

c        write out Fermi level and charge transfers 
c        and do tests of self-consistency
         lpass = .true.
         if (iscmt.lt.nscmt .and. iscmt.le.3) lpass =.false.
         write (slog,150)   xmunew*hart
  150    format (' mu_new= ', f9.3)
         call wlog(slog)
         if (abs (xmunew - xmu) .gt. tolmu) lpass = .false.
         xmu = xmunew
c        print out charge 
         call wlog(' Charge transfer:  iph  charge(iph) ')
         do 170 iph=0,nph
            write (slog,180) iph, -qnrm(iph) + xion(iph)
            call wlog(slog)
            if (abs(qnrm(iph)-qold(iph)).gt.tolq) lpass = .false.
            qold(iph) = qnrm(iph)

c           check self-consistency of charges
            sum = -qnrm(iph)
            do 160 il=0,lx
  160       sum = sum + xnmues(il,iph) - xnvmu(il,iph)
            if (abs(sum).gt.0.05) lpass = .false.
  170    continue
  180    format('     ',i3, 2f9.3)

c        recalculate core density (edens) here. fix later. ala
c        call scfdat
c        for now use the old core density
         if (iscmt.eq.nscmt .or. lpass) then
c           restore  total density from previous iteration
            do 190 ip=0,nph
              do 185 ir=1,251
c                need total density for istprm
                 edens(ir,ip) = edens(ir,ip)-rhoval(ir,ip)+edenvl(ir,ip)
                 vclap(ir,ip) = vclapp(ir,ip)
  185         continue
c             remember the reported charge transfer
              qnrm(ip) = -qnrm(ip) + xion(ip)
  190       continue
c           exit self-consistency loop
            goto 210
         else
c           update valence density
            do 195 ip=0,nph
            do 195 ir=1,251
c              need total density for istprm
               edenvl(ir,ip) = rhoval(ir,ip)
  195       continue
         endif

         call  istprm (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1               edens, edenvl, idmag,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu, xmunew,
     5               rnrmav, qtotel, inters, totvol)
         xmunew = xmu
         if (nmix.gt.0) goto 140

  200 continue
c     suspicious exit: run out of iterations (iscmt=nscmt)

c     right exit from the loop: self-consistency is achieved
  210 continue

      if (worker) go to 400

      if (nohole.gt.0) then
c        testing new final state potential
         do 220 j = 1,251
  220    edens(j,0) = edens(j,0) - drho(j)
         
c        notice that vclap is actually for the next iteration
c        in SCMT loop, thus vclap may be wrong if self-consistency
c        has not been reached
         do 230 j = 1,251
  230    vclap(j,0) = vclap(j,0) - dvcoul(j)

         call  istprm (nph, nat, iphat, rat, iatph, xnatph,
     1      novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1      edens, edenvl, idmag,
     2      dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3      ixc, rhoint,vint, rs, xf, xmu, xmunew,
     5      rnrmav, qtotel, inters, totvol)
      endif

c    correct the excitation energy
c     emu = emu -vclap(1,0) + vcoul(1,0) done also above
c     emu = emu+xmu  should be done in principle but leads
c     to worse estimate of edge position. fix later. ala

      if (ipr1 .ge. 2)  then
         call wpot (nph, edens, imt, inrm,
     1              rho, vclap, vcoul, vtot, ntitle, title)
      endif

c     write stuff into pot.bin
      call wrpot (nph, ntitle, title, rnrmav, xmu, vint, rhoint,
     1            emu, s02, erelax, wp, ecv,rs,xf, qtotel,
     2            imt, rmt, inrm, rnrm, folp, folpx, xnatph,
     3            dgc0, dpc0, dgc, dpc, adgc, adpc,
     3            edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     4            eorb(1,0), kappa(1,0), iorb, qnrm, xnmues, nhtmp,
     5            ihole, inters, totvol, iafolp, xion, iunf, iz, jumprm)

c     write misc.dat
      if (ipr1 .ge. 1)  then
         open (unit=1, file='misc.dat', status='unknown', iostat=ios)
         call chopen (ios, 'misc.dat', 'potph')
         call wthead(1, ntitle, title)
         close (unit=1)
      endif

      call wlog(' Done with module 1: potentials. ')

  400 call par_barrier

      return
      end
      subroutine scmtmp (npr, iscmt, ecv, nph, nat, vclap,
     2                edens, edenvl, vtot, vvalgs, rmt, rnrm,qnrm,
     2                ixc, rhoint, vint, xmu, jumprm,
     3                xnferm, xnvmu, xnval,
     4                x0, ri, dx, xnatph, xion, iunf, iz,
     5                adgc, adpc, dgc,dpc, ihole,
     7                rat,iatph,iphat, lmaxsc, rhoval, xnmues, ok,
     8                rgrd, nohole, nscmt, icoul, ca1, rfms1, lfms1,
     9                gtr, xrhole, xrhoce, yrhole, yrhoce )

c     Finds new Fermi level (xmu), electron counts (qnrm) 
c     and new valence densities (rhoval).

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
      real*8 wall_commend, wall_commst
      Parameter (Maxprocs = 1)

c     input
      dimension dmagx(nrptx), dmag0(251)
      dimension vclap(251,0:nphx)
      dimension vtot (251,0:nphx), vvalgs (251,0:nphx)
      dimension xnvmu(0:lx,0:nphx+1), rmt(0:nphx),rnrm(0:nphx)
      dimension xnval (30,0:nphx)
      dimension qnrm(0:nphx), dq(0:nphx)
      dimension ri(nrptx), ri05(251), nr05(0:nphx)
      dimension xnatph(0:nphx), iz(0:nphx), xion(0:nphx)
      dimension rat(3,natx),iatph(0:nphx),iphat(natx), lmaxsc(0:nphx)
      real  rfms1
c     input and output
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension rhoval(251,0:nphx+1)

c     work space
      dimension xnmues(0:lx, 0:nphx)
      dimension dum(nrptx), vtotph(nrptx),vvalph(nrptx)
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16 ph(lx+1, 0:nphx)
      complex*16 xrhocp(0:lx,0:nphx), yrhocp(251,0:nphx)

c     special dimension for MPI
c     Maxprocs = max number of processors for parallel execution
c--   This is set in parallel.h
c     npr - actual number of processors is passed to this subroutine
      complex gtr(0:lx, 0:nph, Maxprocs)
      complex*16 xrhoce(0:lx,0:nph,Maxprocs)
      complex*16 xrhole(0:lx,0:nph,Maxprocs)
      complex*16 yrhoce(251,0:nph,Maxprocs)
      complex*16 yrhole(251,0:lx,0:nph,Maxprocs)

      integer iph
c     complex energy grid emg is decomposed into em and eref
      parameter (negx = 80)
      complex*16 emg(negx), em, eref, ee, ep, fl, fr, fxa
c     nflrx should be odd and defines the max of Im energy for
c     the countour 
      parameter (nflrx = 17)
      dimension step(nflrx)
c     stuff from feff.f for rdinp, pathfinder and genfmt
      logical wnstar, ok
c     Following passed to pathfinder, which is single precision.
      character*512 slog
      integer ient
      data ient /0/

c     save stuff from rdinp, so no need to call it again
      save   ri05, ient


      ient = ient + 1
      if (ient.eq.1) then
         xmu = -0.25d0
         do 15 i= 1,251
  15     ri05(i) = exp (-8.8+0.05*(i-1))
      endif

      write (slog,10) iscmt, nscmt
  10  format('              SCF ITERATION NUMBER',i3,'  OUT OF',i3)
      call wlog(slog)

      call wlog (' Calculating energy and space dependent l-DOS.')
      call wlog (' It takes time ...')

c     initialize new valence density
      do 16 iph=0,nphx
      do 16 ir=1,251
  16  rhoval(ir,iph) = 0

c     polarization average in scmt and ldos

      call grids (ecv, xmu, negx, neg, emg, step, nflrx)

c     ie - is number of energy points calculated
      ietot0 = 1
      ee = emg(1)
      ep = dble(ee)
      do 21 ipr=1,Maxprocs
      do 21 iph=0,nph
      do 21 il=0,lx
  21    xrhoce(il,iph, ipr) = 0
      do 22 iph=0,nphx
      do 22 il=0,lx
  22    xnmues(il,iph) = 0
      do 23 ipr=1,Maxprocs
      do 23 iph=0,nph
      do 23  ir = 1,251
  23  yrhoce(ir,iph,ipr) = 0
      iflr = nflrx
      iflrp = nflrx

      nproc = min(npr, Maxprocs)
      n1 = 1
      n2 = min(neg, nproc)

c     Start the cycle over energy points (ie)
  25  continue

c     slow loop for MPI execution
      ie = this_process + n1
      ietot = ietot0 + this_process
      if (ie .gt. n2) go to 200
        ipr = 1 + ie - n1
	if (worker) par_type = 3

c       print *,'process n1 n2 ietot',this_process,n1,n2,ietot

        if (ietot.eq.1 .or. mod(ietot,20).eq.0) then
           write(slog,30) ietot, dble(emg(ie))*hart
   30      format('     point # ', i3, '  energy = ', f7.3)
           call wlog(slog)
        endif

        do 100  iph = 0, nph
          do 35 i=1, 251
  35      dmag0(i) = 0.d0
cc        use spin-unpolarized case to get SCF. set dmagx to zero
cc        may want to replace dmag0 with dmag(1,iph) for spin-dependent
cc        extension of SCF procedure.
          call fixvar (rmt(iph),edens(1,iph),vtot(1,iph),dmag0,
     1                  vint, rhoint, dx, rgrd, jumprm,
     2                  vjump, ri, vtotph, dum, 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                dmag0, vint, rhoint, dx, rgrd , jumprm,
     2                vjump, ri, vvalph, dum, dmagx)
            if (jumprm .gt. 0) jumprm = 1
          endif

          call fixdsx (iph, dx, rgrd , dgc, dpc, dgcn, dpcn)
          jri = (log(rmt(iph)) + x0) / rgrd + 2
          jri1 = jri+1
          eref = vtotph(jri1)
          do 40 i = 1, jri1
  40      vtotph(i) = vtotph(i) - eref
          if (ixc.ge.5) then
            do 50 i = 1, jri1
  50        vvalph(i) = vvalph(i) - eref
          else
            do 60 i = 1, jri1
  60        vvalph(i) = vtotph(i)
          endif

           itmp = 0
           if (iph.eq.0 .and. nohole.lt.0) itmp = ihole
           call rholie( ri05, nr05(iph), rgrd, x0, ri, emg(ie), ixc,
     2           rmt(iph), rnrm(iph), vtotph, vvalph, xnval(1,iph),
     3           dgcn, dpcn, eref, adgc(1,1,iph), adpc(1,1,iph),
     4           xrhole(0,iph,ipr), xrhoce(0,iph,ipr),
     5           yrhole(1,0,iph,ipr), yrhoce(1,iph,ipr),
     6           ph(1,iph), iz(iph), xion(iph), iunf, itmp,lmaxsc(iph))
  100   continue

c       Write out phases for fmsie
c       transform neg,emg to em,ne,eref first
        em= dble(emg(ie))
        eref=dble(eref)-coni*dimag(emg(ie))

cc      call fms for a cluster around central atom
        do 115 iph0 = 0,nph
        do 115 il = 0, lx
  115   gtr(il,iph0,ipr) = 0
        if (rfms1 .gt. 0) then
          if (lfms1 .ne. 0) then
            iph0 = 0
c           set logic to call yprep on every processor
            lfms = lfms1
            if (ietot0.eq.1) lfms = 2
            call fmsie( iph0, nph, lmaxsc, ietot, em, eref, ph, iz,
     1           rfms1, lfms, nat, iphat, rat, gtr(0,0,ipr))
          else
            do 190 iph0 = 0, nph 
  190       call fmsie( iph0, nph, lmaxsc, ietot, em, eref, ph, iz,
     1           rfms1, lfms1, nat, iphat, rat, gtr(0,0,ipr))
          endif
        endif
  200 continue
c     end of slow loop for MPI execution

      ietot0 = ietot0 + n2 - n1 + 1
      if (worker) par_type = 2

      ixl = (lx + 1) * (nph + 1)
      ixly = ixl * 251
      ixlc = (nph + 1) * 251
      if (nproc .gt. 1) then
        call seconds(wall_commst)
        if (worker .and. (ie .le. n2)) then
c-- Send pointers for gtr buffer to master
          call par_send_int(ixl,1,0,this_process)
          call par_send_int(ixly,1,0,this_process)
          call par_send_int(ixlc,1,0,this_process)
c-- Send buffer
          if (ixl .ne. 0) then
            call par_send_cmplx(gtr(0,0,ipr),ixl,0,this_process)
            call par_send_dc(xrhoce(0,0,ipr),ixl, 0, this_process)
            call par_send_dc(xrhole(0,0,ipr),ixl, 0, this_process)
	  endif
	  if (ixly .ne. 0)  
     .      call par_send_dc(yrhole(1,0,0,ipr),ixly, 0, this_process)
	  if (ixlc .ne. 0)  
     .      call par_send_dc(yrhoce(1,0,ipr),ixlc, 0, this_process)
        else if (master) then
	  do i = 1,n2-n1
c-- Receive pointers for gtr buffer from i
	    call par_recv_int(ixl,1,i,i)
	    call par_recv_int(ixly,1,i,i)
	    call par_recv_int(ixlc,1,i,i)
c-- Receive buffer from i
	    if (ixl .ne. 0) then
	      call par_recv_cmplx(gtr(0,0,i+1),ixl,i,i)
	      call par_recv_dc(xrhoce(0,0,i+1),ixl,i,i)
              call par_recv_dc(xrhole(0,0,i+1),ixl,i,i)
	    endif
	    if (ixly .ne. 0)
     .        call par_recv_dc(yrhole(1,0,0,i+1),ixly,i,i)
	    if (ixlc .ne. 0)
     .        call par_recv_dc(yrhoce(1,0,i+1),ixlc,i,i)
	  enddo
	endif
c-- Broadcast gtr
c-- Needed here since we aren't done yet
	ilen = ixl * (n2 - n1 + 1)
	ileny = ilen * 251
	ilenc = (nph + 1) * (n2 - n1 + 1) * 251
        call par_bcast_cmplx(gtr(0,0,1),ilen,0)
        call par_bcast_dc(xrhoce(0,0,1),ilen,0)
        call par_bcast_dc(xrhole(0,0,1),ilen,0)
        call par_bcast_dc(yrhole(1,0,0,1),ileny,0)
        call par_bcast_dc(yrhoce(1,0,1),ilenc,0)
        call seconds(wall_commend)
        wall_comm = wall_comm + wall_commend - wall_commst
      endif
       
c     fast loop (does not need parallel execution)
c     uses results of the above loop to find Fermi level
c     and to decide on next set of energy points
      do 300 ie = n1, n2
        ipr = 1+ ie -n1
        ee = emg(ie)

        if (ie.eq.1 .and. iflrp.ne.1) then
c         the absolutely first point on energy grid
          do 206 iph = 0,nph
          do 206 il = 0,lx
  206     xrhocp(il,iph) = xrhoce(il,iph, ipr)
          do 207 iph = 0,nph
          do 207 i = 1,251
  207     yrhocp(i,iph) = yrhoce(i,iph, ipr)
        endif

        xntot = 0
        if (ie.eq.neg .and. iflrp.gt.1) iflr = 1
        fl = 0
        fr = 0
        do 210 iph = 0,nph
c         calculate density and integrated number of electrons in each
c         channel for each type of atoms density, etc., find xntot. 
          call ff2g (gtr(0,iph,ipr), iph,ie, nr05(iph), xrhoce(0,0,ipr), 
     1      xrhole(0,iph,ipr), xrhocp, ee, ep, yrhole(1,0,iph,ipr),
     2      yrhoce(1,iph,ipr),yrhocp(1,iph),rhoval(1,iph),
     3      xnmues(0,iph), xnatph(iph), xntot, iflr, iflrp, fl, fr,iunf)
  210   continue

c       check whether Fermi level is found between points n1 and n2
c       and decide on next set of energy points;
        if (ie.ne.1 .or. iflrp.eq.1) xndifp = xndif
        xndif = xntot - xnferm
c       if (master) print*,'xndif = ', xndif, 'xntot = ',xntot

c       check if the fermi level is found
        if ( iflr.eq.1) then
          if (xndifp*xndif .le. 0.e0) then
c         Fermi level is found ; exit from energy loop
             if (xndif.eq.0) then
               xmunew = dble(emg(ie))
               a=0
             else
               a = xndif/(xndif-xndifp)
               do 220 i = 1,4
                 fxa = a*fl + (1-a)*fr
                 bb = dimag((ep-ee)*(fr+fxa)/2 + coni*dimag(ee)*(fr-fl))
                 xndif1 = xndif + a * bb
                 a = a - xndif1 / bb
  220          continue
               xmunew = dble((1-a)*ee+a*ep)
             endif

c            add end cap corrections to the configuration and density
c            factor 2 for spin degeneracy
             do 250 iph = 0,nph
               do 230 il = 0,lx
                if (il.le.2 .or. iunf.ne.0) then
                 fl = xrhocp(il,iph) * 2
                 fr = xrhoce(il,iph,ipr) * 2
                 fxa = a*fl + (1-a)*fr
                 bb = dimag((ep-ee)*(fr+fxa)/2 + coni*dimag(ee)*(fr-fl))
                 xnmues(il,iph) = xnmues(il,iph) + a * bb
                endif
  230          continue
               do 240 ir = 1,nr05(iph)
                 fl = yrhocp(ir,iph) * 2
                 fr = yrhoce(ir,iph,ipr) * 2
                 fxa = a*fl + (1-a)*fr
                 bb = dimag((ep-ee)*(fr+fxa)/2 + coni*dimag(ee)*(fr-fl))
                 rhoval(ir,iph) = rhoval(ir,iph) + a * bb
  240          continue
  250        continue

c            exit from the energy loop
             goto 305
          endif
        endif
        ep = emg(ie)
        do 256 iph = 0,nph
        do 256 il = 0,lx
  256   xrhocp(il,iph) = xrhoce(il,iph, ipr)
        do 257 iph = 0,nph
        do 257 i = 1,251
  257   yrhocp(i,iph) = yrhoce(i,iph, ipr)

 300  continue

      if (n2.lt.neg .and. iflrp.gt.1) then
        n1 = n2+1
        n2 = min(neg, n2+nproc)
      else
c       set direction of search
        iflr = 1
        iflrp = 1
        idir = -1
        if (xndif.lt.0) idir = 1
        n1 = 1
        n2 = min(nproc, negx)
        do 303 ie = n1, n2
 303    emg(ie) = ep+ idir*step(iflr) * ie
      endif
      goto 25

c     END of the loop over energy in complex plane.
c     new fermi level and densities are calculated.
 305  continue

c     report configuration; repeat iteration if found bad counts.
      ok = .true.
      call wlog('  Electronic configuration')
      call wlog('   iph    il      N_el')
 310  format (2i6, f9.3)
      do 320 ip= 0,nph
      do 320 il = 0,lx
         write (slog,310) ip,il,xnmues(il,ip)
         call wlog(slog)
c        check that occupation numbers are consistent with those
c        set in getorb.f
         diff = abs(xnmues(il,ip) - xnvmu(il,ip))
         if (diff.gt.13.1 .or. (il.eq.2 .and. diff.gt. 9.1) .or.
     1   (il.eq.1 .and. diff.gt.5.1) .or.
     2   (il.eq.0 .and. diff.gt.1.95)) then
            call wlog (' Found bad counts.')
            write (slog,311) xnvmu(il,ip)
  311       format('  Occupation number in getorb is ', f9.3)
            call wlog(slog)
            call wlog ('  Will repeat this iteration ')
            if (ient.gt.1) ok = .false.
         endif
 320  continue

c     if (.not. ok) then will restart SCF loop 
      if (ok) then
         xmu = xmunew
c        find rhoval via Broyden algorithm
         call broydn( iscmt, ca1, nph, xnvmu,
     1         nr05 , xnatph, rnrm, qnrm, edenvl, rhoval, dq)

c        calculate new vclap - overlap coulomb potential
         call coulom (icoul, nph, nr05 , rhoval, edenvl, edens,
     2     nat, rat, iatph, iphat, rnrm, dq, iz, vclap)

c       update array edens
        do 350 ip=0,nph
           do 330 ir=1,nr05 (ip)
             edens(ir,ip)=edens(ir,ip)-edenvl(ir,ip)+rhoval(ir,ip)
  330      continue
           do 340 ir=nr05 (ip)+1,251
             edens(ir,ip)=0.0d0
             edenvl(ir,ip)=0.0d0
  340      continue
  350   continue
      endif

      return
      end
c///////////////////////////////////////////////////////////////////////
c Distribution:  COMMON 1.0
c Copyright (c) [2002] University of Washington
c 
c This software was prepared in part with US Government Funding under
c DOE contract DE-FG03-97ER45623.

c Redistribution and use of this Distribution in source and binary
c formats, with or without modification is permitted, provided the 
c following conditions are met:
c 
c Redistributions must retain the above notices and the following list
c of conditions and disclaimer;
c 
c Modified formats carry the marking
c     "Based on or developed using Distribution: COMMON 1.0
c      COMMON 1.0 Copyright (c) [2002] University of Washington"
c 
c Recipient acknowledges the right of the University of Washington to
c prepare uses of this Distribution and its modifications that may be
c substantially similar or functionally equivalent to
c Recipient-prepared modifications.
c
c Recipient and anyone obtaining access to the Distribution through
c recipient's actions accept all risk associated with possession and
c use of the Distribution.
c
c THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
c WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
c MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
c IN NO EVENT SHALL THE UNIVERSITY OF WASHINGTON OR CONTRIBUTORS TO THE
c DISTRIBUTION BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
c EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
c PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
c REVENUE; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
c LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
c NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
c SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c     sub-program ffmod9
!     program  ffmod9
      subroutine ffmod9

c     Calculation of S_0^2 
c     written by Luke Campbell 2002
c     modified by Luke Campbell 2005 for new I/O structure

c     INPUT: s02.inp mod6.inp and any set of spectroscopy output files
c            (xmu.dat, chi.dat, chipNNNN.dat, feffNNNN.dat)
c     OUTPUT: specfunct.dat and the input spectroscopy files (overwritten)

      implicit double precision (a-h, o-z)
      character*12 cfname

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}


      call par_begin
      if (worker) go to 400
c     open the log file, unit 11.  See subroutine wlog.
      open (unit=11, file='logso2.dat', status='unknown', iostat=ios)
      call chopen (ios, 'logso2.dat', 'feff')

c     read  s02.inp
      call res02( mso2conv, ispec, ipr6, ipse, ipsk, wsigk, cen, cfname)

      if (mso2conv.eq.1) then 
        call wlog(' Calculating s_0^2 ...')

c       calculate S_0^2
        call so2conv (ispec, ipr6, ipse, ipsk, wsigk, cen, cfname)

        call wlog(' Done with s_0^2.')
      endif

  400 call par_barrier
      call par_end

c     sub-program ffmod9
!     stop
      return

      end
      subroutine sfconv(ekp,mu,gammach,npts2,wpts2,xchi,npts1,wpts1,
     2                spectf,weights,cchi,phase,iasym,icut,intout,omp)
* Convolutes the array xchi (signal) with the array spectf (spectral
* function or asymmetric broadening), where spectf
* has a delta function contribution of magnitude |weights(1)+i weights(2)|
* + weights(3).  Complex phase of weights(1) + i weights(2) is given 
* to overall phase of the otherwise real valued array spectf.
* Input: ekp - Photoelectron energy neglecting collective excitations.
*        mu - Chemical potential, position of edge.
*        gammach - Core hole lifetime.
*        npts2 - Dimension of signal array xchi.
*        wpts2 - Energy grid of signal.
*        xchi - Signal array.
*        npts1 - Dimension of spectral function array spectf.
*        wpts1 - Energy grid of spectral function.
*        weights - Array of weights of components of the spectral
*            function.  Only the delta function weights, weights(1)
*            and weights(3), and the imaginary part of the extrinsic
*            delta function, weights(2) are needed.
*        cchi - The magnitude of the convoluted signal.
*        phase - The phase of the convoluted signal.
*        iasym - set to 1 to include quasiparticle phase as an 
*            asymmetric 1/omega term to the etrinsic satellite
*            rather than as a complex spectral weight.  This is
*            necessary when convoluting with a real valued
*            function or one whose imaginary part is not known.
*        icut - set to 0 to avoid truncating the spectral function
*            at energies where there is insufficient energy to create
*            excitations.
*        intout - Flag to write diagnostic file, the running integration
*            of the convolution.
*        omp - Plasma frequency.
      implicit none
      integer npts1,npts2,i,j,intout,iasym,icut
      double precision wpts2(npts2),xchi(npts2),wpts1(npts1),
     2                 spectf(npts1),weights(8),cchi,phase,ekp,mu,
     3                 gammach,spectf2(npts1),wtmp,qpr,omp
*       spectf2 - The spectral function with a cutoff to prevent 
*           excitation energies higher than the total available 
*           energy in the system (ekp-mu).
*       wtmp - The new quasiparticle weight in going 
*           from spectf to spectf2.
*       qpr - Quasiparticle reduction, from renormalizing 
*           spectral function.
      double precision xrcchi,xicchi,xnorm,dw,w,www,xfact,
     2                 xrchi,am,phasez,efrac,pi,eV,store,
     3                 amp,del,lam
*       xrcchi - Real part of convoluted signal.
*       xicchi - Imaginary part of convoluted signal.
*       xnorm - Total weight of spectral function with cutoff,
*           used to normalize the spectral function.
*       dw - Energy interval.
*       w - Exitation energy (omega)
*       www - Quasiparticle energy, available energy minus excitation energy.
*       xfact - Used to store intermediate calculations.
*       xrchi - Convoluted signal before quasiparticle phase shift.
*       am - Magnitude of quasiparticle weight.
*       phasez - Quasiparticle phase.
*       efrac - Fractional distance from one energy grid point to
*           the next, used in interpolation.
*       pi - Ratio of circumference to diameter of a circle in
*           euclidian geometry.
*       eV - Unit conversion to electron volts.
*       store - Dummy variable used to store a value that will be 
*           overwritten but needs to be used again.
*       amp - "Amplitude", signal value at first data point,
*           used for extrapolating signal to lower energies to avoid
*           artifacts.
*       lam - "Lambda", decay constant for extrapolating signal below the
*           first data point.
*       del - "Delta", energy difference used in extrapolation of signal
*           below the first data point.
      parameter (eV=1.d0/27.21160d0)

      pi=dacos(-1.d0)
      xrcchi=0.d0
      xicchi=0.d0
*      iasym=0
* Extrinsic delta function (quasiparticle) weight.
      if (iasym.eq.1) then
        am=weights(1)
      else
        am=dsqrt(weights(1)**2+weights(2)**2)
      endif
* Quasiparticle phase.
      if (weights(1).ne.0.d0.and.iasym.ne.1) then
        phasez=datan(weights(2)/weights(1))
      else
        phasez=0.d0
      endif
* Reduce quasiparticle weight in accord with the same energy cutoff
* constraints used for the rest of the spectral function.
      if (icut.eq.0) then
        qpr=1.d0
      elseif (ekp-mu.ne.0.d0) then
        qpr=datan2(gammach,mu-ekp)/pi
      else
        qpr=0.5d0
      endif
      wtmp=qpr*(am+weights(3))
      xnorm=wtmp
* Cut off that portion of spectral function with more energy than is
* available in the system.
      do i=1,npts1
        if (i.eq.1) then
          dw=wpts1(2)-wpts1(1)
        elseif (i.eq.npts1) then
          dw=wpts1(npts1)-wpts1(npts1-1)
        else
          dw=(wpts1(i+1)-wpts1(i-1))/2.d0
        endif
        w=wpts1(i)
        www=ekp-w
* Construct weight function, cutoff at chemical potential, width 
* equal to core hole lifetime.
        if (icut.eq.0) then
          xfact=1.d0
        elseif (www-mu.ne.0.d0) then
          xfact=datan2(gammach,mu-www)/pi
        else
          xfact=0.5d0
        endif
* Multiply spectral function by cutoff weight function.
        if (icut.eq.0) then
          spectf2(i)=spectf(i)
        elseif (w.ge.0.d0) then
          spectf2(i)=spectf(i)*xfact
        else
          spectf2(i)=max(0.d0,spectf(i)*xfact)
        endif
        if (iasym.eq.1) then
          spectf2(i)=spectf2(i)-qpr*(weights(2)/(pi*am*dw))
     2      *log(((w+dw/2.d0)**2+(3.d0*dw)**2)
     3         /((w-dw/2.d0)**2+(3.d0*dw)**2))
     4         *exp(-((w)/(2*omp))**2)/2.d0
        endif
* Integration to find total spectral weight.
        xnorm=xnorm+spectf2(i)*dw
      enddo
* Main convolution loop.
      do i=1,npts1
        if (i.eq.1) then
          dw=wpts1(2)-wpts1(1)
        elseif (i.eq.npts1) then
          dw=wpts1(npts1)-wpts1(npts1-1)
        else
          dw=(wpts1(i+1)-wpts1(i-1))/2.d0
        endif
        w=wpts1(i)
        www=ekp-w
        xrchi=0
        if (www.gt.wpts2(npts2)) then
* Extrapolate signal to avoid artifacts.
          xrchi=xchi(npts2)
        elseif (www.le.wpts2(1)) then
* Extrapolate signal to avoid artifacts.
          amp=xchi(1)
          del=mu-wpts2(1)
          lam=del**2/(pi*dabs(amp)*(del**2+gammach**2))
          xrchi=amp*exp(lam*(www-wpts2(1)))
        else
* Interpolate signal onto spectral function energy.
          do j=1,npts2-1
            if (www.gt.wpts2(j).and.www.le.wpts2(j+1)) then
              efrac=(www-wpts2(j))/(wpts2(j+1)-wpts2(j))
              xrchi=xchi(j)+(xchi(j+1)-xchi(j))*efrac
              goto 50
            endif
          enddo
        endif
50      continue
        if ((w+wpts1(i-1))/2.d0.lt.0.d0.and.
     2      (w+wpts1(i+1))/2.d0.ge.0.d0) then
* Add delta function contribution.
          xrcchi=xrcchi+wtmp*xrchi
        endif
* Convolution integration.
        xrcchi=xrcchi+spectf2(i)*dw*xrchi
* Print diagnostic files of running integration if requested.
        if (intout.ne.0) then
          if ((w+wpts1(i-1))/2.d0.lt.0.d0.and.
     2        (w+wpts1(i+1))/2.d0.ge.0.d0) then
            write(28,500) www,xrcchi/xnorm,xrchi,am+weights(3),
     2           spectf2(i)/xnorm
          else
            write(28,500) www,xrcchi/xnorm,xrchi,spectf(i),
     2            spectf2(i)/xnorm
          endif
        endif
      enddo
* Add overall phase equal to quasiparticle phase.
      store=xrcchi
      xrcchi=store*dcos(phasez)-xicchi*dsin(phasez)
      xicchi=xicchi*dcos(phasez)+store*dsin(phasez)
      xrcchi=xrcchi/xnorm
      xicchi=xicchi/xnorm
      cchi=dsqrt(xrcchi**2+xicchi**2)
      phase=datan2(xicchi,xrcchi)

 500  format(1x,5(e12.5,1x))
 501  format(1x,7(e10.3,1x))
      return
      end
      subroutine croots (a,b,c,d,x1,x2,x3,nrroots)
* Solves the cubic polynomial ax^3+bx^2+cx+d=0.
* Returns the number of real roots nrroots and the three roots
* of the cubic polynomial.
      implicit none
      integer nrroots
      double precision a,b,c,d,p,q,r,ar,br,disc,disc2
      complex*16 AA,BB,yr,yi,y1,y2,y3,x1,x2,x3
      x1=0.d0
      x2=0.d0
      x3=0.d0
      if (a.eq.0.d0) then
        if (b.eq.0.d0) then
          if (c.eq.0.d0) then
            nrroots=0
            return
          endif
          nrroots=1
          x1=-d/c
          return
        endif
        disc=c**2-4.d0*d*b
        if (disc.ge.0.d0) then
          nrroots=2
        else
          nrroots=0
        endif
        x1=(-c+sqrt(dcmplx(disc,0.d0)))/(2.d0*b)
        x2=(-c-sqrt(dcmplx(disc,0.d0)))/(2.d0*b)
        return
      endif
      p=b/a
      q=c/a
      r=d/a
      ar=q-p**2/3.d0
      br=(2.d0*p**3-9.d0*p*q)/27.d0+r
      disc=br**2/4.d0+ar**3/27.d0
      if (disc.gt.0.d0) then
        nrroots=1
        disc2=-br/2.d0+sqrt(disc)
        if (disc2.ge.0.d0) then
          AA=dcmplx(disc2**(1.d0/3.d0),0.d0)
        else
          AA=dcmplx(-((-disc2)**(1.d0/3.d0)),0.d0)
        endif
        disc2=-br/2.d0-sqrt(disc)
        if (disc2.ge.0.d0) then
          BB=dcmplx(disc2**(1.d0/3.d0),0.d0)
        else
          BB=dcmplx(-((-disc2)**(1.d0/3.d0)),0.d0)
        endif
      else
        nrroots=3
        if (br.lt.0.d0) then
          AA=dcmplx(-br/2.d0,sqrt(-disc))**(1.d0/3.d0)
          BB=dcmplx(dble(AA),-dimag(AA))
        else
          AA=-dcmplx(br/2.d0,-sqrt(-disc))**(1.d0/3.d0)
          BB=dcmplx(dble(AA),-dimag(AA))
        endif
      endif
      yr=-(AA+BB)/2.d0
      yi=(AA-BB)*sqrt((-3.d0,0.d0))/2.d0
      y1=yr+yi
      y2=yr-yi
      y3=AA+BB
      x1=y1-p/3.d0
      x2=y2-p/3.d0
      x3=y3-p/3.d0
      return
      end
c**********************************************************************
c   This is Steve White's rewrite of Mike Teter's integration routine.
c   Modified by J. Rehr for complex integration.
c   The following is a listing of the arguments in the initial function
c   statement:
c      fn    -- routine requires external function statement in MAIN
c      xmin  -- lower limit
c      xmax  -- upper limit
c      abr   -- absolute tolerable error
c      rlr   -- relative tolerable error
c      nsing -- number of singularities or regions requiring
c                   special attention
c      xsing -- array of locations of singularities or endpoints
c                   of special regions
c      error -- output for routine error messages
c      numcal-- the number of times fn was called
c      maxns -- the maximum number of regions being considered simultaneously
c       function grater(fn,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)
c       fn declared double precision
c       double precision function grater(fn,xmin,xmax,abr,rlr,
c       fn declared complex*16
c      complex*16 fn,value,valu,fval(3,mx),xmax,xmin,del,del1

       double precision function grater(fn,xmin,xmax,abr,rlr,
     1 nsing,xsing,error,numcal,maxns)

       implicit double precision (a-h,o-z)
       parameter (mx=1500)
       dimension xleft(mx),fval(3,mx),dx(3),wt(3)
       dimension wt9(9), xsing(20)
       external fn
        logical atsing
        save dx,wt,wt9
        data dx/0.1127016653792583  ,0.5  ,0.8872983346207417  /
        data wt/0.277777777777777778  ,0.4444444444444444444  ,
     1                               0.2777777777777777778  /
        data wt9/0.0616938806304841571  ,0.108384229110206161  ,
     1           0.0398463603260281088  ,0.175209035316976464  ,
     2           0.229732989232610220  ,0.175209035316976464  ,
     3           0.0398463603260281088  ,0.108384229110206161  ,
     4           0.0616938806304841571  /
c nstack is the number of different intervals into which the
c integration region is currently divided. The number of regions can
c grow if more accuracy is needed by dividing the right-most region
c into three regions. The number of regions shrinks when the integral
c over the right-most region is accurate enough, in which case that
c integral is added to the total (stored in grater) and the region
c is removed from consideration (and a new region is the right-most).
        nstack=nsing+1
        maxns = nstack
        error=0.
        grater=0.
c The array xleft stores the boundary points of the regions.
c The singular points just govern the initial placement of the regions.
        xleft(1)=xmin
        xleft(nsing+2)=xmax
        if(nsing.gt.0) then
          do 9 j=1,nsing
9           xleft(j+1)=xsing(j)
        endif
c For each region, calculate the function and store at three selected points.
        do 1 jj=1,nstack
          del=xleft(jj+1)-xleft(jj)
c         print*, 'fn call j= ,'
          do 1 j=1,3
c         print*, 'fn call in grater j= ',j
1           fval(j,jj)=fn(xleft(jj)+del*dx(j))
c         print*, 'output of fn call, fval(j,jj)',fval(j,jj)
        numcal = nstack * 3
6       continue
          if(nstack+3.ge.mx) then
            write(*,*) 'TOO MANY REGIONS'
            stop 0006
          endif
c Divide the rightmost region into three subregions.
          del=xleft(nstack+1)-xleft(nstack)
          xleft(nstack+3)=xleft(nstack+1)
          xleft(nstack+1)=xleft(nstack)+del*dx(1)*2.
          xleft(nstack+2)=xleft(nstack+3)-del*dx(1)*2.
c The three data points already found for the region become the
c middle data points (number 2 in first index of fval) for each region.
          fval(2,nstack+2)=fval(3,nstack)
          fval(2,nstack+1)=fval(2,nstack)
          fval(2,nstack)=fval(1,nstack)
c Now do the integral over the right-most region in two different ways-
c a three point integral (valu) over each of the three subregions
c and a more accurate nine-point integral (value) over whole region.
c valu is used only for the error estimate.
          icount=0
          value=0.
          valu=0.
          do 3 j=nstack,nstack+2
            del1=xleft(j+1)-xleft(j)
c         print*, 'fn call 2'
            fval(1,j)=fn(xleft(j)+dx(1)*del1)
            fval(3,j)=fn(xleft(j)+dx(3)*del1)
c         print*, 'fn call 2'
            numcal = numcal + 2
            do 5 k=1,3
              icount=icount+1
              value=value+wt9(icount)*fval(k,j)*del
5             valu=valu+fval(k,j)*wt(k)*del1
3         continue
          dif=abs(value-valu)
c If the following condition is true, add in this integral to the total,
c and reduce the number of regions under consideration.
          frac = del / (xmax - xmin)
          atsing = .false.
          if(frac .le. 1.0e-8) atsing = .true.
          if(dif .le. abr*frac .or. dif.le.rlr*abs(value) .or.
     1       (atsing .and.
     2     (frac .le. 1.0e-15 .or. dif .le. abr*0.1  ))) then
c The following commented out line is Teeter's old error criterion.
c          if(dif.le.abr.or.dif.le.rlr*abs(value))then
            grater=grater+value
            error=error+abs(dif)
            nstack=nstack-1
c If no more regions, we are done.
            if(nstack.le.0) return
          else
c If the integration is insufficiently accurate, make each of the
c three subregions of the right-most region into regions.
c On next pass the right-most of these is the new current region.
            nstack=nstack+2
            maxns = max(maxns,nstack)
          endif
        go to 6
        end
      subroutine interpsf(npts,epts,wpts,spectf,cspec)
* Interpolates the spectral function calculated on a minimal grid
* to a uniform grid that can be handled by the convolution subroutine.
* input: npts - number of grid points the spectral function will
*               be interpolated on to.
*        epts - energy values of the minimal grid
*        wpts - energy values of the uniform grid
*        spectf - the spectral function on the minimal grid
*        cspec - the spectral function on the uniform grid
      implicit none
      integer npts,nsfpts,i,j
*      parameter (nsfpts=80)
      parameter (nsfpts=110)
      double precision spectf(8,nsfpts),cspec(npts),epts(nsfpts),
     2                 wpts(npts),wmin,wmax,dw,sfhi,sflo,delw
      double precision pi,ef,fmu,qf,omp,ompl,wt,ekp,ek,qpk,acc,brd,adisp
      common /convsf/ pi,ef,fmu,qf,omp,ompl,wt,ekp,ek,qpk,acc,brd,adisp
      double precision se,ce,width,z1,z1i,se2,xise
      common /energies/ se,ce,width,z1,z1i,se2,xise
      wmin=epts(1)
      wmax=epts(nsfpts)
      dw=(wmax-wmin)/(npts-1)
      wpts(1)=wmin
      do i=2,npts
        wpts(i)=wmin+dw*(i-1)
      enddo
      cspec(1)=spectf(2,1)+spectf(5,1)-2.d0*spectf(4,1)
      cspec(npts)=spectf(2,nsfpts)+spectf(5,nsfpts)
     2            -2.d0*spectf(4,nsfpts)
      do i=2,npts-1
        do j=2,nsfpts
          if (wpts(i).ge.epts(j-1).and.wpts(i).lt.epts(j)) then
            delw=wpts(i)-epts(j-1)
            sfhi=spectf(2,j)+spectf(5,j)-2.d0*spectf(4,j)
            sflo=spectf(2,j-1)+spectf(5,j-1)-2.d0*spectf(4,j-1)
            cspec(i)=sflo+(sfhi-sflo)*delw/(epts(j)-epts(j-1))
            goto 10
          endif
        enddo
 10     continue
      enddo
      return
      end
      subroutine mkrmu(xmu,xmu0,rmu,wpts,npts)
* This subroutine does a Cramers-Kronig transform on the array xmu
* and returns an array rmu which is the real part of the analytic
* function whose imaginary part is xmu.  This is needed to get the proper
* phase shift for a convolution with a real function.
      implicit none
      integer npts,i,j
      double precision xmu(npts),xmu0(npts),rmu(npts),wpts(npts)
      double precision dw,pi
      pi=dacos(-1.d0)
      do j=1,npts
        rmu(j)=0.d0
        do i=1,npts
          if (i.eq.1) then
            dw=wpts(2)-wpts(1)
          elseif (i.eq.npts) then
            dw=wpts(npts)-wpts(npts-1)
          else
            dw=(wpts(i+1)-wpts(i-1))/2.d0
          endif
          if (i.ne.j) then
            rmu(j)=rmu(j)+dw*(xmu(i)-xmu0(i))/(wpts(i)-wpts(j))
          endif
        enddo
        rmu(j)=rmu(j)/pi
      enddo
      rmu(20)=(rmu(20)+rmu(21))/2.d0
      rmu(21)=rmu(20)
 500  format(1x,5(e12.5,1x))
      return
      end
      double precision function xmkesat(w)
* Find the extrinsic satellite spectral function.  This is the extrinsic 
* spectral function with the quasiparticle pole subtracted off and the 
* quasiparticle broadening removed.
* input: w - energy (omega)
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       omp - plasma frequency omega_p
*       se - real part of the on shell self energy
*       width - absolute value of the imaginargy part of the 
*            on shell self energy plus the core hole broadening
*       se2 - real part of the self energy at energy w
*       xise - imaginary part of the self energy at energy w
*       z1 - real part of the renormalization constant
*       z1i - imaginary part of the renormalization constant
      implicit none
      integer it1,it2
      double precision w,etot,emain,etothi,etotlo,z1m
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision se,ce,width,z1,z1i,se2,xise
      common /energies/ se,ce,width,z1,z1i,se2,xise
      z1m=sqrt(z1**2+z1i**2)
*      etot=-z1*(width-xise)+z1i*(w+se-se2)
      etot=-(width-xise)
      etot=etot/((w+se-se2)**2+(width-xise)**2)
*      it1=int(xmkesat)
*      it2=int(2*xmkesat)
*      if(it1.eq.it2.and.it1.gt.5) then
*        etot=-sqrt(z1**2+z1i**2)*(width-xise)
*        etothi=etot/((w+omp*1.d-3+se-se2)**2+(width-xise)**2)
*        etotlo=etot/((w-omp*1.d-3+se-se2)**2+(width-xise)**2)
*        etot=(etothi+etotlo)/2.d0
*      endif
*      emain=0.d0
      emain=-z1i/(w*pi*z1m)
      emain=emain*exp(-(w/(2*omp))**2)
      xmkesat=etot/(pi*z1m)-emain
*      it1=int(xmkesat)
*      it2=int(2*xmkesat)
*      if(it1.eq.it2.and.it1.gt.5) then
*        write(6,*) 'nan error: xmkesat'
*        write(6,*) z1,z1i,width,xise,w,se,se2,etot,xmkesat
*      endif
      return
500   format(1x,5(e12.5,1x))
      end

      double precision function xmkgwext(w)
* Find the extrinsic satellite, with full broadening and all quasiparticle
* contributions.
* input: w - energy (omega)
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       se - real part of the on shell self energy
*       se2 - real part of the self energy at energy w
*       xise - imaginary part of the self energy at energy w
      implicit none
      integer it1,it2
      double precision w,etot,emain
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision se,ce,width,z1,z1i,se2,xise
      common /energies/ se,ce,width,z1,z1i,se2,xise
      etot=xise/(pi*((w+se-se2)**2+xise**2))
      emain=0.d0
      xmkgwext=etot-emain
      it1=int(xmkgwext)
      it2=int(2*xmkgwext)
      if(it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'nan error: xmkgwext'
        write(6,*) z1,z1i,width,xise,w,se,se2,etot,xmkgwext
      endif
      return
500   format(1x,5(e12.5,1x))
      end

      double precision function xintxsat(q)
* the integrand of the interference spectral function
* input: q - momentum to be integrated over
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       omp - plasma frequency omega_p
*       ek - bare photoelectron kinetic energy = pk**2/2
*       brd - global broadening parameter to stabilize logarithms
*       ac2 - additional accuracy parameter
*       wp2 - omega prime, an additional energy variable
      implicit none
      integer numcal,maxns,nsing
      double precision wwq,q,xk,vpp2,wdisp,xfact,xloren,
     2       eps,ac2,wp2,dw1,abr,rlr,xsing,error,tol
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision se,ce,width,z1,z1i,se2,xise
      common /energies/ se,ce,width,z1,z1i,se2,xise
      common /ff/ ac2,wp2
      external vpp2,wdisp
      wwq=wdisp(q)
      tol=2.d-1*omp
      if (ek-wp2.ge.0.d0) then
        xk=sqrt(2.d0*(ek-wp2))
        xfact=log(((wwq-q**2/2+xk*q)**2+tol**2)/
     2            ((wwq-q**2/2-xk*q)**2+tol**2))/2.d0
        xloren=ac2/(pi*((wp2-wwq)**2+ac2**2))
        xintxsat=q*vpp2(q)*xloren*xfact/(wwq*xk)
      else
        xk=sqrt(-2.d0*(ek-wp2))
        xfact=datan(xk*q/(wwq-q**2/2))
        xloren=ac2/(pi*((wp2-wwq)**2+ac2**2))
        xintxsat=q*vpp2(q)*xloren*xfact/(wwq*xk)
      endif
      return
      end

      double precision function xintisat(q)
* the integrand of the intrinsic spectral function
* input: q - momentum to be integrated over
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ac2 - additional accuracy parameter
*       wp2 - omega prime, an additional energy variable
      implicit none
      integer numcal,maxns,nsing
      double precision wwq,q,xk,vpp2,wdisp,xfact,xloren,
     3       ac2,wp2,dw1,abr,rlr,xsing,error
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /ff/ ac2,wp2
      external vpp2,wdisp
      wwq=wdisp(q)
      xloren=ac2/(((wp2-wwq)**2+ac2**2)*pi)
      xintisat=q**2*vpp2(q)*xloren/wwq**2
      return
      end

      double precision function xmkxsat(w,width)
* generates the interference spectral function
* input: w - energy (omega)
*        width - additional broadening
* input from common blocks
*       omp - plasma frequency omega_p
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp2 - omega prime, an additional energy variable
      implicit none
      integer nsing,numcal,maxns,i
      double precision xintxsat,grater,abr,rlr,xsing,error,
     2       qk,wp,acc,pi,ef,xmu,qf,omp,ompl,wt,w,pk,width,
     3       ekp,ek,ac2,wp2,q2,qwidth,qmin,qmax,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /ff/ ac2,wp2
      external xintxsat,grater
      wp2=w
      ac2=width
      rlr=acc
      abr=omp*acc
      nsing=0
      q2=sqrt(max(2*(w-ompl),ac2))
      qwidth=10.d0*ac2/q2
      qmin=max(0.d0,q2-qwidth)
      qmax=q2+qwidth
*      do i=1,1000
*      enddo
*      write(6,*) 'xmkxsat'
      xmkxsat=grater(xintxsat,qmin,q2,
     2             abr,rlr,nsing,xsing,error,numcal,maxns)
      xmkxsat=xmkxsat+grater(xintxsat,q2,qmax,
     2             abr,rlr,nsing,xsing,error,numcal,maxns)
      xmkxsat=xmkxsat/(2.d0*pi)**2
      return
      end

      double precision function xmkisat(w,width)
* generates the intrinsic spectral function
* input: w - energy (omega)
*        width - additional broadening
* input from common blocks
*       omp - plasma frequency omega_p
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp2 - omega prime, an additional energy variable
      implicit none
      integer nsing,numcal,maxns
      double precision xintisat,grater,abr,rlr,xsing,error,
     2       qk,wp,acc,pi,ef,xmu,qf,omp,ompl,wt,z,w,pk,width,
     3       ekp,ek,ac2,wp2,q2,qmin,qmax,qwidth,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /ff/ ac2,wp2
      external xintisat,grater
      wp2=w
      ac2=width
      rlr=acc
      abr=omp*acc
      nsing=0
      if ((w-ompl).gt.ac2) then
        q2=dsqrt(2.d0*(w-ompl))
      else
        q2=dsqrt(2.d0*ac2)
      endif
      qwidth=10.d0*min(q2,ac2/q2)
      qmin=max(0.d0,q2-qwidth)
      qmax=q2+qwidth
      xmkisat=grater(xintisat,0.d0,q2,
     2             abr,rlr,nsing,xsing,error,numcal,maxns)
      xmkisat=xmkisat+grater(xintisat,q2,qmax,
     2             abr,rlr,nsing,xsing,error,numcal,maxns)
      xmkisat=xmkisat/(2.d0*pi**2)
      return
      end

*      double precision function xmkisat(w,width)
**     generates the intrinsic spectral function
*      implicit none
*      double precision w,wdisp,qdisp,dwdq,q,vpp2,width
*      double precision pi,ef,xmu,qf,omp,ekp,ek,pk,acc,brd,adisp
*      common /convsf/ pi,ef,xmu,qf,omp,ekp,ek,pk,acc,brd,adisp
*      external wdisp,dwdq,qdisp,vpp2
*      xmkisat=0.d0
*      if (w.gt.omp) then
*        q=qdisp(w)
*        xmkisat=q**2*vpp2(q)/(2.d0*pi**2*w**2*dwdq(q))
*      endif
*      return
*      end
*
*      double precision function xmkxsat(w)
**     generates the interference spectral function
*      implicit none
*      double precision w,q,wdisp,qdisp,dwdq,vpp2,xk,xfact,
*     2                 eta
*      complex*16 cfac,coni
*      parameter (coni=(0,1))
*      double precision pi,ef,xmu,qf,omp,ekp,ek,pk,acc,brd,adisp
*      common /convsf/ pi,ef,xmu,qf,omp,ekp,ek,pk,acc,brd,adisp
*      external wdisp,dwdq,qdisp,vpp2
*      xmkxsat=0.d0
*      eta=1.d-2*omp
*      if (w.gt.omp.and.ek.gt.w) then
*        q=qdisp(w)
*        xk=dsqrt(2.d0*(ek-w))
*        xfact=log(((w-q**2/2+xk*q)**2+(omp*acc)**2)/
*     2            ((w-q**2/2-xk*q)**2+(omp*acc)**2))/2.d0
**        cfac=log((w-q**2/2+xk*q-coni*eta)/(w-q**2/2-xk*q-coni*eta))
**        xfact=dble(cfac)
*        xmkxsat=q*vpp2(q)*xfact/((2.d0*pi)**2*xk*w*dwdq(q))
*      endif
*      return
*      end

      double precision function xmkak(w)
* This function returns the interference contribution to the 
* quasiparticle.
* input: w - energy (omega)
* input from common blocks
*       omp - plasma frequency omega_p
*       ek - bare photoelectron kinetic energy = pk**2/2
*       acc - global accuracy parameter 
*       wmax - highest allowed energy
* common block control of subprograms
*       pkq - momentum variable used in the integrand but kept 
*             fixed throughout the integration
      implicit none
      integer i,j,jj,nsing,numcal,maxns,it1,it2
      double precision w,qmax,xintak,
     2                 abr,rlr,error,xsing,grater
      integer nnpts
      double precision pkq
      common /funct2/ pkq
      double precision wmin,wmax,wmin1,wmax1
      common /limits/ wmin,wmax,wmin1,wmax1
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      external xintak
      if (w.gt.0.d0) then
        rlr=acc
        abr=dsqrt(omp)*acc
        qmax=dsqrt(2*wmax)
        pkq=dsqrt(2*ek)
        nsing=0
*        write(6,*) 'xmkak'
        xmkak=grater(xintak,abr,qmax,abr,rlr,nsing,xsing,
     2                 error,numcal,maxns)
      else
        xmkak=0.d0
      endif
      return
      end

      double precision function xintak(q)
* Integrand for the function xmkak.
* input: q - momentum to be integrated over.
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       omp - plasma frequency omega_p
*       pkq - momentum variable used in the integrand but kept 
*             fixed throughout the integration
      implicit none
      double precision wq,q,pkq,xlog,wdisp,vpp2,eps
      common /funct2/ pkq
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      external vpp2,wdisp
      wq=wdisp(q)
      eps=1.d-1
      xlog=(wq+q**2/2.d0+pkq*q)**2+(ompl*eps)**2
      xlog=xlog/((wq+q**2/2.d0-pkq*q)**2+(ompl*eps)**2)
      xlog=log(xlog)/2.d0
      xintak=q*vpp2(q)*xlog/(wq*pkq*4.d0*pi**2)
      return
      end
c  Computes spectral function window centered on resonance.  
c  Spectral function "deconvoluted" to remove broadening of main peak
      subroutine mkspectf(rs,pk,gammach,xreduc,wpts,spectf,
     2                    weights,isattype,npl,nplmax,
     3                    plengy,plwt,plbrd,brpole) 
* input: rs - radius that contains one electron
*        pk - photoelectron momentum
*        gammach - core hole lifetime broadening
*        xreduc - add-hoc interference reduction
*        isattype - approximation to use when computing satellite.
*        npl - number of poles in epsilon^{-1}
*        nplmax - maximum number of poles for dimensioning arrays
*        plengy - energy of each pole in epsilon^{-1}
*        plwt - weight of each pole in epsilon^{-1}
*        plbrd - broadening of each pole in epsilon^{-1}
*        brpole - true if poles are to be calculated with broadening
* output: wpts - array of energy points on which the spectral
*                function is specified.  array is of length npts
*         spectf - array of values of the spectral function.
*                array is of length npts
*         weights - array containing the total spectral weight of 
*                various contributions to the spectral function
*         weights(1) - extrinsic quasiparticle weight
*         weights(2) - asymmetry of quasiparticle
*         weights(3) - interference quasiparticle weight
*         weights(4) - extrinsic satellite weight
*         weights(5) - interference satellite weight
*         weights(6) - intrinsic satellite weight
*         weights(7) - weight of the extrinsic satellite clipped 
*                      to include only that part in the satellite region
*         weights(8) - weight of the extrinsic satellite clipped
*                      to include that part in the vicinity of the
*                      quasiparticle
      implicit none
      logical brpole
      integer npts,i,ii,j,jj,k,iemax,iixmax,ishift,isetold,
     2        iset,iset2,iswitch,isattype,iqph,iqpl,
     3        isetd,isetd2,iswd,iswd2,jwidth,ipl
*             npts - number of grid points for spectral function
*             i,ii,j,jj,k - counters and dummy variables
*             iixmax - grid point of highest value of the
*                   interference spectral function
*             ishift - number of grid points to shift the 
*                   extrinsic spectral function
*             iset,iset2,isetd,isetd2,isetold - keeping track
*                   of trigger conditions to separate the 
*                   extrinsic satellite into "satellite" and
*                   "main peak" regions
*             iswd,iswd2,iswitch - keeping track of grid points
*                   at which the above triggering conditions are met
*             iqph,iqpl - array points that bound the quasiparticle
*             jwidth - extra region tacked onto integration for 
*                   lorentzian broadening of the self energy
*             ipl - counter for loops over poles
*      parameter(npts=80)
      parameter(npts=112)
      integer npl,nplmax
      double precision rs,pk,gammach,xreduc,
     2                 spectf(8,npts),wpts(npts)
      double precision plengy(nplmax),plwt(nplmax),plbrd(nplmax)
      double precision conc,xa,expa,ak,aangstrom,eV,dsat,d2sat,
     2                 specttmp(npts),wswitch,swidth,wd,wd2,
     3                 dsatold,d2satold,dsath,wsearch,esfhi,esflo
*             conc - electron concentration
*             xa - dimensionless coupling constant of the electron gas
*             expa - the base of the natural logarithm raised to the
*                  power xa (e**xa)
*             ak - interference contribution to the quasiparticle
*             aangstrom - convert from angstrom to Bohr units of length
*             eV - convert from electron volts to Hartree units of energy
*             dsat,d2sat,dsatold,d2satold,dsath - finite difference 
*                  derivatives of the extrinsic satellite, to find
*                  the triggers to separate the "main peak" from the
*                  "satellite" structure of the extrinsic satellite 
*                  spectral function
*             specttmp - interpolated spectral function for shifting
*                  the extrinsic spectral function without numerical
*                  jitter
*             wsearch - energy used for finding the shift in the
*                  extrinsic spectral function
*             wswitch,wd,wdold - keep track of energy at which the trigger
*                  for separating the extrinsic spectral function
*                  is met
*             esfhi,esflo - used to bracket the high point of the
*                  extrinsic spectral function for its shift
      parameter (aangstrom=1.d0/0.52917706d0,eV=1.d0/27.21160d0)
      double precision xfact1,xfact2,wemax,wshift,wshift2,
     3                 whi,wlo,whi2,wlo2,ehi,elo,emax,ehi1,ehi2,
     4                 elo1,elo2,delta
*             xfact1,xfact2 - dummy variables for keeping track of 
*                  lengthly computations
*             wemax - the energy at the maximum value of the 
*                  extrinsic spectral function
*             wshift,wshift2 - amounts to shift the extrinsic 
*                  spectral function
*             whi,wlo,whi2,wlo2 - used to bracket the search region for the
*                  maximum of the extrinsic spectral function
*             ehi,elo,ehi1,ehi2,elo1,elo2 - values of the extrinsic 
*                  spectral function at the above bracket points
*             emax - the maximum value of the extrinsic spectral function
*             delta - a small value
      double precision sefr(npts),sefi(npts),
     2                 sef2r(npts),sef2i(npts),sumr,sumi,brpl,
     3                 wh,wl,w2,wh2,wl2,dw2
*             sefr - array of the real part of the self energy 
*                  values on the energy grid wpts
*             sefi - array of the imaginary part of the self energy 
*                  values on the energy grid wpts
*             sef2r,sef2i - self energy after lorentzian broadening
*             sumr,sumi - running integration counters
*             brpl - the broadening of a given pole in epsilon^{-1}
*             wh,wl,wh2,wl2 - high and low values of energy intervals,
*                  used for integration bounds over that interval
*             w2 - an energy variable
*             dw2 - an energy interval
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,qpk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,qpk,acc,brd,adisp
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of ipl'th pole in epsilon^{-1}
*       wt - weight of ipl'th pole in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       qpk - photoelectron momentum
*       acc - global accuracy parameter
*       brd - width of pole in epsilon^(-1)
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
      double precision wmin,wmax,wmin1,wmax1,dw,dw1,w,wlim(0:npts)
      common /limits/ wmin,wmax,wmin1,wmax1
*       wmin,wmax,wmin1,wmax1 - a bunch of extreme values of the energy
*       dw,dw1 - energy intervals
*       w - energy
*       wlim - energy values separating the energy gridpoints
      double precision se,xibeta,ce,width,xnn,xaa,se2,xise,
     2                 z0,z0i,zm,z1,z1i,z1m,xrz,xiz,x2a,x2n,
     3                 sef0,se0,yr,yi,zzr,zzi,zzm,qpengy,qpwidth
*       se - real part of the on shell self energy
*       xibeta - imaginary part of the on shell self energy, primarily 
*             used only to find width
*       ce - core energy
*       width - quasiparticle broadening
*       xnn - on shell energy derivative of the real part of the self
*             energy
*       xaa - on shell energy derivative of the imaginary part of the self
*             energy
*       se2 - real part of the self energy calculated at energy w
*       xise - imaginary part of the self energy calculated at energy w
*       z0 - approximation for the real part of the renormalization constant
*       z0i - approximation for the imaginary part of the 
*             renormalization constant
*       zm - magnitude of the above approximation for the 
*             renormalization constant
*       z1,z1i,z1m - a better approximation for the renormalization constant 
*       xrz,xiz - variables for intermediate steps in the calculation of
*             the renormalization constant
*       x2n,x2a - the real and imaginary parts, respectively, of the
*             second energy derivative of the on shell self energy.
*             These variables are not currently used in this version
*             of the code, but if needed, here they are.
*       sef0 - self energy at the fermi level
*       se0 - approximation for the self energy
*       yr - real part of second derivative of self energy
*       yi - imaginary part of second derivative of self energy
*       zzr,zzi,zzm - refined approximation for renormalization constant
*       qpengy - refined approximation for quasiparticle energy
*       qpwidth - refined approximation for quasiparticle width
      double complex zzc,yyc,xxc,discr,epc
*       zzc - complex renormalization constant
*       yyc - second derivative of self energy
*       xxc - 1-derivative of self energy
*       discr - square root of complex discriminant
*       epc - complex energy of quasiparticle pole
      double precision sxnn,sxaa,sse,sxise
*       for sums over the poles in epsilon^{-1} when computing the 
*       self energy and its derivatives
      common /energies/ se,ce,width,z1,z1i,se2,xise
      double precision xsat,xmain,emain,esat,xisat,esat2
*       the values of the interference satellite, interference 
*       quasiparticle, extrinsic quasiparticle, extrinsic satellite,
*       intrinsic satellite, and quasiparticle asymmetry spectral 
*       functions, respectively
      double precision xwidth, xiwidth
*       xwidth - broadening of the interference satellite
*       xiwidth - broadening of the intrinsic satellite
      double precision wtemain,wtesat,wtxmain,wtxsat,wtisat,
     2                 wtmesat,wtmemain,wtesat2,weights(8)
*       the total spectral weights of the extrinsic quasiparticle,
*       extrinsic satellite, interference quasiparticle, 
*       interference satellite, intrinsic satellite, clipped 
*       "satellite" part of the extrinsic satellite, clipped
*       "quasiparticle" part of the extrinsic satellite, and quasipartcle
*       asymmetry terms in the spectral function, respectively, in 
*       addition to the array of spectral weights
      double precision swtcorr,satwt,swtfac
*       swtcorr - the weight of the negative regions of the satellite
*       satwt - the satellite weight (neglecting factors of expa, as above)
*       swtfac - renormalization factor to keep satellite weight the 
*          same after negative parts are chopped off
      double precision grater,abr,rlr,xsing,error
      integer nsing,numcal,maxns
*       Grater is an integration function.  See its description for
*       the meaning of these variables.
      double precision xmkesat,beta,xmkak,xmkxsat,xmkisat,
     2                 xmkgwext,xmkssat,xmkpsat,xmkxg,xmkig
*       These are functions called in the execution of this subroutine.
      integer iwrite,jcount
      common /flag/ iwrite,jcount
*       These are used to flag a particular run of this subroutine
*       to write intermediate results to a file.
      integer lowq
*       lowq - If not equal to zero, calculate contributions
*          to self energy from below Fermi level.
      common /belowqf/ lowq
      external beta,grater,xmkesat,xmkxsat,xmkisat,xmkak,xmkgwext,
     2         xmkssat,xmkxg,xmkig
      double precision w3,q3,q4
      common /fqso2/ q3
      common /fw/ w
c     Josh - comment out extraneous externals
c      double precision wintr1,winti1,wintr2,winti2,xdumr,xdumi
c      external wintr1,winti1,wintr2,winti2
c      double precision srrpaw1,sirpaw1,rpadsfr,rpadsfi
c      external srrpaw1,sirpaw1,rpadsfr,rpadsfi
c      double precision rpapolr,rpapoli
c     external rpapolr,rpapoli
c      double precision xtestr,xtesti,qq,wplas,dq
c      external xtestr,xtesti,wplas
c      double precision rpasigr,rpasigi
c      external rpasigr,rpasigi
c     End Josh
      double precision exchange
      external exchange
      integer iw
      integer ijkwrite
      common /morewrite/ ijkwrite
* test functions

* compute initial values
      ijkwrite=0
      acc=1.d-4
      pi=dacos(-1.d0)
      qf=((9.d0*pi/4.d0)**(1.d0/3.d0))/rs
      ef=qf*qf/2.d0
      conc=3.d0/(4.d0*pi*(rs**3))
      omp=dsqrt(4.d0*pi*conc)
      qpk=qf
      ek=ef
      ekp=ef
      adisp=2.d0*ef/3.d0
      sef0=0.d0
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        if (brpole) then
          call brsigma(0.d0,sse,sxise)
        else
          call renergies(0.d0,sse)
        endif
*        call ppset(rs,pi,qf,ef,omp)
        sef0=sef0+sse*wt
      enddo
      sef0=sef0+exchange(qf)
*      call ppset(rs,pi,qf,ef,omp)
      xmu=ef+sef0
      ekp=xmu

* first estimate for energies and self energies
      qpk=pk
      ek=pk*pk/2.d0
      ekp=ek
      se0=0.d0
      xnn=0.d0
      xaa=0.d0
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        if (brpole) then
          call brsigma(0.d0,sse,sxise)
          call dbrsigma(0.d0,sxnn,sxaa)
        else
          call renergies(0.d0,sse)
          call drenergies(0.d0,sxnn)
          call dienergies(0.d0,sxaa)
        endif
*        call ppset(rs,pi,qf,ef,omp)
        se0=se0+sse*wt
        xnn=xnn+sxnn*wt
        xaa=xaa+sxaa*wt
      enddo
      se0=se0+exchange(pk)
*      call ppset(rs,pi,qf,ef,omp)
      xrz=1.d0-xnn
      xiz=-xaa
      z0=xrz/(xrz**2+xiz**2)
      z0i=-xiz/(xrz**2+xiz**2)
      zm=dsqrt(z0**2+z0i**2)
      ekp=ek+sef0+z0*(se0-sef0)

* refined estimate for self energies, using the self energy at the 
* Fermi level to increase self consistency
      se=0.d0
      xibeta=0.d0
      xnn=0.d0
      xaa=0.d0
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        if (brpole) then
          call brsigma(-sef0,sse,sxise)
          call dbrsigma(-sef0,sxnn,sxaa)
        else
          call renergies(-sef0,sse)
          call xienergies(-sef0,sxise)
          call drenergies(-sef0,sxnn)
          call dienergies(-sef0,sxaa)
        endif
        se=se+sse*wt
        xibeta=xibeta+sxise*wt
        xnn=xnn+sxnn*wt
        xaa=xaa+sxaa*wt
      enddo
      se=se+exchange(pk)
      width=dabs(xibeta)+gammach

* calculate renormalization constant
      xa=0.d0
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        xa=xa+3*wt*(omp/ompl)**2/(8*dsqrt(2.d0*ompl))
      enddo
      expa=exp(-xa)
      xrz=1.d0-xnn
      xiz=-xaa
      z1=xrz/(xrz**2+xiz**2)
      z1i=-xiz/(xrz**2+xiz**2)
      z1m=sqrt(z1**2+z1i**2)

* Find energy gridpoints
      dw=omp/30.d0
      iqph=54
      iqpl=53
      wpts(iqph)=dw*1.d-2
      wpts(iqpl)=-dw*1.d-2
      wpts(iqph+1)=dw*2.d-2
      wpts(iqpl-1)=-dw*2.d-2
      do i=1,30
        wpts(i+1+iqph)=i*dw
        wpts(iqpl-1-i)=-i*dw
      enddo
      do i=1,3
        wpts(i+31+iqph)=wpts(31+iqph)+i*dw
        wpts(iqpl-31-i)=wpts(iqpl-31)-i*dw
      enddo
      do i=1,3
        wpts(i+34+iqph)=wpts(34+iqph)+(2*i)*dw
        wpts(iqpl-34-i)=wpts(iqpl-33)-(2*i)*dw
      enddo
      do i=1,3
        wpts(i+37+iqph)=wpts(37+iqph)+(4*i)*dw
        wpts(iqpl-37-i)=wpts(iqpl-36)-(4*i)*dw
      enddo
      do i=1,12
        wpts(i+40+iqph)=wpts(40+iqph)+(10*i)*dw
        wpts(iqpl-40-i)=wpts(iqpl-39)-(10*i)*dw
      enddo
      do i=1,6
        wpts(i+52+iqph)=wpts(52+iqph)+(30*i)*dw
      enddo
      do i=1,npts-1
        wlim(i)=(wpts(i)+wpts(i+1))/2.d0
      enddo
      wlim(0)=2.d0*wpts(1)-wpts(2)
      wlim(npts)=2.d0*wpts(npts)-wpts(npts-1)
      wmin=wpts(1)
      wmax=wpts(npts)
      wmax1=ekp+wmax
      wmin1=ekp+wmin

* compute self energies on energy gridpoints
      do i=1,npts
        sefr(i)=0.d0
        sefi(i)=0.d0
      enddo
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        do i=1,npts
          w=wpts(i)+ekp
          dw1=wlim(i)-wlim(i-1)
*          dw1=wpts(i)-wpts(i-1)
  
*          call renergies(w-ekp-sef0,sse)
*          call xienergies(w-ekp-sef0,sxise)
          if (brpole) then
            call brsigma(w-ekp-se,sse,sxise)
          else
            call renergies(w-ekp-se,sse)
            call xienergies(w-ekp-se,sxise)
          endif
          sefr(i)=sefr(i)+sse*wt
          sefi(i)=sefi(i)+sxise*wt
        enddo
*        call ppset(rs,pi,qf,ef,omp)
      enddo
      se2=0.d0
      xise=0.d0
      xnn=0.d0
      xaa=0.d0
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        if (brpole) then
          call brsigma(-se,sse,sxise)
          call dbrsigma(-se,sxnn,sxaa)
        else
          call renergies(-se,sse)
          call xienergies(-se,sxise)
          call drenergies(-se,sxnn)
          call dienergies(-se,sxaa)
        endif
        se2=se2+sse*wt
        xise=xise+sxise*wt
        xnn=xnn+sxnn*wt
        xaa=xaa+sxaa*wt
      enddo
      se=se2+exchange(pk)
      width=dabs(xise)+gammach


      do i=1,npts
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        sefr(i)=sefr(i)+exchange(pk)
        sefi(i)=dabs(sefi(i))+gammach
        if (iwrite.eq.jcount) write(24,500) wpts(i),sefr(i),sefi(i)
      enddo
*      se=(sefr(iqph)+sefr(iqpl))/2
*      width=(sefi(iqph)+sefi(iqpl))/2
*      xnn=(sefr(iqph)-sefr(iqpl))/(wpts(iqph)-wpts(iqpl))
*      xaa=(sefi(iqph)-sefi(iqpl))/(wpts(iqph)-wpts(iqpl))
      xrz=1.d0-xnn
      xiz=-xaa
      z1=xrz/(xrz**2+xiz**2)
      z1i=-xiz/(xrz**2+xiz**2)
      z1m=sqrt(z1**2+z1i**2)
      qpengy=ekp+width*z1i
      qpwidth=width*z1
      zzr=z1
      zzi=z1i
      zzm=z1m

*      write(68,*) pk/qf,se,width,z1,z1i

* correct for endpoint effects
      ak=0.d0
      do ipl=1,npl
        call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
        ak=ak+xmkak(ekp)*xreduc*wt
*        call ppset(rs,pi,qf,ef,omp)
      enddo
      wtemain=(datan(wlim(0)/width)+pi/2.d0)/pi
     2        +(pi/2.d0-datan(wlim(npts)/width))/pi
      wtxmain=2.d0*wtemain*zm*z1*ak
      wtemain=wtemain*z1*expa
      wtesat=0.d0
      wtesat2=0.d0
      wtxsat=0.d0
      wtisat=0.d0
      do i=1,npts
        do ii=1,8
          spectf(ii,i)=0.d0
        enddo
      enddo

* compute spectral function
      do i=1,npts
        w=wpts(i)+ekp
        dw1=wlim(i)-wlim(i-1)

        se2=sefr(i)
        xise=sefi(i)

* This form for the extrinsic quasiparticle is calculated at the
* correct quasiparticle pole, for much better cancelation of the
* quasiparticle structure from the xmkgwext function, below.
        emain=z1*(datan((wlim(i)-qpengy+ekp)/qpwidth)
     2        -datan((wlim(i-1)-qpengy+ekp)/qpwidth))/(pi*dw1)
     3        -z1i*dlog((qpwidth**2+(wlim(i)-qpengy+ekp)**2)/
     4         (qpwidth**2+(wlim(i-1)-qpengy+ekp)**2))/(2.d0*pi*dw1)
     5         *exp(-((w-qpengy)/(2*omp))**2)
        xmain=2.d0*zm*ak*emain
        wtemain=wtemain+emain*expa*dw1
        wtxmain=wtxmain+xmain*expa*dw1
* Depending on the value of isattype, different approximations
* can be used for the satellite.
        if (isattype.eq.1) then
          esat=xmkgwext(w-ekp)-emain
        elseif (isattype.eq.2) then
          esat=(xise-width-(w-ekp)*xaa)/(pi*(w-ekp)**2)
        elseif (isattype.eq.3) then
* generate full extrinsic spectral function - do not use for spectroscopy!
          esat=xmkgwext(w-ekp)
        else
          esat=xmkesat(w-ekp)
        endif
        xsat=0.d0
        xisat=0.d0
        do ipl=1,npl
          call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
          xwidth=max(5.d0*dw,brd)
          xiwidth=max(2.d0*dw,brd)
          if (isattype.eq.3) then
            xwidth=xwidth+width
            xiwidth=xiwidth+width
          endif
          xsat=xsat+xmkxsat(w-ekp,xwidth)*xreduc*wt
          xisat=xisat+xmkisat(w-ekp,xiwidth)*wt
*          call ppset(rs,pi,qf,ef,omp)
        enddo
        wtxsat=wtxsat+xsat*dw1*expa
        wtesat=wtesat+esat*dw1*expa
        wtisat=wtisat+xisat*dw1*expa
        spectf(1,i)=emain
        spectf(2,i)=esat
        spectf(3,i)=xmain
        spectf(4,i)=xsat
        spectf(5,i)=xisat
        spectf(6,i)=(esat+xisat-2.d0*xsat)
        if (isattype.eq.3) then
          spectf(6,i)=spectf(6,i)+xmain
        endif
      enddo
      spectf(2,iqpl)=(spectf(2,iqpl)+spectf(2,iqph))/2
      spectf(2,iqph)=spectf(2,iqpl)

*     separate quasiparticle-like structure from satellite in non-delta
*     function part of extrinsic spectral function.
      iset=0
      iset2=0
      dsatold=0.d0
      d2satold=0.d0
      isetd=0
      isetd2=0
      do ii=2,npts-1
        isetold=iset2
        i=npts+1-ii
        w=wpts(i)+ekp
        dsat=(spectf(2,i)-spectf(2,i-1))/(wpts(i)-wpts(i-1))
        dsath=(spectf(2,i+1)-spectf(2,i))/(wpts(i+1)-wpts(i))
        d2sat=(dsath-dsat)/(wlim(i)-wlim(i-1))
        if (dsat.gt.0.d0.and.spectf(2,i).gt.0.d0
     2      .and.iset.eq.0.d0) iemax=i
        if (spectf(5,i).lt.spectf(5,i+1)
     2      .and.spectf(5,i+1).gt.spectf(5,i+2)) iixmax=i
        if (dsat.gt.0.d0.and.spectf(2,i).gt.0.d0) iset=1
        if (beta(0.d0).gt.0.d0) then
          if (dsat.lt.0.d0.and.dsatold.ge.0.d0
     2        .and.iset.eq.1.and.isetd.eq.0) then
             isetd=1
             iswd=i
             wd=w
          endif
          if (d2sat.gt.0.d0.and.d2satold.le.0.d0
     2        .and.iset.eq.1.and.isetd2.eq.0) then
             isetd2=1
             iswd2=i
             wd2=w
          endif
        else
          if (dsat.lt.0.d0.and.dsatold.ge.0.d0
     2        .and.iset.eq.1.and.isetd.eq.0.and.w.gt.0.d0) then
             isetd=1
             iswd=i
             wd=w
          endif
          if (d2sat.gt.0.d0.and.d2satold.le.0.d0
     2        .and.iset.eq.1.and.isetd2.eq.0) then
             isetd2=1
             iswd2=i
             wd2=w
          endif
        endif
      enddo
      if (isetd.eq.1) then
        iswitch=iswd
        wswitch=wd
      else
        iswitch=iswd2
        wswitch=wd2
      endif
*      swidth=(omp/4.d0)*spectf(2,iswitch)/spectf(2,iemax)
      swidth=0.d0
      do i=1,npts
        w=wpts(i)+ekp
        if (swidth.gt.0.d0) then
          spectf(7,i)=spectf(2,i)/(1.d0+exp((w-wswitch)/swidth))
          spectf(8,i)=spectf(2,i)/(1.d0+exp((wswitch-w)/swidth))
        elseif (i.ge.iswitch) then
          spectf(8,i)=spectf(2,i)
        else
          spectf(7,i)=spectf(2,i)
        endif
      enddo

** find the energy at which the extrinsic satellite reaches its 
** maximum value.
*      wemax=wpts(iemax)+ekp
*      whi=wpts(iemax+1)+ekp
*      wlo=wpts(iemax-1)+ekp
*      emax=spectf(2,iemax)
*      do i=1,8
*        whi2=(whi+wemax)/2.d0
*        wlo2=(wlo+wemax)/2.d0
*        if (whi2-ekp.ne.0.d0) then
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          xise=dabs(xise)+gammach
*          ehi=xmkesat(whi2-ekp)
*        else
*          delta=(whi2-wemax)/1.d3
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          xise=dabs(xise)+gammach
*          ehi1=xmkesat(whi2-ekp+delta)
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          xise=dabs(xise)+gammach
*          ehi2=xmkesat(whi2-ekp-delta)
*          ehi=(ehi1+ehi2)/2.d0
*        endif
*        if (wlo2-ekp.ne.0.d0) then
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          xise=dabs(xise)+gammach
*          elo=xmkesat(wlo2-ekp)
*        else
*          delta=(wemax-wlo2)/1.d3
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          xise=dabs(xise)+gammach
*          elo1=xmkesat(wlo2-ekp+delta)
*          se2=0.d0
*          xise=0.d0
*          do ipl=1,npl
*            call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
*            call brsigma(whi2-ekp-sef0,sse,sxise)
**            call ppset(rs,pi,qf,ef,omp)
*            se2=se2+sse*wt
*            xise=xise+sxise*wt
*          enddo
*          se2=se2+exchange(pk)
*          xise=dabs(xise)+gammach
*          elo2=xmkesat(wlo2-ekp-delta)
*          elo=(elo1+elo2)/2.d0
*        endif
*        if (ehi.gt.emax.and.ehi.gt.elo) then
*          wlo=wemax
*          wemax=whi2
*          emax=ehi
*        elseif(elo.gt.emax.and.elo.ge.ehi) then
*          whi=wemax
*          wemax=wlo2
*          emax=elo
*        else
*          whi=whi2
*          wlo=wlo2
*        endif
*      enddo
*      wemax=wemax-ekp
*
** if the extrinsic spectral function peaks beyond the plasma frequency,
** shift the spectral function so it peaks at the plasma frequency.
**      if(wemax.lt.omp) then
*      if(.false.) then
*        wshift=omp-wemax
*        ishift=53-iemax
**       here, wpts(53)=omp
*        wshift2=wpts(iemax)-wemax
*        if (wshift.lt.0.d0) then
*          ishift=ishift-1
*          wshift2=wpts(iemax+1)-wemax
*        endif
**        ishift=int(wshift/dw)
**        wshift2=wshift-ishift*dw
*        do i=1,ishift
*          specttmp(i)=0.d0
*        enddo
*        do i=1,npts
*          wsearch=wpts(i)-wshift
*          if (wpts(1).gt.wsearch) then
*            specttmp(i)=0.d0
*          else
*            do j=1,npts
*              if (wpts(j).gt.wsearch) then
*                whi=wpts(j)
*                wlo=wpts(j-1)
*                esfhi=spectf(2,j)
*                esflo=spectf(2,j-1)
*                wshift2=wpts(j)-wsearch
*                specttmp(i)=esflo+(esfhi-esflo)*wshift2/(whi-wlo)
*                goto 100
*              endif
*            enddo
*          endif
*100       continue
*        enddo
*      endif


* Find the weights for the clipped parts of the extrinsic satellite
      wtmesat=0.d0
      wtmemain=0.d0
      do i=1,npts
        wtmesat=wtmesat+spectf(8,i)*expa*dw
        wtmemain=wtmemain+spectf(7,i)*expa*dw
      enddo
** Weight the satellite terms by the power of the renormalization
** constant reflecting how many powers of the extrinsic Green's function
** appear in the original expressions
*      wtxsat=wtxsat*(zm+wtmemain)**2
*      wtisat=wtisat*(zm+wtmemain)
      do i=1,npts
*        spectf(4,i)=spectf(4,i)*(zm+wtmemain)**2
*        spectf(5,i)=spectf(5,i)*(zm+wtmemain)
        spectf(6,i)=spectf(2,i)-2.d0*spectf(4,i)+spectf(5,i)
      enddo
      
* eliminate regions of negative spectral weight, keep track of 
* the total satellite weight before correction and weight of negative
* regions removed for later renormalization.
      swtcorr=0.d0
      satwt=0.d0
      do i=1,npts
        w=wpts(i)+ekp
        dw1=wlim(i)-wlim(i-1)
        satwt=satwt+spectf(6,i)*dw1
        if (spectf(6,i).lt.0.d0) then
          swtcorr=swtcorr+spectf(6,i)*dw1
          spectf(6,i)=0.d0
          spectf(4,i)=(spectf(2,i)+spectf(5,i))/2.d0
        endif
      enddo
* renormalize to keep satellite weight the same.
      swtfac=satwt/(satwt-swtcorr)
      if (swtfac.lt.0.d0) swtfac=0.d0
      wtxsat=0.d0
      wtisat=0.d0
      wtesat=0.d0
      wtmesat=0.d0
      wtmemain=0.d0
      do i=1,npts
        w=wpts(i)+ekp
        dw1=wlim(i)-wlim(i-1)
        spectf(4,i)=(spectf(2,i)+spectf(5,i)-spectf(6,i)*swtfac)/2.d0
        wtxsat=wtxsat+spectf(4,i)*dw1*expa
        wtesat=wtesat+spectf(2,i)*dw1*expa
        wtisat=wtisat+spectf(5,i)*dw1*expa
        wtmesat=wtmesat+spectf(8,i)*expa*dw
        wtmemain=wtmemain+spectf(7,i)*expa*dw
      enddo
        
* Write out array of weights
      weights(1)=z1*expa
      write(66,*) z1,expa
      weights(2)=z1i*expa
      weights(3)=2.d0*z1*zm*ak*xreduc*expa
      weights(4)=wtesat
      weights(5)=wtxsat
      weights(6)=wtisat
      weights(7)=wtmesat
      weights(8)=wtmemain

*      write(6,*) xxc,yyc,discr,abs(discr),
*     2           -2.d0*width*(0,1)*yyc,zzc,abs(zzc),z1,z1i
*      z1=zzr
*      z1i=zzi
*      z1m=zzm

      if (iwrite.eq.jcount) then
        do i=1,npts
          write(12,500) wpts(i),spectf(1,i),spectf(3,i),
     2                  spectf(7,i),spectf(8,i)
          write(13,500) wpts(i),spectf(2,i),spectf(4,i),
     2                  spectf(5,i),
     3                  spectf(2,i)+spectf(5,i)-2.d0*spectf(4,i)
*     2                  spectf(5,i),spectf(6,i)
        enddo
      endif

      return
 500  format(1x,5(e12.5,1x))
 700  format(1x,7(f10.5,1x))
      end
      double precision function wdisp(q)
* dispertion relation
* input: q - momentum or wavenumber
* input from common blocks
*       ompl - zero q energy of mode
*       adisp - dispersion parameter for dispersion relation,
      implicit none
      double precision q
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      wdisp=sqrt(ompl**2+adisp*q**2+q**4/4.d0)
      return
      end

      double precision function dwdq(q)
* the derivative of the dispertion relation 
* with respect to the plasmon momentum q
* input: q - momentum or wavenumber
* input from common blocks
*       ompl - zero q energy of mode
*       adisp - dispersion parameter for dispersion relation,
      implicit none
      double precision q,wdisp
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      external wdisp
      dwdq=(q**3+2.d0*adisp*q)/(2.d0*wdisp(q))
      return
      end

      double precision function d2wdq2(q)
* the second derivative of the dispertion relation 
* with respect to the plasmon momentum q
* input: q - momentum or wavenumber
* input from common blocks
*       omp - plasma frequency omega_p
*       adisp - dispersion parameter for dispersion relation,
      implicit none
      double precision q,wdisp,dwdq
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      external wdisp,dwdq
      d2wdq2=(3.d0*q**2+2.d0*adisp)*wdisp(q)
     2       -(q**3+2.d0*adisp*q)*dwdq(q)
      d2wdq2=d2wdq2/(2.d0*wdisp(q)**2)
      return
      end

      double precision function qdisp(w)
* The inverse dispertion relation
* input: w - energy (omega)
* input from common blocks
*       ompl - zero q energy of mode
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=ompl+adisp*q**2+q**4/4
      implicit none
      double precision w,x,y
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      x=adisp**2+w**2-ompl**2
      if (x.ge.0.d0) then
        y=-2.d0*adisp+2.d0*dsqrt(x)
        if (y.ge.0.d0) then
          qdisp=dsqrt(y)
          return
        endif
      endif
      qdisp=0.d0
      return
      end

      double precision function qthresh(ompl,AA,ef,qf)
* Find the photoelectron momentum corresponding to the onset of plasmon
* losses.
* input: ompl - zero q energy of mode
*        AA - dispersion parameter omega(q)**2=ompl**2+AA*q**2+q**4/4
*        ef - fermi energy
*        qf - fermi momentum
      implicit none
      integer i,nrts,nrts2,nflip,nqa,nqb
      double precision AA,ompl,ef,qf,a,b,c,d,qthresh1,qthresh2,q01,
     2                 q02,xfact,test1,test2,test3,qh,ek,q1a,q2a,
     3                 q3a,q0a,q1b,q2b,q3b,q0b,w,x,y
      complex*16 rt1,rt2,rt3,rtt1,rtt2,rtt3,rt(3),rtt(3),qst
      a=1.d0
      b=-3.d0*AA
      c=3.d0*AA**2-27.d0*ompl**2/4.d0
      d=-AA**3
      call croots(a,b,c,d,rt1,rt2,rt3,nrts)
      rt(1)=rt1
      rt(2)=rt2
      rt(3)=rt3
      if (nrts.eq.1) then
 10     continue
          nflip=0
          do i=1,2
            if (dimag(rt(i)).lt.dimag(rt(i+1))) then
              qst=rt(i)
              rt(i)=rt(i+1)
              rt(i+1)=qst
              nflip=nflip+1
            endif
          enddo
        if (nflip.ne.0) goto 10
        qthresh1=dble(rt(2))
      else
        qthresh1=max(dble(rt1),dble(rt2),dble(rt3))
      endif
*      write(6,*) rt1,rt2,rt3
*      write(6,*) qthresh1
      if (qthresh1.gt.0.d0) then
        qthresh1=dsqrt(qthresh1)
      else
        qthresh1=0.d0
      endif
*      write(6,*) qthresh1
      a=1.d0
      b=1.5d0*qf+AA/qf
      c=qf**2+2.d0*AA
      d=qf**3/4.d0+AA*qf+ompl**2/qf
      call croots(a,b,c,d,rt1,rt2,rt3,nrts)
      rt(1)=rt1
      rt(2)=rt2
      rt(3)=rt3
      b=-b
      d=-d
      call croots(a,b,c,d,rtt1,rtt2,rtt3,nrts2)
      rtt(1)=rtt1
      rtt(2)=rtt2
      rtt(3)=rtt3
      if (nrts.eq.1) then
 11     continue
          nflip=0
          do i=1,2
            if (dimag(rt(i)).lt.dimag(rt(i+1))) then
              qst=rt(i)
              rt(i)=rt(i+1)
              rt(i+1)=qst
              nflip=nflip+1
            endif
          enddo
        if (nflip.ne.0) goto 11
        q01=dble(rt(2))
      else
        xfact=sqrt(AA**2+(dble(rt(1))**2/2.d0)**2-ompl**2)-AA
        test1=dble(rt(1))-qf-sqrt(2.d0*xfact)
        xfact=sqrt(AA**2+(dble(rt(2))**2/2.d0)**2-ompl**2)-AA
        test2=dble(rt(2))-qf-sqrt(2.d0*xfact)
        xfact=sqrt(AA**2+(dble(rt(3))**2/2.d0)**2-ompl**2)-AA
        test3=dble(rt(3))-qf-sqrt(2.d0*xfact)
        if(test1.lt.test2.and.test1.lt.test3) then
          q01=dble(rt(1))
        elseif(test2.lt.test3) then
          q01=dble(rt(2))
        else
          q01=dble(rt(3))
        endif
      endif
      if (nrts2.eq.1) then
 12     continue
          nflip=0
          do i=1,2
            if (dimag(rtt(i)).lt.dimag(rtt(i+1))) then
              qst=rtt(i)
              rtt(i)=rtt(i+1)
              rtt(i+1)=qst
              nflip=nflip+1
            endif
          enddo
        if (nflip.ne.0) goto 12
        q02=dble(rtt(2))
      else
        xfact=sqrt(AA**2+(dble(rtt(1))**2/2.d0)**2-ompl**2)-AA
        test1=dble(rtt(1))+qf-sqrt(2.d0*xfact)
        xfact=sqrt(AA**2+(dble(rtt(2))**2/2.d0)**2-ompl**2)-AA
        test2=dble(rtt(2))+qf-sqrt(2.d0*xfact)
        xfact=sqrt(AA**2+(dble(rtt(3))**2/2.d0)**2-ompl**2)-AA
        test3=dble(rtt(3))+qf-sqrt(2.d0*xfact)
        if(test1.lt.test2.and.test1.lt.test3) then
          q02=dble(rt(1))
        elseif(test2.lt.test3) then
          q02=dble(rt(2))
        else
          q02=dble(rt(3))
        endif
      endif
*      write(6,*) q01,q02
      qthresh2=min(abs(q01),abs(q02))
*      write(6,*) qthresh1,qthresh2

      qh=1000.d0*qf
      ek=qthresh1**2/2.d0
      call qlimits(ek,qthresh1,ompl,AA,qh,nqa,q1a,q2a,q3a)
      q0a=0.d0
      w=ek-ef
      x=AA**2+w**2-ompl**2
      if (x.ge.0.d0) then
        y=-2.d0*AA+2.d0*dsqrt(x)
        if (y.ge.0.d0) then
          q0a=dsqrt(y)
        endif
      endif
      ek=qthresh2**2/2.d0
      call qlimits(ek,qthresh2,ompl,AA,qh,nqb,q1b,q2b,q3b)
      q0b=0.d0
      w=ek-ef
      x=AA**2+w**2-ompl**2
      if (x.ge.0.d0) then
        y=-2.d0*AA+2.d0*dsqrt(x)
        if (y.ge.0.d0) then
          q0b=dsqrt(y)
        endif
      endif

      if (nqa.eq.0) then
        qthresh=qthresh1
      elseif(abs(q1a-q2a).lt.abs(q1b-q0b)) then
        qthresh=qthresh1
      else
        qthresh=qthresh2
      endif
*      write(6,*) qthresh
      return
      end

      double precision function vpp2(q)
* the square of the coupling potential
* input: q - momentum or wavenumber
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ompl - zero q energy of mode
      implicit none
      double precision q,wdisp
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      external wdisp
      vpp2=2*pi*omp**2/(q**2*wdisp(q))
      return
      end

      subroutine qlimits(w,pk,omp,Ap,qh,nq,q1,q2,q3)
* finds the limiting q values of the inequalities
* omega(q)+(q-k)^2/2-omega < 0 
* omega(q)+(q+k)^2/2-omega > 0 and
* omega(q)-(q-k)^2/2+omega > 0
* for omega(q)^2 = omp^2+Ap q^2+q^4/4
* qh is the upper allowable value for q (usually set by omega(q)+E_f-omega < 0
* for the first two inequalities.
* input: energy w in atomic hartrees.
*        momentum pk in atomic units.
*        resonance frequency omp in hartrees.
*        dispersion parameter Ap.
*        upper limit qh.
* output: number of limiting q values (either 1 or 3).
*         limiting q values q1, q2,and q3
*         q1 and q2 bracket a region of allowed q values given by
*         the first two inequalities listed above,
*         q3 is the upper bound of the third inequality
      implicit none
      integer i,j,nar,nq
      double precision w,pk,omp,Ap,qh,q1,q2,q3,a,b,c,d
      double precision dev1,dev2,dev3,qa1,qa2,qa3,wdisp
      complex*16 aa1,aa2,aa3
      external wdisp
*      write(6,*) 'qlimits'
* find q for which omega(q)+(q-k)^2/2-omega = 0
      a=pk
      b=w+Ap-3.d0*pk**2/2.d0
      c=pk**3-2.d0*w*pk
      d=omp**2-w**2+w*pk**2-pk**4/4.d0
      call croots(a,b,c,d,aa1,aa2,aa3,nar)
* One of these roots is the solution of
* omega(q)-(q-k)^2/2+omega = 0.  This is q3.  The other two roots, if present,
* solve omega(q)+(q-k)^2/2-omega = 0
* It must hold that q>=0.  Fortunately, the symmetry of the inequalities
* means that solving omega(q)+(q+k)^2/2-omega = 0 gives roots which are the 
* negatives of the roots from the cubic we just solved.  It suffices to
* take the absolute value of the roots (if they are real) to give our
* limiting values of q.
      if (nar.eq.3) then
        qa1=dble(aa1)
        qa2=dble(aa2)
        qa3=dble(aa3)
        dev1=dabs(wdisp(qa1)+(qa1-pk)**2/2.d0-w)
        dev2=dabs(wdisp(qa2)+(qa2-pk)**2/2.d0-w)
        dev3=dabs(wdisp(qa3)+(qa3-pk)**2/2.d0-w)
        if (dev1.gt.dev2.and.dev1.gt.dev3) then
          q1=min(dabs(qa2),dabs(qa3))
          q2=max(dabs(qa2),dabs(qa3))
          q3=dabs(qa1)
        elseif(dev2.gt.dev3) then
          q1=min(dabs(qa1),dabs(qa3))
          q2=max(dabs(qa1),dabs(qa3))
          q3=dabs(qa2)
        else
          q1=min(dabs(qa1),dabs(qa2))
          q2=max(dabs(qa1),dabs(qa2))
          q3=dabs(qa3)
        endif
        q1=min(q1,qh)
        q2=min(q2,qh)
        nq=3
      else
* The equation omega(q)+(q-k)^2/2-omega = 0 has no real solutions.  The
* one real root of the cubic is q3. 
        q1=0.d0
        q2=0.d0
        qa1=dabs(dimag(aa1))
        qa2=dabs(dimag(aa2))
        qa3=dabs(dimag(aa3))
        if (qa1.lt.qa2.and.qa1.lt.qa3) then
          q3=dabs(dble(aa1))
        elseif (qa2.lt.qa3) then
          q3=dabs(dble(aa2))
        else
          q3=dabs(dble(aa3))
        endif
        nq=1
      endif
      return
      end
      subroutine renergies(w,rbeta)
* Calculates the real part of the photelectron self energy due to 
* pole ipl in the inverse dielectric function epsilon^{-1}.
* input: w - energy (omega)
* output: rbeta - the real part of the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - width of pole in epsilon^(-1)
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=ompl+adisp*q**2+q**4/4
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable
      implicit none
      integer i,npts,nnpts,nsing,numcal,maxns
      double precision w,rbeta,beta,rw1beta,grater,wmax,wmin,
     2                 abr,rlr,xsing,error,exchange,qmax
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision rseint1,rseint2,rseint3
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      integer lowq
      common /belowqf/ lowq
      external beta,rw1beta,grater,exchange,rseint1,rseint2,rseint3
      integer ijkwrite
      common /morewrite/ ijkwrite
      wp=w+ekp
      qmax=1.d2*dsqrt(ompl)+pk+qf
*     rlr for plasmon pole should be 10^-7 to eliminate numerical 
*     artifacts
      rlr=1.d-7
      abr=rlr/1.d3
      nsing=0
      if (pk.gt.qf) then
        rbeta=grater(rseint1,pk+qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        rbeta=rbeta+grater(rseint1,0.d0,pk-qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        rbeta=rbeta+grater(rseint2,pk-qf,pk+qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      elseif (pk.lt.qf) then
        rbeta=grater(rseint1,pk+qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        rbeta=rbeta+grater(rseint2,qf-pk,pk+qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        if (lowq.ne.0) rbeta=rbeta+grater(rseint3,0.d0,
     2             qf-pk,abr,rlr,nsing,xsing,error,numcal,maxns)
      else
        rbeta=grater(rseint1,2.d0*qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        rbeta=rbeta+grater(rseint2,0.d0,2.d0*qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      endif
      rbeta=-rbeta*omp**2/(2.d0*pi*pk)
*      rbeta=rbeta+exchange(pk)
      return
      end

      subroutine brsigma(w,rbeta,xibeta)
* Calculates the broadened photelectron self energy due to 
* pole ipl in the inverse dielectric function epsilon^{-1}.
* input: w - energy (omega)
* output: rbeta - the real part of the self energy
*         xibeta - the imaginary part of the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - linewidth of pole in epsilon^{-1}
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=ompl+adisp*q**2+q**4/4
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable
      implicit none
      integer i,npts,nnpts,nsing,numcal,maxns,nq,nqq
      parameter (nqq=5)
      double precision w,rbeta,xibeta,grater,qdisp,wmax,wmin,
     2                 abr,rlr,xsing(20),error
      double precision qmax,qlimh,qliml,qh,q0,q1,q2,q3,qsing(nqq)
      double precision sig1r,sig2r,sig3r,sig4r,sig5r,
     2                 sig6r,sig7r,sig8r,sig9r,sig10r,
     3                 sig1i,sig2i,sig3i,sig4i,sig5i,
     4                 sig6i,sig7i,sig8i,sig9i,sig10i
      double precision fqlogr1,fqlogr2,fqlogr3,fqlogr4,
     2                 fqlogi1,fqlogi2,fqlogi3,fqlogi4,
     3                 fqatnr1,fqatnr2,fqatnr3,fqatnr4,
     4                 fqatni1,fqatni2,fqatni3,fqatni4
      double complex cfact,csigma
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      integer iwrite,jj
      common /flag/ iwrite,jj
      integer lowq
      common /belowqf/ lowq
      external grater,qdisp,
     2         fqlogr1,fqlogr2,fqlogr3,fqlogr4,
     3         fqlogi1,fqlogi2,fqlogi3,fqlogi4,
     4         fqatnr1,fqatnr2,fqatnr3,fqatnr4,
     5         fqatni1,fqatni2,fqatni3,fqatni4
      wp=w+ekp
      qmax=1.d2*dsqrt(ompl)+pk+qf
*     rlr for plasmon pole should be 10^-7 to eliminate numerical 
*     artifacts
      rlr=1.d-7
      abr=rlr/1.d3
      qlimh=pk+qf
      qliml=abs(pk-qf)
      qh=qdisp(max(wp-ef,ompl))
      q0=qdisp(max(ef-wp,ompl))
      call qlimits(wp,pk,ompl,adisp,qmax,nq,q1,q2,q3)
      qsing(1)=q0
      qsing(2)=q1
      qsing(3)=q2
      qsing(4)=q3
      qsing(5)=qh
      sig1r=0.d0
      sig1i=0.d0
      sig2r=0.d0
      sig2i=0.d0
      sig3r=0.d0
      sig3i=0.d0
      sig4r=0.d0
      sig4i=0.d0
      sig5r=0.d0
      sig5i=0.d0
      sig6r=0.d0
      sig6i=0.d0
      sig7r=0.d0
      sig7i=0.d0
      sig8r=0.d0
      sig8i=0.d0
      sig9r=0.d0
      sig9i=0.d0
      sig10r=0.d0
      sig10i=0.d0
      call findsing(qlimh,qmax,nqq,qsing,nsing,xsing)
      sig1r=grater(fqlogr1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      sig1i=grater(fqlogi1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      sig2r=grater(fqatnr1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      sig2i=grater(fqatni1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      call findsing(qliml,qlimh,nqq,qsing,nsing,xsing)
      sig3r=grater(fqlogr2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      sig3i=grater(fqlogi2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      sig4r=grater(fqatnr2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      sig4i=grater(fqatni2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      if (lowq.ne.0) then
        sig7r=grater(fqlogr3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
        sig7i=grater(fqlogi3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
        sig8r=grater(fqatnr3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
        sig8i=grater(fqatni3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      endif
      call findsing(0.d0,qliml,nqq,qsing,nsing,xsing)
      if (pk.gt.qf) then
        sig5r=grater(fqlogr1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        sig5i=grater(fqlogi1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        sig6r=grater(fqatnr1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        sig6i=grater(fqatni1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      endif
      if (pk.lt.qf.and.lowq.ne.0) then
        sig9r=grater(fqlogr4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        sig9i=grater(fqlogi4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        sig10r=grater(fqatnr4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        sig10i=grater(fqatni4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      endif
      rbeta=(sig1r+sig3r+sig5r+sig7r+sig9r)*omp**2/(4.d0*pi*pk)
     2     +(sig2r+sig4r+sig6r+sig8r+sig10r)*omp**2/(2.d0*pi*pk)
      xibeta=(sig1i+sig3i+sig5i+sig7i+sig9i)*omp**2/(4.d0*pi*pk)
     2     -(sig2i+sig4i+sig6i+sig8i+sig10i)*omp**2/(2.d0*pi*pk)
      cfact=(1,0)-(brd/ompl)*(0,1)
      csigma=((1,0)*rbeta+(0,1)*xibeta)*cfact
      rbeta=dble(csigma)
      xibeta=dimag(csigma)
*      rbeta=rbeta+exchange(pk)
      return
      end

      double precision function fqlogr1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xlog=((pk-q)**2/2.d0-wp+wq)**2+(brd)**2
      xlog=xlog/(((pk+q)**2/2.d0-wp+wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogr1=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogi1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xlog=((pk-q)**2/2.d0-wp+wq)**2+(brd)**2
      xlog=xlog/(((pk+q)**2/2.d0-wp+wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogi1=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogr2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xlog=(ef-wp+wq)**2+(brd)**2
      xlog=xlog/(((pk+q)**2/2.d0-wp+wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogr2=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogi2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xlog=(ef-wp+wq)**2+(brd)**2
      xlog=xlog/(((pk+q)**2/2.d0-wp+wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogi2=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogr3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xlog=((pk-q)**2/2.d0-wp-wq)**2+(brd)**2
      xlog=xlog/((ef-wp-wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogr3=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogi3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xlog=((pk-q)**2/2.d0-wp-wq)**2+(brd)**2
      xlog=xlog/((ef-wp-wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogi3=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogr4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xlog=((pk-q)**2/2.d0-wp-wq)**2+(brd)**2
      xlog=xlog/(((pk+q)**2/2.d0-wp-wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogr4=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqlogi4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xlog=((pk-q)**2/2.d0-wp-wq)**2+(brd)**2
      xlog=xlog/(((pk+q)**2/2.d0-wp-wq)**2+(brd)**2)
      xlog=log(xlog)
      fqlogi4=xpole*xlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function fqatni1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xatan=atan((wp-wq-(pk-q)**2/2.d0)/brd)
      xatan=xatan-atan((wp-wq-(pk+q)**2/2.d0)/brd)
      fqatni1=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatnr1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xatan=atan((wp-wq-(pk-q)**2/2.d0)/brd)
      xatan=xatan-atan((wp-wq-(pk+q)**2/2.d0)/brd)
      fqatnr1=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatni2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xatan=atan((wp-wq-ef)/brd)
      xatan=xatan-atan((wp-wq-(pk+q)**2/2.d0)/brd)
      fqatni2=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatnr2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xatan=atan((wp-wq-ef)/brd)
      xatan=xatan-atan((wp-wq-(pk+q)**2/2.d0)/brd)
      fqatnr2=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatni3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xatan=atan((wp+wq-(pk-q)**2/2.d0)/brd)
      xatan=xatan-atan((wp+wq-ef)/brd)
      fqatni3=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatnr3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xatan=atan((wp+wq-(pk-q)**2/2.d0)/brd)
      xatan=xatan-atan((wp+wq-ef)/brd)
      fqatnr3=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatni4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xatan=atan((wp+wq-(pk-q)**2/2.d0)/brd)
      xatan=xatan-atan((wp+wq-(pk+q)**2/2.d0)/brd)
      fqatni4=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function fqatnr4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,xatan
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xatan=atan((wp+wq-(pk-q)**2/2.d0)/brd)
      xatan=xatan-atan((wp+wq-(pk+q)**2/2.d0)/brd)
      fqatnr4=xpole*xatan/dsqrt(q**2+omp*acc)
      return
      end

      subroutine dbrsigma(w,drbeta,dibeta)
* Calculates the derivative of the broadened photelectron self energy 
* with respect to frequency w due to 
* pole ipl in the inverse dielectric function epsilon^{-1}.
* input: w - energy (omega)
* output: drbeta - the real part of the self energy derivative
*         dibeta - the imaginary part of the self energy derivative
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - linewidth of pole in epsilon^{-1}
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=ompl+adisp*q**2+q**4/4
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable
      implicit none
      integer i,npts,nnpts,nsing,numcal,maxns,nq,nqq
      parameter (nqq=5)
      double precision w,drbeta,dibeta,grater,qdisp,wmax,wmin,
     2                 abr,rlr,xsing(20),error
      double precision qmax,qlimh,qliml,qh,q0,q1,q2,q3,qsing(nqq)
      double precision dsig1r,dsig2r,dsig3r,dsig4r,dsig5r,
     2                 dsig6r,dsig7r,dsig8r,dsig9r,dsig10r,
     3                 dsig1i,dsig2i,dsig3i,dsig4i,dsig5i,
     4                 dsig6i,dsig7i,dsig8i,dsig9i,dsig10i
      double precision fqlogr1,fqlogr2,fqlogr3,fqlogr4,
     2                 fqlogi1,fqlogi2,fqlogi3,fqlogi4,
     3                 fqatnr1,fqatnr2,fqatnr3,fqatnr4,
     4                 fqatni1,fqatni2,fqatni3,fqatni4
      double complex cfact,csigma
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      integer iwrite,jj
      common /flag/ iwrite,jj
      integer lowq
      common /belowqf/ lowq
      external grater,qdisp,
     2         dqlogr1,dqlogr2,dqlogr3,dqlogr4,
     3         dqlogi1,dqlogi2,dqlogi3,dqlogi4,
     4         dqatnr1,dqatnr2,dqatnr3,dqatnr4,
     5         dqatni1,dqatni2,dqatni3,dqatni4
      wp=w+ekp
      qmax=1.d2*dsqrt(ompl)+pk+qf
*     rlr for plasmon pole should be 10^-7 to eliminate numerical 
*     artifacts
      rlr=1.d-7
      abr=rlr/1.d3
      qlimh=pk+qf
      qliml=abs(pk-qf)
      qh=qdisp(max(wp-ef,ompl))
      q0=qdisp(max(ef-wp,ompl))
      call qlimits(wp,pk,ompl,adisp,qmax,nq,q1,q2,q3)
      qsing(1)=q0
      qsing(2)=q1
      qsing(3)=q2
      qsing(4)=q3
      qsing(5)=qh
      dsig1r=0.d0
      dsig1i=0.d0
      dsig2r=0.d0
      dsig2i=0.d0
      dsig3r=0.d0
      dsig3i=0.d0
      dsig4r=0.d0
      dsig4i=0.d0
      dsig5r=0.d0
      dsig5i=0.d0
      dsig6r=0.d0
      dsig6i=0.d0
      dsig7r=0.d0
      dsig7i=0.d0
      dsig8r=0.d0
      dsig8i=0.d0
      dsig9r=0.d0
      dsig9i=0.d0
      dsig10r=0.d0
      dsig10i=0.d0
      call findsing(qlimh,qmax,nqq,qsing,nsing,xsing)
      dsig1r=grater(dqlogr1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      dsig1i=grater(dqlogi1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      dsig2r=grater(dqatnr1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      dsig2i=grater(dqatni1,qlimh,qmax,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      call findsing(qliml,qlimh,nqq,qsing,nsing,xsing)
      dsig3r=grater(dqlogr2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      dsig3i=grater(dqlogi2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      dsig4r=grater(dqatnr2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      dsig4i=grater(dqatni2,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      if (lowq.ne.0) then
        dsig7r=grater(dqlogr3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
        dsig7i=grater(dqlogi3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
        dsig8r=grater(dqatnr3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
        dsig8i=grater(dqatni3,qliml,qlimh,abr,rlr,nsing,xsing,
     2           error,numcal,maxns)
      endif
      call findsing(0.d0,qliml,nqq,qsing,nsing,xsing)
      if (pk.gt.qf) then
        dsig5r=grater(dqlogr1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        dsig5i=grater(dqlogi1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        dsig6r=grater(dqatnr1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        dsig6i=grater(dqatni1,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      endif
      if (pk.lt.qf.and.lowq.ne.0) then
        dsig9r=grater(dqlogr4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        dsig9i=grater(dqlogi4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        dsig10r=grater(dqatnr4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        dsig10i=grater(dqatni4,0.d0,qliml,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      endif
      drbeta=(dsig1r+dsig3r+dsig5r+dsig7r+dsig9r)*omp**2/(2.d0*pi*pk)
     2     +(dsig2r+dsig4r+dsig6r+dsig8r+dsig10r)*omp**2/(2.d0*pi*pk)
      dibeta=(dsig1i+dsig3i+dsig5i+dsig7i+dsig9i)*omp**2/(2.d0*pi*pk)
     2     -(dsig2i+dsig4i+dsig6i+dsig8i+dsig10i)*omp**2/(2.d0*pi*pk)
      cfact=(1,0)-(brd/ompl)*(0,1)
      csigma=((1,0)*drbeta+(0,1)*dibeta)*cfact
      drbeta=dble(csigma)
      dibeta=dimag(csigma)
*      rbeta=rbeta+exchange(pk)
      return
      end

      double precision function dqlogr1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp-wq-(pk-q)**2/2.d0
      xw2=wp-wq-(pk+q)**2/2.d0
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogr1=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqlogi1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp-wq-(pk-q)**2/2.d0
      xw2=wp-wq-(pk+q)**2/2.d0
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogi1=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqlogr2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp-wq-ef
      xw2=wp-wq-(pk+q)**2/2.d0
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogr2=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqlogi2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp-wq-ef
      xw2=wp-wq-(pk+q)**2/2.d0
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogi2=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqlogr3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-ef
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogr3=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqlogi3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-ef
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogi3=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end


      double precision function dqlogr4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-(pk+q)**2/2.d0
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogr4=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqlogi4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxlog,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-(pk+q)**2/2.d0
      dxlog=xw1/((xw1)**2+(brd)**2)-xw2/((xw2)**2+(brd)**2)
      dqlogi4=xpole*dxlog/dsqrt(q**2+ompl*acc)
      return
      end

      double precision function dqatni1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp-wq-(pk-q)**2/2.d0
      xw2=wp-wq-(pk+q)**2/2.d0
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatni1=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatnr1(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp-wq-(pk-q)**2/2.d0
      xw2=wp-wq-(pk+q)**2/2.d0
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatnr1=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatni2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp-wq-ef
      xw2=wp-wq-(pk+q)**2/2.d0
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatni2=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatnr2(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp-wq-ef
      xw2=wp-wq-(pk+q)**2/2.d0
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatnr2=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatni3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-ef
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatni3=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatnr3(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-ef
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatnr3=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatni4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=wq/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-(pk+q)**2/2.d0
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatni4=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      double precision function dqatnr4(q)
* Integrand for one of the intergals in calculating the 
* self energy in subroutine brsigma.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
*      integer it1,it2,i
      double precision q,wq,xpole,dxatan,xw1,xw2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xpole=brd/(wq**2+brd**2)
      xw1=wp+wq-(pk-q)**2/2.d0
      xw2=wp+wq-(pk+q)**2/2.d0
      dxatan=brd/((xw1)**2+(brd)**2)-brd/((xw2)**2+(brd)**2)
      dqatnr4=xpole*dxatan/dsqrt(q**2+omp*acc)
      return
      end

      subroutine findsing(ql,qh,nqq,qsing,nsing,xsing)
* finds which values in the array qsing are between ql and qh, and puts
* them in the array xsing.  Returns number of elements in xsing as nsing
      implicit none
      integer i,j,k,nqq,nsing,it
      double precision ql,qh,qsing(nqq),xsing(20),store
      integer iwrite,jj
      common /flag/ iwrite,jj
      nsing=0
      do i=1,nqq
        if (qsing(i).gt.ql.and.qsing(i).lt.qh) then
          nsing=nsing+1
          xsing(nsing)=qsing(i)
        elseif (qsing(i).lt.ql.and.qsing(i).gt.qh) then
          nsing=nsing+1
          xsing(nsing)=qsing(i)
        endif
      enddo
      if (nsing.le.1) goto 40
      j=2
 20   k=j
 30   continue
      if (xsing(k-1).gt.xsing(k)) then
        store=xsing(k-1)
        xsing(k-1)=xsing(k)
        xsing(k)=store
        k=k-1
        if (k.gt.1) goto 30
      endif
      j=j+1
      if (j.le.nsing) goto 20
 40   return
      end

      double precision function exchange(qk)
* compute the HF exchange potential for the free electron gas
* input: qk - photoelectron momentum
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       qf - Fermi momentum
      implicit none
      integer i,ii,j,jj
      double precision qk
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      if (qk.eq.qf) then
        exchange=-qf/pi
      else
        exchange=-(1.d0/pi)*(qf+
     2  ((qf**2-qk**2)/(2.d0*qk))*log(dabs((qk+qf)/(qk-qf))))
      endif
      return
      end

      subroutine xienergies(w,xibeta)
* Calculates the imaginary part of the photelectron self energy.
* input: w - energy (omega)
* output: xibeta - the imaginary part of the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=ompl+adisp*q**2+q**4/4
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable
      implicit none
      integer i,npts,nnpts,nsing,numcal,maxns
      double precision w,xibeta,beta,xiw1beta,grater,wmax,wmin,
     2                 abr,rlr,xsing,error
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      integer lowq
      common /belowqf/ lowq
      external beta,xiw1beta,grater
      xibeta=-beta(w)*pi
      return
      end

      subroutine drenergies(w,drbeta)
* Calculates the real part of the derivative of the photelectron 
* self energy with respect to omega.
* input: w - energy (omega)
* output: drbeta - the imaginary part of the derivative of the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable
      implicit none
      integer i,npts,nnpts,nsing,numcal,maxns
      double precision w,drbeta,beta,grater,wmax,wmin,
     2                 abr,rlr,xsing,error,qmax
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision rseint1,rseint2,rseint3
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      integer lowq
      common /belowqf/ lowq
      external beta,grater,drseint1,drseint2,drseint3
      wp=w+ekp
      qmax=1.d2*dsqrt(ompl)
*     rlr for plasmon pole should be 10^-7 to eliminate numerical 
*     artifacts
      rlr=1.d-7
      abr=rlr/1.d3
      nsing=0
      if (pk.gt.qf) then
        drbeta=grater(drseint1,pk+qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        drbeta=drbeta+grater(drseint1,0.d0,pk-qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        drbeta=drbeta+grater(drseint2,pk-qf,pk+qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
      elseif (pk.lt.qf) then
        drbeta=grater(drseint1,pk+qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        drbeta=drbeta+grater(drseint2,qf-pk,pk+qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        if (lowq.ne.0) drbeta=drbeta+grater(drseint3,0.d0,
     2             qf-pk,abr,rlr,nsing,xsing,error,numcal,maxns)
      else
        drbeta=grater(drseint1,2.d0*qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        drbeta=drbeta+grater(drseint2,0.d0,2.d0*qf,abr,rlr,nsing,
     2             xsing,error,numcal,maxns)
      endif
      drbeta=drbeta*omp**2/(2.d0*pi*pk)
      return
      end

      subroutine dienergies(w,dibeta)
* Calculates the imaginary part of the derivative of the photelectron 
* self energy with respect to omega.
* input: w - energy (omega)
* output: dibeta - the imaginary part of the derivative of the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=ompl+adisp*q**2+q**4/4
      implicit none
      integer i,npts,nnpts
      double precision w,dibeta
      integer it1,it2,nq
      double precision qh,q1,q2,q3,q0,wh,wq1,wq2,wq3,wq0,qmax
* the q's are limiting values of momenta, the w's are energies
* corresponding to these limiting momenta
      double precision qdisp,A,wdisp,test1,test2
      double precision dq0dw,dq1dw,dq2dw,dq3dw,dqhdw,xfact
* the dqdw's are derivatives of the momentum limits with
* changing energy
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      integer lowq
      common /belowqf/ lowq
      external qdisp,wdisp
      A=adisp
      q1=0.d0
      q2=0.d0
      q3=0.d0
*      xfact=0.d0
      dibeta=0.d0
* Must find the momenta which limit the 
* final integration (done analytically).
* Find limit due to Fermi level
      qh=qdisp(max(w+ekp-ef,ompl))
      q0=qdisp(max(ef-w-ekp,ompl))
* Find roots of omega(q)-omega+(q-k)^2/2=0, omega(q)-omega+(q+k)^2/2=0,
* and omega(q)+omega-(k-q)^2/2=0 for q>0.
      qmax=1.d6*qf
      call qlimits(w+ekp,pk,ompl,A,qmax,nq,q1,q2,q3)
* find derivatives of q's
      wq1=wdisp(q1)
      if (w+ekp-ef.gt.ompl) then
        dqhdw=(w+ekp-ef)/(qh*dsqrt(A**2+(w+ekp-ef)**2-ompl**2))
        dq0dw=0.d0
      elseif(ef-w-ekp.gt.ompl) then
        dq0dw=-(ef-w-ekp)/(q0*dsqrt(A**2+(ef-w-ekp)**2-ompl**2))
        dqhdw=0.d0
      else
        dqhdw=0.d0
        dq0dw=0.d0
      endif
      test1=(pk+q1)**2/2.d0-(w+ekp)+wq1
      test2=(pk-q1)**2/2.d0-(w+ekp)+wq1
      if (q1.ge.qh) then
        q1=qh
        dq1dw=dqhdw
      elseif (dabs(test1).lt.dabs(test2)) then
        dq1dw=wq1/((q1+pk)*wq1+A*q1+q1**3/2.d0)
      else
        dq1dw=wq1/((q1-pk)*wq1+A*q1+q1**3/2.d0)
      endif
      wq2=wdisp(q2)
      test1=(pk+q2)**2/2.d0-(w+ekp)+wq2
      test2=(pk-q2)**2/2.d0-(w+ekp)+wq2
      if (q2.ge.qh) then
        q2=qh
        dq2dw=dqhdw
      elseif (dabs(test1).lt.dabs(test2)) then
        dq2dw=wq2/((q2+pk)*wq2+A*q2+q2**3/2.d0)
      else
        dq2dw=wq2/((q2-pk)*wq2+A*q2+q2**3/2.d0)
      endif
      wq3=wdisp(q3)
      test1=(pk+q3)**2/2.d0-(w+ekp)-wq3
      test2=(pk-q3)**2/2.d0-(w+ekp)-wq3
      if (q3.ge.q0) then
        q3=q0
        dq3dw=dq0dw
      elseif (dabs(test1).lt.dabs(test2)) then
        dq3dw=wq3/((q3+pk)*wq3-A*q3-q3**3/2.d0)
      else
        dq3dw=wq3/((q3-pk)*wq3-A*q3-q3**3/2.d0)
      endif
* find derivative of imaginary part of self energy
* find contributions from above Fermi momentum
      if (nq.eq.3) then
        q1=dsqrt(q1**2+acc*ompl)
        q2=dsqrt(q2**2+acc*ompl)
        wq1=wdisp(q1)
        wq2=wdisp(q2)
        xfact=A*q1*(1.d0/wq1+1.d0/ompl)+q1**3/(2.d0*wq1)
        xfact=2.d0/q1-xfact/(ompl+wq1+A*q1**2/(2.d0*ompl))
        dibeta=dibeta+omp**2/(4.d0*pk*ompl)*dq1dw*xfact
        xfact=A*q2*(1.d0/wq2+1.d0/ompl)+q2**3/(2.d0*wq2)
        xfact=2.d0/q2-xfact/(ompl+wq2+A*q2**2/(2.d0*ompl))
        dibeta=dibeta-omp**2/(4.d0*pk*ompl)*dq2dw*xfact
      endif
* find contributions from below Fermi momentum
      if (q3.lt.q0.and.lowq.ne.0) then
        q0=dsqrt(q0**2+acc*ompl)
        q3=dsqrt(q3**2+acc*ompl)
        wq0=wdisp(q0)
        wq3=wdisp(q3)
        xfact=A*q0*(1.d0/wq0+1.d0/ompl)+q0**3/(2.d0*wq0)
        xfact=2.d0/q0-xfact/(ompl+wq0+A*q0**2/(2.d0*ompl))
        dibeta=dibeta+omp**2/(4.d0*pk*ompl)*dq0dw*xfact
        xfact=A*q3*(1.d0/wq3+1.d0/ompl)+q3**3/(2.d0*wq3)
        xfact=2.d0/q3-xfact/(ompl+wq3+A*q3**2/(2.d0*ompl))
        dibeta=dibeta-omp**2/(4.d0*pk*ompl)*dq3dw*xfact
      endif
      dibeta=dibeta
* Test that dibeta is a number (stop for nan results).
      it1=int(dibeta)
      it2=int(2.d0*dibeta)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'dienergies ',dibeta
        stop
      endif
      dibeta=dibeta
      return
      end

      subroutine d2renergies(w,d2rbeta)
* Calculates the real part of the second derivative of the photelectron 
* self energy with respect to omega.
* input: w - energy (omega)
* output: d2rbeta - the real part of the second derivative of the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable
      implicit none
      integer i,npts,nnpts,nsing,numcal,maxns
      double precision w,d2rbeta,beta,grater,wmax,wmin,
     2                 abr,rlr,xsing,error,qmax
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision d2rseint1,d2rseint2,d2rseint3
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      integer lowq
      common /belowqf/ lowq
      external beta,grater,d2rseint1,d2rseint2,d2rseint3
      wp=w+ekp
      wmin=-100*(pi*beta(0.d0)+ompl)+w
      wmax=100*(pi*beta(0.d0)+ompl)+w
      qmax=1.d2*dsqrt(ompl)
*     rlr for plasmon pole should be 10^-7 to eliminate numerical 
*     artifacts
      rlr=1.d-7
      abr=rlr/1.d3
      nsing=0
      if (pk.gt.qf) then
        d2rbeta=grater(d2rseint1,pk+qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        d2rbeta=d2rbeta+grater(d2rseint1,0.d0,pk-qf,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        d2rbeta=d2rbeta+grater(d2rseint2,pk-qf,pk+qf,abr,rlr,nsing,
     2             xsing,error,numcal,maxns)
      elseif (pk.lt.qf) then
        d2rbeta=grater(d2rseint1,pk+qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        d2rbeta=d2rbeta+grater(d2rseint2,qf-pk,pk+qf,abr,rlr,nsing,
     2             xsing,error,numcal,maxns)
        if (lowq.ne.0) d2rbeta=d2rbeta+grater(d2rseint3,0.d0,
     2             qf-pk,abr,rlr,nsing,xsing,error,numcal,maxns)
      else
        d2rbeta=grater(d2rseint1,2.d0*qf,qmax,abr,rlr,nsing,xsing,
     2             error,numcal,maxns)
        d2rbeta=d2rbeta+grater(d2rseint2,0.d0,2.d0*qf,abr,rlr,nsing,
     2             xsing,error,numcal,maxns)
      endif
      d2rbeta=d2rbeta*omp**2/(2.d0*pi*pk)
      return
      end

      subroutine d2ienergies(w,d2ibeta)
* Calculates the imaginary part of the second derivative of the photelectron 
* self energy with respect to omega.
* input: w - energy (omega)
* output: d2ibeta - the imaginary part of the second derivative of 
*                   the self energy
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
      implicit none
      integer i,npts,nnpts
      double precision w,d2ibeta
      integer it1,it2,nq
      double precision qh,q1,q2,q3,q0,wh,wq1,wq2,wq3,wq0,qmax
* the q's are limiting values of momenta, the w's are energies
* corresponding to these limiting momenta
      double precision qdisp,A,wdisp,test1,test2,www,d2fact,xfact
      double precision dq0dw,dq1dw,dq2dw,dq3dw,dqhdw,dwqdw
* the dqdw's are derivatives of the momentum limits with
* changing energy
      double precision d2q0dw2,d2q1dw2,d2q2dw2,d2q3dw2,d2qhdw2
* the d2qdw2's are second derivatives of the momentum limits with
* changing energy (but you've already figured that out by now, right?)
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      integer lowq
      common /belowqf/ lowq
      external qdisp,wdisp,d2fact
      A=adisp
      q1=0.d0
      q2=0.d0
      q3=0.d0
      d2ibeta=0.d0
* Must find the momenta which limit the 
* final integration (done analytically).
* Find limit due to Fermi level
      qh=qdisp(max(w+ekp-ef,ompl))
      q0=qdisp(max(ef-w-ekp,ompl))
* Find roots of omega(q)-omega+(q-k)^2/2=0, omega(q)-omega+(q+k)^2/2=0,
* and omega(q)+omega-(k-q)^2/2=0 for q>0.
      qmax=1.d6*qf
      call qlimits(w+ekp,pk,ompl,A,qmax,nq,q1,q2,q3)
* find derivatives of q's
      wq1=wdisp(q1)
      if (w+ekp-ef.gt.ompl) then
        www=A**2+(w+ekp-ef)**2-ompl**2
        dqhdw=(w+ekp-ef)/(qh*dsqrt(www))
        dq0dw=0.d0
        d2qhdw2=1/(qh*dsqrt(www))-(w+ekp-ef)**2/(qh*dsqrt(www)**3)
     2          -(w+ekp-ef)*dqhdw/(qh**2*dsqrt(www))
        d2q0dw2=0.d0
      elseif(ef-w-ekp.gt.ompl) then
        www=A**2+(w+ekp-ef)**2-ompl**2
        dq0dw=(w+ekp-ef)/(q0*dsqrt(www))
        dqhdw=0.d0
        d2q0dw2=1/(q0*dsqrt(www))-(w+ekp-ef)**2/(q0*dsqrt(www)**3)
     2          -(w+ekp-ef)*dq0dw/(q0**2*dsqrt(www))
        d2qhdw2=0.d0
      else
        dqhdw=0.d0
        dq0dw=0.d0
        d2qhdw2=0.d0
        d2q0dw2=0.d0
      endif
      test1=(pk+q1)**2/2.d0-(w+ekp)+wq1
      test2=(pk-q1)**2/2.d0-(w+ekp)+wq1
      if (q1.ge.qh) then
        q1=qh
        dq1dw=dqhdw
        d2q1dw2=d2qhdw2
      elseif (dabs(test1).lt.dabs(test2)) then
        dq1dw=wq1/((q1+pk)*wq1+A*q1+q1**3/2.d0)
        dwqdw=(A*q1+q1**3/2.d0)/wq1*dq1dw
        d2q1dw2=dwqdw/((q1+pk)*wq1+A*q1+q1**3/2.d0)
     2  -wq1/((q1+pk)*wq1+A*q1+q1**3/2.d0)
     3  *((wq1+A+3*q1**2/2.d0)*dq1dw+(q1+pk)*dwqdw)
      else
        dq1dw=wq1/((q1-pk)*wq1+A*q1+q1**3/2.d0)
        dwqdw=(A*q1+q1**3/2.d0)/wq1*dq1dw
        d2q1dw2=dwqdw/((q1-pk)*wq1+A*q1+q1**3/2.d0)
     2  -wq1/((q1-pk)*wq1+A*q1+q1**3/2.d0)
     3  *((wq1+A+3*q1**2/2.d0)*dq1dw+(q1-pk)*dwqdw)
      endif
      wq2=wdisp(q2)
      test1=(pk+q2)**2/2.d0-(w+ekp)+wq2
      test2=(pk-q2)**2/2.d0-(w+ekp)+wq2
      if (q2.ge.qh) then
        q2=qh
        dq2dw=dqhdw
        d2q2dw2=d2qhdw2
      elseif (dabs(test1).lt.dabs(test2)) then
        dq2dw=wq2/((q2+pk)*wq2+A*q2+q2**3/2.d0)
        dwqdw=(A*q2+q2**3/2.d0)/wq2*dq2dw
        d2q2dw2=dwqdw/((q2+pk)*wq2+A*q2+q2**3/2.d0)
     2  -wq2/((q2+pk)*wq2+A*q2+q2**3/2.d0)
     3  *((wq2+A+3*q2**2/2.d0)*dq2dw+(q2+pk)*dwqdw)
      else
        dq2dw=wq2/((q2-pk)*wq2+A*q2+q2**3/2.d0)
        dwqdw=(A*q2+q2**3/2.d0)/wq2*dq2dw
        d2q2dw2=dwqdw/((q2-pk)*wq2+A*q2+q2**3/2.d0)
     2  -wq2/((q2-pk)*wq2+A*q2+q2**3/2.d0)
     3  *((wq2+A+3*q2**2/2.d0)*dq2dw+(q2-pk)*dwqdw)
      endif
      wq3=wdisp(q3)
      test1=(pk+q3)**2/2.d0-(w+ekp)-wq3
      test2=(pk-q3)**2/2.d0-(w+ekp)-wq3
      if (q3.ge.q0) then
        q3=q0
        dq3dw=dq0dw
        d2q3dw2=d2q0dw2
      elseif (dabs(test1).lt.dabs(test2)) then
        dq3dw=wq3/((q3+pk)*wq3-A*q3-q3**3/2.d0)
        dwqdw=(A*q3+q3**3/2.d0)/wq3*dq3dw
        d2q3dw2=dwqdw/((q3+pk)*wq3-A*q3-q3**3/2.d0)
     2  -wq3/((q3+pk)*wq3-A*q3-q3**3/2.d0)
     3  *((wq3-A-3*q3**2/2.d0)*dq3dw+(q3+pk)*dwqdw)
      else
        dq3dw=wq3/((q3-pk)*wq3-A*q3-q3**3/2.d0)
        dwqdw=(A*q3+q3**3/2.d0)/wq3*dq3dw
        d2q3dw2=dwqdw/((q3-pk)*wq3-A*q3-q3**3/2.d0)
     2  -wq3/((q3-pk)*wq3-A*q3-q3**3/2.d0)
     3  *((wq3-A-3*q3**2/2.d0)*dq3dw+(q3-pk)*dwqdw)
      endif
* find second derivative of imaginary part of self energy
* find contributions from above Fermi momentum
      if (nq.eq.3) then
        q1=dsqrt(q1**2+acc*ompl)
        q2=dsqrt(q2**2+acc*ompl)
        wq1=wdisp(q1)
        wq2=wdisp(q2)
        d2ibeta=d2ibeta+d2fact(q1,wq1,dq1dw,d2q1dw2)
        d2ibeta=d2ibeta-d2fact(q2,wq2,dq2dw,d2q2dw2)
      endif
* find contributions from below Fermi momentum
      if (q3.lt.q0.and.lowq.ne.0) then
        q0=dsqrt(q0**2+acc*ompl)
        q3=dsqrt(q3**2+acc*ompl)
        wq0=wdisp(q0)
        wq3=wdisp(q3)
        d2ibeta=d2ibeta+d2fact(q0,wq0,dq0dw,d2q0dw2)
        d2ibeta=d2ibeta-d2fact(q3,wq3,dq3dw,d2q3dw2)
      endif
* Test that d2ibeta is a number (stop for nan results).
      it1=int(d2ibeta)
      it2=int(2.d0*d2ibeta)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'd2ienergies ',d2ibeta
        stop
      endif
      d2ibeta=d2ibeta
      return
      end

      double precision function d2fact(q,wq,dqdw,d2qdw2)
* the terms in a sum used to calculate the imaginary part of
* the second derivative of the self energy in the subroutine
* d2ienergies.
* input: q - momentum limit
*        wq - energy corresponding to q
*        dqdw - derivative of momentum limit with respect to energy
*        d2qdw2 - second derviative of momentum limit
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
      implicit none
      double precision q,wq,dqdw,d2qdw2,xfact1,xfact2,dwqdw
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,A
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,A
      dwqdw=(A*q+q**3/2.d0)/wq*dqdw
      xfact1=((A*(1.d0/wq+1.d0/ompl)+3.d0*q**2/(2.d0*wq))*dqdw
     2  -dwqdw*(q**3+2.d0*A*q)/(2*wq**2))
     3  /(ompl+wq+A*q**2/(2.d0*ompl))
      xfact1=-xfact1+(dwqdw+A*q*dqdw/ompl)
     2  *(A*q*(1.d0/wq+1.d0/ompl)+q**3/(2.d0*wq))
     3  /(ompl+wq+A*q**2/(2.d0*ompl))**2
      xfact1=xfact1-2.d0*dqdw/q**2
      xfact2=A*q*(1.d0/wq+1.d0/ompl)+q**3/(2.d0*wq)
      xfact2=2.d0/q-xfact2/(ompl+wq+A*q**2/(2.d0*ompl))
      d2fact=omp**2/(4.d0*pk*ompl)*(dqdw*xfact1+d2qdw2*xfact2)
      return
      end

      double precision function rseint1(q)
* Integrand for one of the intergals in calculating the real part
* of the self energy in subroutine renergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      integer ijkwrite
      common /morewrite/ ijkwrite
      wq=wdisp(q)
      xlog=((pk+q)**2/2.d0-wp+wq)**2+(acc*ompl)**2
      xlog=xlog/(((pk-q)**2/2.d0-wp+wq)**2+(acc*ompl)**2)
      xlog=log(xlog)/2.d0
      rseint1=xlog/(wq*dsqrt(q**2+ompl*acc))
** NAN detector
*      it1=int(rseint1)
*      it2=int(2.d0*rseint1)
*      if (it1.eq.it2.and.it1.gt.5) then
*        write(6,*) 'rseint1 ',rseint1,q,wq,xlog,wp,pk,acc,ompl
*        stop
*      endif
      return
      end

      double precision function rseint2(q)
* Integrand for one of the intergals in calculating the real part
* of the self energy in subroutine renergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      integer lowq
      common /belowqf/ lowq
      external qdisp,wdisp
      wq=wdisp(q)
      xlog=1.d0
      if (lowq.ne.0) then
        xlog=(ef-wp-wq)**2+(acc*ompl)**2
        xlog=xlog/(((pk-q)**2/2.d0-wp-wq)**2+(acc*ompl)**2)
      endif
      xlog=xlog*(((pk+q)**2/2.d0-wp+wq)**2+(acc*ompl)**2)
      xlog=xlog/((ef-wp+wq)**2+(acc*ompl)**2)
      xlog=log(xlog)/2.d0
      rseint2=xlog/(wq*dsqrt(q**2+ompl*acc))
** NAN detector
*      it1=int(rseint2)
*      it2=int(2.d0*rseint2)
*      if (it1.eq.it2.and.it1.gt.5) then
*        write(6,*) 'rseint2 ',rseint2,q,wq,xlog,wp,pk,acc,ompl
*        stop
*      endif
      return
      end

      double precision function rseint3(q)
* Integrand for one of the intergals in calculating the real part
* of the self energy in subroutine renergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xlog
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xlog=((pk+q)**2/2.d0-wp-wq)**2+(acc*ompl)**2
      xlog=xlog/(((pk-q)**2/2.d0-wp-wq)**2+(acc*ompl)**2)
      xlog=log(xlog)/2.d0
      rseint3=xlog/(wq*dsqrt(q**2+ompl*acc))
** NAN detector
*      it1=int(rseint3)
*      it2=int(2.d0*rseint3)
*      if (it1.eq.it2.and.it1.gt.5) then
*        write(6,*) 'rseint3 ',rseint3,q,wq,xlog,wp,pk,acc,ompl
*        stop
*      endif
      return
      end

      double precision function drseint1(q)
* Integrand for one of the intergals in calculating the derivative 
* of the real part of the self energy in subroutine drenergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xfact,xnum1,xnum2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xnum1=(pk+q)**2/2.d0-wp+wq
      xfact=xnum1/(xnum1**2+brd**2)
      xnum2=(pk-q)**2/2.d0-wp+wq
      xfact=xfact-xnum2/(xnum2**2+brd**2)
      drseint1=xfact/(wq*dsqrt(q**2+ompl*acc))
      it1=int(drseint1)
      it2=int(2.d0*drseint1)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'drseint1 ',drseint1,q,wq,xfact,wp,pk,acc,ompl
        stop
      endif
      return
      end

      double precision function drseint2(q)
* Integrand for one of the intergals in calculating the derivative 
* of the real part of the self energy in subroutine drenergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xfact,xnum1,xnum2,xnum3,xnum4
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      integer lowq
      common /belowqf/ lowq
      external qdisp,wdisp
      wq=wdisp(q)
      xfact=0.d0
      if (lowq.ne.0) then
        xnum1=ef-wp-wq
        xfact=xnum1/(xnum1**2+brd**2)
        xnum2=(pk-q)**2/2.d0-wp-wq
        xfact=xfact-xnum2/(xnum2**2+brd**2)
      endif
      xnum3=(pk+q)**2/2.d0-wp+wq
      xfact=xfact+xnum3/(xnum3**2+brd**2)
      xnum4=ef-wp+wq
      xfact=xfact-xnum4/(xnum4**2+brd**2)
      drseint2=xfact/(wq*dsqrt(q**2+ompl*acc))
      it1=int(drseint2)
      it2=int(2.d0*drseint2)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'drseint2 ',drseint2,q,wq,xfact,wp,pk,acc,ompl
        stop
      endif
      return
      end

      double precision function drseint3(q)
* Integrand for one of the intergals in calculating the derivative 
* of the real part of the self energy in subroutine drenergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xfact,xnum1,xnum2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xnum1=(pk+q)**2/2.d0-wp-wq
      xfact=xnum1/(xnum1**2+brd**2)
      xnum2=(pk-q)**2/2.d0-wp-wq
      xfact=xfact-xnum2/sqrt(xnum2**2+brd**2)
      drseint3=xfact/(wq*dsqrt(q**2+ompl*acc))
      it1=int(drseint3)
      it2=int(2.d0*drseint3)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'drseint3 ',drseint3,q,wq,xfact,wp,pk,acc,ompl
        stop
      endif
      return
      end

      double precision function d2rseint1(q)
* Integrand for one of the intergals in calculating the second derivative 
* of the real part of the self energy in subroutine d2renergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xfact,xnum1,xnum2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xnum1=(pk+q)**2/2.d0-wp+wq
      xfact=(xnum1**2-brd**2)/(xnum1**2+brd**2)**2
      xnum2=(pk-q)**2/2.d0-wp+wq
      xfact=xfact-(xnum2**2-brd**2)/(xnum2**2+brd**2)**2
      d2rseint1=xfact/(wq*dsqrt(q**2+ompl*acc))
      it1=int(d2rseint1)
      it2=int(2.d0*d2rseint1)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'd2rseint1 ',d2rseint1,q,wq,xfact,wp,pk,acc,ompl
        stop
      endif
      return
      end

      double precision function d2rseint2(q)
* Integrand for one of the intergals in calculating the second derivative 
* of the real part of the self energy in subroutine d2renergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xfact,xnum1,xnum2,xnum3,xnum4
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      integer lowq
      common /belowqf/ lowq
      external qdisp,wdisp
      wq=wdisp(q)
      xfact=0.d0
      if (lowq.ne.0) then
        xnum1=ef-wp-wq
        xfact=(xnum1**2-brd**2)/(xnum1**2+brd**2)**2
        xnum2=(pk-q)**2/2.d0-wp-wq
        xfact=xfact-(xnum2**2-brd**2)/(xnum2**2+brd**2)**2
      endif
      xnum3=(pk+q)**2/2.d0-wp+wq
      xfact=xfact+(xnum3**2-brd**2)/(xnum3**2+brd**2)**2
      xnum4=ef-wp+wq
      xfact=xfact-(xnum4**2-brd**2)/(xnum4**2+brd**2)**2
      d2rseint2=xfact/(wq*dsqrt(q**2+ompl*acc))
      it1=int(d2rseint2)
      it2=int(2.d0*d2rseint2)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'd2rseint2 ',d2rseint2
        stop
      endif
      return
      end

      double precision function d2rseint3(q)
* Integrand for one of the intergals in calculating the second derivative 
* of the real part of the self energy in subroutine d2renergies.
* input: q - momentum (variable to be integrated over)
* input from common blocks
*       ompl - energy of pole ipl in epsilon^{-1}
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
* common block control of subprograms
*       ac2 - additional accuracy parameter
*       wp - omega prime, an additional energy variable to be held
*            constant durring the integration
      implicit none
      integer it1,it2,i
      double precision q,wq,xfact,xnum1,xnum2
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      double precision ac2,wp
      common /ff/ ac2,wp
      double precision qdisp,wdisp
      external qdisp,wdisp
      wq=wdisp(q)
      xnum1=(pk+q)**2/2.d0-wp-wq
      xfact=(xnum1**2-brd**2)/(xnum1**2+brd**2)**2
      xnum2=(pk-q)**2/2.d0-wp-wq
      xfact=xfact-(xnum2**2-brd**2)/sqrt(xnum2**2+brd**2)**2
      d2rseint3=xfact/(wq*dsqrt(q**2+ompl*acc))
      it1=int(d2rseint3)
      it2=int(2.d0*d2rseint3)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'd2rseint3 ',d2rseint3
        stop
      endif
      return
      end

      double precision function beta(w)
* the extrinsic beta function
* beta(k,w)=(1/pi)*|Im(self energy(k,w+(k^2)/2))|*theta((w+(k^2)/2)-xmu)
* input: w - energy (omega)
* input from common blocks
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       xmu - chemical potential = Fermi energy + self consistent 
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole ipl in epsilon^{-1}
*       wt - weight of pole ipl in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of 
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       pk - photoelectron momentum
*       acc - global accuracy parameter 
*       brd - global broadening parameter to stabilize logarithms
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
      implicit none
      integer it1,it2,nq,i
      double precision w,q1,q2,q3,wth,wq0,wq1,wq2,wq3
      double precision q0,qh,qdisp,A,wdisp
      double precision pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
      common /convsf/ pi,ef,xmu,qf,omp,ompl,wt,ekp,ek,pk,acc,brd,adisp
*      common /temp/ q1,q2
      integer lowq
      common /belowqf/ lowq
      external qdisp,wdisp
      A=adisp
      q1=0.d0
      q2=0.d0
* Must find the momenta which limit the
* final integration (done analytically).
      beta=0.d0
* Find limit due to Fermi level
      qh=qdisp(max(w+ekp-ef,ompl))
      q0=qdisp(max(ef-w-ekp,ompl))
* Find roots of omega(q)-omega+(q-k)^2/2=0, omega(q)-omega+(q+k)^2/2=0,
* and omega(q)+omega-(k-q)^2/2=0.
      call qlimits(w+ekp,pk,ompl,A,qh,nq,q1,q2,q3)
* Calculate beta
* Calculate contributions from above Fermi momentum
      if (nq.eq.3) then
        q1=dsqrt(q1**2+acc*ompl)
        q2=dsqrt(q2**2+acc*ompl)
        wq1=wdisp(q1)
        wq2=wdisp(q2)
        beta=beta+omp**2/(4*pi*pk*ompl)
     2       *dlog(q2**2/(ompl+wq2+A*q2**2/(2.d0*ompl))
     2       *(ompl+wq1+A*q1**2/(2.d0*ompl))/q1**2)
*        beta=beta+ompl/(4*pi*pk)
*     2       *dlog(q2**2/(ompl+wq2+A*q2**2/(2.d0*ompl)))
      endif
* Calculate contributions from below Fermi momentum
      if (q3.lt.q0.and.lowq.ne.0) then
        q0=dsqrt(q0**2+acc*ompl)
        q3=dsqrt(q3**2+acc*ompl)
        wq0=wdisp(q0)
        wq3=wdisp(q3)
        beta=beta-omp**2/(4*pi*pk*ompl)
     2       *dlog(q0**2/(ompl+wq0+A*q0**2/(2.d0*ompl))
     2       *(ompl+wq3+A*q3**2/(2.d0*ompl))/q3**2)
      endif
* Test that beta is a number (stop for nan results).
      it1=int(beta)
      it2=int(2.d0*beta)
      if (it1.eq.it2.and.it1.gt.5) then
        write(6,*) 'beta ',beta,q1,q2,q3,q0
        write(6,*) 'beta ',pk,w,ekp,acc,ompl
        write(6,*) nq
        write(6,*) q1,q2
        stop
      endif
      return
      end
      
* Program so2conv, by Luke Campbell (2002)

      subroutine so2conv (ispec, ipr6, ipse, ipsk, wsigk, cen, cfname)

* This program computes many body effects on an XAS spectrum given in
* one or more FEFF output files of the form chi.dat,chipnnnn.dat,
* xmu.dat, or feffnnnn.dat.  The files read are from the most recent FEFF 
* from the directory in which this (sub) program is run, as determined
* by the files feff.inp and list.dat.  The files are overwritten
* with the computed spectra corrected for many body effects.

      implicit none
      integer npts,npts2,j,nsfpts,nqpts,maxfiles,ifiles,ifeffct
*      parameter(npts=400,npts2=401,nsfpts=80,nqpts=66,maxfiles=200)
      parameter(npts=400,npts2=401,nsfpts=112,nqpts=66,maxfiles=200)
*       npts - The number of points of the uniform energy grid used for 
*              the spectral function.
*       npts2 - The maximum number of data points in the data files
*       j - Used to store the number of data points in a data file.
*       nsfpts - Number of points of the minimal energy grid used for 
*              the spectral function.
*       nqpts - Number of points in the minimal momentum grid used for
*              the spectral function.
*       maxfiles - The maximum expected number of FEFF files to be read.
*       ifiles - The actual number of FEFF files specified.
*       ifeffct - Number of data points in a feffnnnn.dat file.
      integer i,ii,jj,ik,ikk,ipl
*       i,ii,jj,ik,ikk,ipl - counters for loops.
      integer last,lfirst,isearch,ifirst(maxfiles),ilast(maxfiles)
*       last - Collum number of last non-blank character in text string.
*       lfirst - Collum number of first non-blank character in text string.
*       isearch - Another counter for loops, used in text string searches.
*       ifirst - Collum number of start of file name.
*       ilast - Collum number of end of file name.
      integer ispec,ipr6
*       ispec - Identifies type of spectroscopy.  0 for EXAFS, 1 for XANES.
*       ipr6 - Identifes which files need to be convoluted.
      integer iwrite,iwrite2,intout,iwrconv,iwrcfile,iout,ipw,
     2        ipwc,ipse,ipsk
      double precision cen,den,den2
      character*12 cfname
*       iwrite - Write the spectral function and self energy 
*              to a file at this point on the minimal grid.
*       iwrite2 - Write the spectral function to a file at this point 
*              on the uniform grid.
*       intout - Set to one to write out the running integration of 
*              the convolution with the spectral function.
*       iwrconv - The data point at which the running integration is
*              to be written.
*       iwrcfile - The file for which the running integration is to be 
*              written.
*       ipw - Set greater than zero to write a file of integrated spectral
*              weights.
*       ipwc - Set greater than zero to write a file of integrated spectra
*              weights with the extrinsic spectral function separated into
*              quasiparticle and satellite terms.
*       ipse - Set greater to zero to write a file of the on shell
*              self energy.
*       ipsk - Set greater than zero to write the spectral function 
*              and self energy at a specified momentum.
*       iout - Flags whether the file specfunct.dat needs to
*              be created.
*       cen -  closest energy point to write out running convolution
*       den -  difference in gridpoint energy and cen (above)
*       cfname - name of file shown in running convolution (NULL if none)
      double precision wsigk
*       wsigk - Momentum at which to write self energy file if 
*              ipsk specified.
      integer iedge,ios,itype(maxfiles),iasym,iasymt,isattype,isattypt,
     2        icut,nleg,npi
*       iedge - Pointer to the Fermi energy in xmu.dat.
*       ios - Greater than 1 upon failure to open a file.
*       itype - Identifies type of file read.
*       iasym - Set to 1 to include quasiparticle phase as an
*              asymmetric 1/omega term to the extrinsic satellite
*              rather than as a complex spectral weight.  This is
*              necessary when convoluting with a real valued
*              function or one whose imaginary part is not known as
*              is the case with the xmu.dat file.
*       iasymt - Check if spectral function read from file uses
*              the same method of calculating the quasiparticle phase.
*       isattype - Indicates what approximations to use for 
*              satellite.
*       isattypt - Check if spectral function read from file uses
*              the same approximation.
*       icut - Set to 0 to avoid cutting off the spectral function at
*              energies where excitations are energetically forbidden
*              in the convolution.
*       nleg - Number of legs in the scattering path, not used for 
*              any calculations.
*       npi - Number of 2 pi jumps in phase.
      integer ipath,nlegs
*       Data from file list.dat.  Only ipath is used.
*       ipath - Path index.
      double precision sig2,ampratio,reff
*       Data from file list.dat.  Not used in this program except 
*       as dummy variables.
      character*80 cfirst,cinp,cblankl
      character*12 cfile(maxfiles)
      character*4 cpath
*       cfirst - Lines from FEFF files.
*       cinp - Lines from so2conv.inp.
*       cblankl - A long line of blanks.
*       cfile - The names of the FEFF files to read.
*       cpath - text containing path index
      character*20 cblanks
*       cblanks - A short line of blanks.
      character*10 vintx,mutx
*       Text containing the interstitial potential and the chemical
*       potential, respectively.
      character*9 gchtx,kftx
*       Text containing the core hole lifetime and the Fermi level,
*       respectively.
      character*5 rstx
*       Text containing the interstitial electron density parameter R_s.
      double precision aangstrom,eV
*       Conversion constants.
      parameter (aangstrom=1.d0/0.52917706d0,eV=1.d0/27.21160d0)
      double precision dw,w,wp,dk,dk2,dp,delta
*       Various energy and momenta and their intervals.
      double precision rs,vint,deg,Rnn,gammach,conc,brpl1,brpl,cmu,
     2                 ckf,rst,gcht,brplt
*       rs - Electron density parameter R_s.
*       vint - Interstitial potential.
*       deg - Path degeneracy, number of identical scattering paths.
*       Rnn - Half length of scattering path.
*       gammach - Core hole lifetime.
*       conc - Electron concentration.
*       brpl1 - plasmon broadening in units of plasma frequency
*       brpl - plasmon broadening
*       cmu - Chemical potential from FEFF file.
*       ckf - Fermi level from FEFF file.
*       rst - Test to see if rs matches old value.
*       gcht - Test to see if gammach matches old value.
*       brplt - Test to see if brpl1 matches old value.
      double precision sef0,se0,se,ce,width,z1,z1i,se2,xise,
     2                 zkk,dsig,xpkg(npts2),seg(npts2),ekpg(npts2),
     3                 sse,sxise
*       sef0 - Self energy at the Fermi level Sigma(E_F,k_F)
*       se0 - Non-self consistent on shell self energy.
*       se - Real part of on shell self energy.
*       ce - Electron gas core hole self energy.
*       width - Quasiparticle lifetime.
*       z1 - Real part of renormalization constant.
*       z1i - Imaginary part of renormalization constant.
*       se2 - Real part of self energy (not neccessarily on shell).
*       xise - Imaginary part of self energy (not neccessarily on shell).
*       zkk - Momentum derivative renormalization constant.
*       dsig - Difference in self energies, to estimate zkk.
*       xpkg - Array of momenta, to estimate zkk.
*       seg - Array of self energies, to estimate zkk.
*       ekpg - Array of energies, to estimate zkk.
*       sse - self energy due to given pole in epsilon^{-1}
      common /energies/ se,ce,width,z1,z1i,se2,xise
      double precision xktest,xktold
*       Used for checking the location of the fermi level in xmu.dat.
      double precision xreduc,xfact1
*       xreduc - Ad hoc overall uniform amplitude reduction.  Obsolete.
*       xfact1 - Dummy variable for storing intermediate calculations.
      double precision pk(npts2),pgrid(nqpts),epts(nsfpts),wpts(npts),
     2                 pthresh
*       pk - Array of momentum values at data points from FEFF files.
*       pgrid - Array of momentum values on minimal momentum grid.
*       epts - Array of energy values on minimal energy grid.
*       wpts - Array of energy variables on uniform energy grid.
*       pthresh - Estimate of momentum threshold for plasmon creation.
      double precision spectf(8,nsfpts),cspec(npts),weights(8)
*       spectf - Spectral function computed on minimal grid.
*       cspec - Spectral function interpolated onto uniform grid.
*       Weights - Spectral weights of the components of the spectral function.
      double precision dphsum,s02sum,xnorm,ww
*       Used in finite element integration for averaging over
*            data points on uniform momentum grid to get output 
*            for momentum points in feffnnnn.dat file.
*       dphsum - Phase shift integration.
*       s02sum - Amplitude reduction integration.
*       xnorm - Normalization.
*       ww - Weighting or importance function.
      double precision chirr,chiii,so2mag,phaseshft,
     2                 phshftold,phrmu,phrmu0,
     3                 xchir,xchii,phchir,phchii,xmu2,xmu02,
     4                 phmu,phmu0,xchi2,phchi,rmu2,rmu02,ximu2
*       chirr - Real part of chi.
*       chiii - Imaginary part of chi.
*       so2mag - Amplitude reduction.
*       phaseshift - Phaseshift.
*       phaseshiftold - Used to check for jumps of 2 pi in phase.
*       xchir - Intermediate real part of chi.
*       xchii - Intermediate imaginary part of chi.
*       phchir - Phase of convolution of real part of chi.
*       phchii - Phase of convolution of imaginary part of chi.
*       xmu2 - Convolution of XANES spectrum with spectral function.
*       xmu02 - Convolution of background with spectral function.
*       xchi2 - Convolution of XAFS signal from xmu.dat.
*       phmu - 'Phase' of XANES spectrum, should be zero, but the 
*           subroutine needs a variable to put it in.
*       phmu0 - 'Phase' of background, should be zero, but the 
*           subroutine needs a variable to put it in.
*       phchi - 'Phase' of XAFS signal, should be zero, but the 
*           subroutine needs a variable to put it in.
      double precision emsf(nqpts,nsfpts),essf(nqpts,nsfpts),
     2                 xmsf(nqpts,nsfpts),xssf(nqpts,nsfpts),
     3                 xissf(nqpts,nsfpts),escsf(nqpts,nsfpts),
     4                 engrid(nqpts,nsfpts),wgts(nqpts,8),
     5                 sfinfo(nqpts,8)
*       emsf - Array of extrinsic quasiparticle spectral function
*            values for file specfunct.dat.
*       essf - Array of extrinsic satellite spectral function
*            values for file specfunct.dat.
*       xmsf - Array of interference quasiparticle spectral function
*            values for file specfunct.dat.
*       xssf - Array of interference satellite spectral function
*            values for file specfunct.dat.
*       xissf - Array of intrinsic satellite spectral function
*            values for file specfunct.dat.
*       essf - Array of clipped extrinsic satellite spectral function
*            values for file specfunct.dat.
*       engrid - Energy grid for spectral function in file specfunct.dat.
*       wgts - Array of spectral weights in file specfunct.dat.
*       sfinfo - Array of miscellaneous information in file specfunct.dat.
      double precision xk(npts2),chi(npts2),xmag(npts2),phase(npts2),
     2                 phm2kr(npts2),epts2(npts2),chir(npts2),
     3                 chii(npts2),e1(npts2),xmu(npts2),xmu0(npts2),
     5                 xk2(npts2),caph(npts2),xmfeff(npts2),
     6                 phfeff(npts2),redfac(npts2),xlam(npts2),
     7                 realck2(npts2),caph2(npts2),xmfeff2(npts2),
     8                 phfeff2(npts2),redfac2(npts2),xlam2(npts2)
      double precision rmu(npts2),rmu0(npts2),ximu(npts2)
*       xk - EXAFS wavenumber from chi.dat or chipnnnn.dat.
*       chi - EXAFS signal from chi.dat or chipnnnn.dat.
*       xmag - Magnitude of chi from chi.dat or chipnnnn.dat.
*       phase - Phase of chi from chi.dat or chipnnnn.dat.
*       phm2kr - PHase Minus 2 K R, phase of chi with dominant 
*           k dependant oscillation removed from chi.dat or chipnnnn.dat.
*       epts2 - Energy from files, measured from edge.
*       chir - Real part of EXAFS signal.
*       chii - Imaginary part of EXAFS signal.
*       e1 - Energy from xmu.dat.
*       xmu - XANES signal from xmu.dat.
*       xmu0 - Embedded atom background signal.
*       xk2 - EXAFS wavenumber from feffnnnn.dat
*       caph - Central atom phase shift interpolated onto uniform 
*           momentum grid.
*       xmfeff - Magnitude of f_(eff) interpolated onto uniform
*           momentum grid.
*       phfeff - Phase of f_(eff) interpolated onto uniform 
*           momentum grid.
*       redfac - Reduction factor on uniform momentum grid.
*       xlam - Mean free path of photoelectron, interpolated
*           onto uniform momentum grid.
*       realck2 - Real part of complex momentum from feffnnnn.dat.
*       caph2 - Central atom phase shift on feffnnnn.dat grid.
*       xmfeff2 - Magnitude of f_(eff) from feffnnnn.dat.
*       phfeff2 - Phase of f_(eff) from feffnnnn.dat.
*       redfac2 - Reduction factor feffnnnn.dat grid
*       xlam2 - Mean free path of photoelectron from feffnnnn.dat.
      double precision s02list(npts2),phlist(npts2)
*       s02list - Array of amplitude reduction values on uniform 
*           momentum grid.
*       phlist - Array of phase shifts on uniform momentum grid.
      double precision emain,esat,xmain,xsat,xisat,sat,eclip,esatr
*       emain - Extrinsic quasiparticle spectral function.
*       esat - Extrinsic satellite spectral function.
*       xmain - Interference quasiparticle spectral function.
*       xsat - Interference satellite spectral function.
*       xisat - Intrinsic spectral function.
*       sat - Total satellite spectral function.
*       eclip - Anomalous extrinsic satellite in region of quasiparticle.
*       esatr - Everything left in the extrinsic satellite after eclip is
*         subtracted off.
      integer npl,nplmax,nplt
      parameter (nplmax=5000)
*       npl - number of poles in epsilon^{-1}
*       nplmax - maximum number of poles in epsilon^{-1} for array dimensioning
      double precision plengy(nplmax),plwt(nplmax),oscstr(nplmax),
     2                 plbrd(nplmax),epswt,
     3                 plengyt(nplmax),plwtt(nplmax),plbrdt(nplmax)
*       plengy - energy of poles in epsilon^{-1}
*       plwt - weight of poles in epsilon^{-1}, such that sum(plwt)=1
*       oscstr - oscilator strength f of resonances epsilon^{-1}
*       plbrd - broadening of poles in epsilon^{-1}
*       epswt - sum of weight of poles, to enforce sum(plwt)=1 {a consequence of
*               int(0,oo) d_omega omega epsilon^{-1}(q,omega)=-(pi/2)*omp}
      logical brpole
*       brpole - true if pole broadening is to be calculated
      double precision pi,ef,fmu,qf,omp,ompl,wt,ekp,ek,qpk,acc,brd,adisp
*       pi - ratio of circumference to diameter of a circle in
*            euclidian geometry
*       ef - Fermi energy
*       fmu - chemical potential = Fermi energy + self consistent
*             on shell self energy at the Fermi level
*       qf - Fermi momentum
*       omp - plasma frequency omega_p
*       ompl - energy of pole in epsilon^{-1}
*       wt - weight of pole in epsilon^{-1}
*       ekp - photoelectron energy = bare kinetic energy + real part of
*             on shell self energy
*       ek - bare photoelectron kinetic energy = pk**2/2
*       qpk - photoelectron momentum
*       acc - global accuracy parameter
*       brd - width of pole in epsilon^(-1)
*       adisp - dispersion parameter for dispersion relation,
*               w(q)**2=omp+adisp*q**2+q**4/4
      common /convsf/ pi,ef,fmu,qf,omp,ompl,wt,ekp,ek,qpk,acc,brd,adisp
*       Common block one is used in most functions and subroutines.
      common /flag/ iwrite,jj
*       Common block flag tells subroutine  mkspectf when to print out
*       interesting information.
      double precision qthresh,beta,exchange
*       Functions which may be called.
      integer lowq,lowqt
*       lowq - Set equal to 0 to avoid calculating self energy from 
*              contributions below Fermi level.  When considering 
*              interference effects, lowq should be set equal to zero.
*              When finding quasiparticle properties, lowq should not
*              be zero.
*       lowqt - Value of lowq from previous run.
      common /belowqf/ lowq
      external qthresh,beta,exchange


      integer elnes,ipmin,ipmax,ipstep  !KJ added these variables 2-06
	character*12 f1,f2  !KJ dummy filenames  2-06
	integer kilast(10) !KJ stupid fix for stupid setup of this program 2-06
	integer ip !KJ local index 2-06
c     elnes : we're in EELS mode if elnes=1
c     ipmin,ipmax,ipstep : range of polarization components to calculate

c  !KJ Next section added to read ELNES variables 2-06     
c     read eels.inp
      elnes=0
      open(file='eels.inp',unit=3,status='old',err=900)
        read(3,*,err=900,end=900) 
        read(3,20,err=900,end=900) elnes
        read(3,*,err=900,end=900)
        read(3,*,err=900,end=900)
        read(3,*,err=900,end=900)
        read(3,20,err=900,end=900) ipmin,ipstep,ipmax
  20  format (20i4)
      close(3)
      goto 901
900   continue
      elnes=0
901   continue
      if(elnes.eq.0) then
        ipstep=1
        ipmax=1
        ipmin=1
      endif
      do i=1,10
      kilast(i)=9
      enddo
      kilast(1)=7
c  !KJ end my changes



c  !KJ big loop for all polarization types 2-06 :
      do ip=ipmin,ipmax,ipstep
      if(ip.eq.1) then
	  f1(1:12)='chi.dat     '
	  f2(1:12)='xmu.dat     '
	elseif(ip.eq.10) then
	  f1(1:12)='chi10.dat   '
	  f2(1:12)='xmu10.dat   '
	elseif(ip.gt.1.and.ip.lt.10) then
	  f1(1:4)='chi0'
	  f1(5:5)= char(48+ip)
	  f1(6:12)='.dat   '
	  f2(1:4)='xmu0'
	  f2(5:5)= char(48+ip)
	  f2(6:12)='.dat   '
	else
	  stop 'crazy ip in ff2xmu'
	endif
c  !KJ end my changes


      isattype=0
      iwrite=0
      iwrite2=0
      iwrconv=0
      iwrcfile=0
      ipw=0
      ipwc=0
*      ipse=0
*      ipsk=0
      lowq=0
      icut=0
      brpole=.true.
*      brpole=.false.
*      wsigk=1.d0
      if (abs(ispec).eq.1) then
        cfile(1)= f2  !KJ 2-06    'xmu.dat     '
        ilast(1)= kilast(ip)  !KJ 2-06     7
        itype(1)=2
        cfile(2)= f1  !KJ 2-06    'chi.dat     '
        ilast(2)=7
        itype(2)=1
        ifiles=2
      elseif (abs(ispec).eq.0) then
c       Josh - Added convolution of xmu.dat for path expansion
        cfile(1)= f2  !KJ 2-06    'xmu.dat     '
        ilast(1)= kilast(ip)  !KJ 2-06   7
        itype(1)=2
c       Josh END
        cfile(2)= f1  !KJ 2-06    'chi.dat     '
        ilast(2)= kilast(ip)  !KJ 2-06   7
        itype(2)=1
        ik=2
        if (ipr6.eq.2.or.ipr6.eq.3) then
          open(unit=1,file='list.dat',status='old',iostat=ios)
          if (ios.gt.0) goto 10
 2        read(1,'(A)') cinp
          if (cinp(6:14).ne.'---------') goto 2
          read(1,'(A)') cinp
 3          read(1,'(A)',end=10) cinp
            ik=ik+1
            lfirst=1
            last=1
 4          if (cinp(lfirst:lfirst).eq.' ') then
              lfirst=lfirst+1
              last=lfirst
              goto 4
            endif
 5          if (cinp(last:last).ne.' ') then
              last=last+1
              goto 5
            endif
            if (last-lfirst.eq.3) then
              cpath='0'//cinp(lfirst:last-1)
            elseif (last-lfirst.eq.2) then
              cpath='00'//cinp(lfirst:last-1)
            elseif (last-lfirst.eq.1) then
              cpath='000'//cinp(lfirst:last-1)
            else
              cpath=cinp(lfirst:last-1)
            endif
*            open(unit=23,file='temp',status='unknown')
*            close(unit=23)
*            open(unit=23,file='temp',status='old')
*            read(23,*) cpath
*            close(unit=23,status='delete')
*            last=4
* 4          if (cpath(last:last).eq.' ') then
*              last=last-1
*              goto 4
*            endif
*            if (last.eq.3) then
*              cpath='0'//cpath(:last)
*            elseif (last.eq.2) then
*              cpath='00'//cpath(:last)
*            elseif (last.eq.1) then
*              cpath='000'//cpath(:last)
*            endif
            if (ipr6.eq.2) then
              cfile(ik+1)='chip'//cpath//'.dat'
              itype(ik+1)=1
            elseif (ipr6.eq.3) then
              cfile(ik+1)='feff'//cpath//'.dat'
              itype(ik+1)=3
            endif
            ilast(ik+1)=12
          goto 3
 10       close(unit=1)
        endif
        ifiles=ik+1
      endif
      do i=1,ifiles
        if (cfile(i).eq.cfname) iwrcfile=i
      enddo

      if (ipsk.ne.0) then
        iwrite=0
        iwrite2=0
      elseif (iwrite.ne.0) then
        iwrite2=0
      endif
        
* Open diagnostic and auxilliary output files.
      if (iwrite.ne.0.or.iwrite2.ne.0.or.ipsk.ne.0) then
        open(unit=12,status='unknown',file='qpsf.dat')
        open(unit=13,status='unknown',file='satsf.dat')
      endif
      if (ipsk.ne.0.or.iwrite.ne.0) 
     2  open(unit=24,status='unknown',file='sigma.dat')
      if (ipwc.ne.0) open(unit=14,status='unknown',file='weightscl.dat')
      if (ipw.ne.0) open(unit=15,status='unknown',file='weights.dat')
      if (ipse.ne.0) 
     2 open(unit=18,status='unknown',file='selfenergy.dat')

      do ikk=1,ifiles
* Open input and output files.
        open(unit=21,status='old',
     2       file=cfile(ikk)(:ilast(ikk)),iostat=ios)
        open(unit=16,status='unknown',
     2       file='mbheader.temp')
*        if (itype(ikk).eq.1) then
*          open(unit=17,status='unknown',
*     2       file=cfile(ikk)(:ilast(ikk)-4)//'so2.dat')
*        endif
        if (ios.gt.0) goto 640

 12     read(21,'(A)') cfirst
        last=80
* Trim off excess white space.
 13     if (cfirst(last:last).eq.' ') then
          last=last-1
          goto 13
        endif
* Josh - Check that convolution has not been done on this file.
        if(cfirst(1:last).eq.'# Convoluted with A(omega).') then
          print '(A)', 'WARNING: '// cfile(ikk) 
          print '(A)', 'has already been convoluted ' //
     2          'in a previous calculation.'
          print '(A)', 'Rerun module 6 if you still '//
     2          'wish to proceed.'
          stop
        end if
* Find physical parameters of the material needed for computation.
        do isearch=1,last-7
          if(cfirst(isearch:isearch+6).eq.'Gam_ch=') then
            gchtx=cfirst(isearch+7:isearch+15)
          elseif(cfirst(isearch:isearch+6).eq.'Rs_int=') then
            rstx=cfirst(isearch+8:isearch+12)
          elseif(cfirst(isearch:isearch+4).eq.'Vint=') then
            vintx=cfirst(isearch+5:isearch+14)
          elseif(cfirst(isearch:isearch+2).eq.'Mu=') then
            mutx=cfirst(isearch+3:isearch+12)
          elseif(cfirst(isearch:isearch+2).eq.'kf=') then
            kftx=cfirst(isearch+3:isearch+11)
          endif
        enddo
* Write header lines.
        if ((iwrite.ne.0.or.iwrite2.ne.0.or.ipsk.ne.0).and.ikk.eq.1) 
     2  then
          write(12,'(A)') cfirst(1:last)
          write(13,'(A)') cfirst(1:last)
        endif
        if (ikk.eq.1.and.(ipsk.ne.0.or.iwrite.ne.0))
     2    write(24,'(A)') cfirst(1:last)
        if (ikk.eq.1.and.ipwc.ne.0) write(14,'(A)') cfirst(1:last)
        if (ikk.eq.1.and.ipw.ne.0) write(15,'(A)') cfirst(1:last)
        write(16,'(A)') cfirst(1:last)
        if (ikk.eq.1.and.ipse.ne.0) write(18,'(A)') cfirst(1:last)
        if (cfirst(6:14).ne.'---------') goto 12
* feffnnnn.dat files have more information lines after the line with
* dashes than the other file types.
        if (itype(ikk).eq.3) then
 14       read(21,'(A)') cfirst
          last=80
 15        if (cfirst(last:last).eq.' ') then
            last=last-1
            goto 15
          endif
* If first character is a number, keep it.  Otherwise it might be a
* comment character, so dump it.
          if (cfirst(1:1).eq.'1'.or.cfirst(1:1).eq.'2'
     2        .or.cfirst(1:1).eq.'3'.or.cfirst(1:1).eq.'4'
     3        .or.cfirst(1:1).eq.'5'.or.cfirst(1:1).eq.'6'
     4        .or.cfirst(1:1).eq.'7'.or.cfirst(1:1).eq.'8'
     5        .or.cfirst(1:1).eq.'9'.or.cfirst(1:1).eq.'0') then
            lfirst=1
          else
            lfirst=2
          endif
* Search for scattering half length, read into variable Rnn
          do isearch=1,last
            if(cfirst(isearch:isearch+3).eq.'reff') then
              open(unit=23,file='temp',status='unknown')
              write(23,*) cfirst(lfirst:last)
              close(unit=23)
              open(unit=23,file='temp',status='old')
              read(23,*) nleg,deg,Rnn
              close(unit=23,status='delete')
              Rnn=Rnn*aangstrom
* @# indicates end of comment lines.
            elseif(cfirst(isearch:isearch+1).eq.'@#') then
              goto 16
            endif
          enddo
          write(16,'(A)') cfirst(1:last)
          goto 14
        else 
          read(21,'(A)') cfirst
        endif
        last=80
 16     if (cfirst(last:last).eq.' ') then
          last=last-1
          goto 16
        endif
* Write column labels.
        if (ikk.eq.1) then
          if (iwrite.ne.0.or.iwrite2.ne.0.or.ipsk.ne.0) then
            write(12,'(A)') '#  omega       delta ext    interf.'   
     2       // '      main ext     sat ext'
            write(13,'(A)') '#  omega       extrinsic    interf.'    
     2       // '      intrinsic    total'
          endif
          if (iwrite.ne.0.or.ipsk.ne.0)
     2    write(24,'(A)') '#   omega      Re(Sigma)    -Im(Sigma)'
          if (ipwc.ne.0)
     2    write(14,'(A)') '#   energy     ext q.p.   inter q.p. ext sat'
     3     // '    inter sat  intrin sat'
          if (ipw.ne.0)
     2    write(15,'(A)') '#   energy     ext q.p.   inter q.p. ext sat'
     3     // '    inter sat  intrin sat'
          if (ipse.ne.0)
     2    write(18,'(A)') '#   energy      Re(Sigma)   -Im(Sigma)'
     3     //'        Re(Z)        Im(Z)'
        endif
        write(16,'(A)') cfirst(1:last)
*        if (itype(ikk).eq.1) then
*          write(17,'(A)') '#     k          So2        phase shift'
*        endif
* Find numerical values of core hole lifetime, Wigner-Seitz radius, 
* interstitial potential, chemical potential, and Fermi momentum.
        open(unit=23,file='temp',status='unknown')
        write(23,*) gchtx
        write(23,*) rstx
        write(23,*) vintx
        write(23,*) mutx
        write(23,*) kftx
        close(unit=23)
        open(unit=23,file='temp',status='old')
        read(23,*) gammach
        read(23,*) rs
        read(23,*) vint
        read(23,*) cmu
        read(23,*) ckf
        close(unit=23,status='delete')
        gammach=(gammach/2.d0)*eV
        cmu=(cmu-vint)*eV
        vint=vint*eV
        ckf=ckf/aangstrom
        xreduc=1.d0
* Compute important material properties and constants.
        pi=dacos(-1.d0)
        qf=((9.d0*pi/4.d0)**(1.d0/3.d0))/rs
        ef=qf*qf/2.d0
        conc=3.d0/(4.d0*pi*(rs**3))
        omp=dsqrt(4.d0*pi*conc)
        adisp=2.d0*ef/3.d0
        ekp=ef
        qpk=qf
        acc=1.d-4

* Read pole expansion for epsilon^{-1}
        call rdeps(omp,nplmax,npl,plengy,oscstr,plbrd)
        epswt=0.d0
        do ipl=1,npl
          plwt(ipl)=dabs(oscstr(ipl)*plengy(ipl)**2/(omp**2))
          epswt=epswt+plwt(ipl)
        enddo
        open (unit=88,file='apl.dat', status='unknown')
        do ipl=1,npl
          write(88,'(5f10.5)') plengy(ipl)/eV,oscstr(ipl)*plengy(ipl)
        enddo
        close (88)

        sef0=0.d0
        do ipl=1,npl
          call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
          if (brpole) then
            call brsigma(0.d0,sse,sxise)
          else 
            call renergies(0.d0,sse)
          endif
          sef0=sef0+sse*wt
        enddo
        sef0=sef0+exchange(qf)

* Estimate threshold for plasmon creation.
        pthresh=qthresh(omp,adisp,ef,qf)
* Find minimal momentum grid.
        do i=1,10
          dp=(pthresh-qf)/10.d0
          pgrid(i)=qf+i*dp
        enddo
        do i=1,30
          dp=0.25d0*pthresh/30.d0
          pgrid(i+10)=pgrid(10)+i*dp
        enddo
        do i=1,10
          dp=0.75d0*pthresh/10.d0
          pgrid(i+40)=pgrid(40)+i*dp
        enddo
        do i=1,10
          dp=2.d0*pthresh/10.d0
          pgrid(i+50)=pgrid(50)+i*dp
        enddo
        pgrid(61)=5.d0*pthresh
        pgrid(62)=7.d0*pthresh
        pgrid(63)=1.d1*pthresh
        pgrid(64)=3.d1*pthresh
        pgrid(65)=1.d2*pthresh
        pgrid(66)=3.d2*pthresh
  
* Read information from files.
        if (itype(ikk).eq.1) then
          iasym=0
          do i=1,npts2
            epts2(i)=0.d0
            xk(i)=0.d0
            pk(i)=0.d0
            chi(i)=0.d0
            xmag(i)=0.d0
            phase(i)=0.d0
            phm2kr(i)=0.d0
          enddo
          xktold=0.d0
          do i=1,npts2
            read(21,*,end=25) xk(i),chi(i),xmag(i),phase(i)
            xk(i)=xk(i)/aangstrom
            chir(i)=xmag(i)*cos(phase(i))
            chii(i)=xmag(i)*sin(phase(i))
            j=i
          enddo
        elseif (itype(ikk).eq.2) then
          iasym=1
          do i=1,npts2
            e1(i)=0.d0
            epts2(i)=0.d0
            xk(i)=0.d0
            pk(i)=0.d0
            xmu(i)=0.d0
            xmu0(i)=0.d0
            chi(i)=0.d0
          enddo
          xktold=0.d0
          do i=1,npts2
            read(21,*,end=25) e1(i),epts2(i),xk(i),xmu(i),xmu0(i),chi(i)
            e1(i)=e1(i)*eV
            epts2(i)=epts2(i)*eV
            xktest=dabs(xk(i))
            if (xktest.lt.xktold) iedge=i
            xktold=xktest
            xk(i)=xk(i)/aangstrom
            j=i
          enddo
          dw=epts2(j)-epts2(j-1)
        elseif (itype(ikk).eq.3) then
          iasym=0
          do i=1,npts2
            epts2(i)=0.d0
            xk(i)=0.05d0*(i-1)/aangstrom
            pk(i)=0.d0
            chi(i)=0.d0
            xmag(i)=0.d0
            phase(i)=0.d0
            phm2kr(i)=0.d0
          enddo
          xktold=0.d0
          do i=1,npts2
            read(21,*,end=17) xk2(i),caph2(i),xmfeff2(i),phfeff2(i),
     2          redfac2(i),xlam2(i),realck2(i)
            xk2(i)=xk2(i)/aangstrom
            xmfeff2(i)=xmfeff2(i)*aangstrom
            xlam2(i)=xlam2(i)*aangstrom
            realck2(i)=realck2(i)/aangstrom
            j=i
          enddo
 17       ifeffct=j
* Interpolate data from feffnnnn.dat grid to the uniform grid used
* in chi.dat.
          do i=1,npts2
            do jj=1,j-1
              if (xk(i).ge.xk2(jj).and.xk(i).lt.xk2(jj+1)) then
                caph(i)=caph2(jj)+(caph2(jj+1)-caph2(jj))
     2                  *(xk(i)-xk2(jj))/(xk2(jj+1)-xk2(jj))
                xmfeff(i)=xmfeff2(jj)+(xmfeff2(jj+1)-xmfeff2(jj))
     2                  *(xk(i)-xk2(jj))/(xk2(jj+1)-xk2(jj))
                phfeff(i)=phfeff2(jj)+(phfeff2(jj+1)-phfeff2(jj))
     2                  *(xk(i)-xk2(jj))/(xk2(jj+1)-xk2(jj))
                redfac(i)=redfac2(jj)+(redfac2(jj+1)-redfac2(jj))
     2                  *(xk(i)-xk2(jj))/(xk2(jj+1)-xk2(jj))
                xlam(i)=xlam2(jj)+(xlam2(jj+1)-xlam2(jj))
     2                  *(xk(i)-xk2(jj))/(xk2(jj+1)-xk2(jj))
                goto 18
              endif
            enddo
            if (xk(i).eq.xk2(jj)) then
              caph(i)=caph2(jj)
              xmfeff(i)=xmfeff2(jj)
              phfeff(i)=phfeff2(jj)
              redfac(i)=redfac2(jj)
              xlam(i)=xlam2(jj)
            endif
* Compute exafs signal Chi from feffnnnn.dat info.
 18         xmag(i)=(deg*xmfeff(i)*redfac(i)*exp(-2.d0*Rnn/xlam(i)))
     2              /(xk(i)*Rnn**2)
            phm2kr(i)=phfeff(i)+caph(i)
            phase(i)=phm2kr(i)+2.d0*xk(i)*Rnn
            chir(i)=xmag(i)*cos(phase(i))
            chii(i)=xmag(i)*sin(phase(i))
          enddo
          xmag(1)=xmag(2)+(xk(1)-xk(2))*(xmag(3)-xmag(2))/(xk(3)-xk(2))
          chir(1)=xmag(1)*cos(phase(1))
          chii(1)=xmag(1)*sin(phase(1))
          j=npts2
        endif
 25     continue

        close(unit=21)
        close(unit=16)
        open(unit=21,status='old',file='mbheader.temp',iostat=ios)
        if (ios.gt.0) goto 640
        open(unit=16,status='unknown',
     2       file=cfile(ikk)(:ilast(ikk)))
*	Josh - added to header so that we can check if a previous convolution
*	has been performed.
        write(16,'(A)') '# Convoluted with A(omega).'
 27       read(21,'(A)',end=35) cfirst
          last=80
 30       if (cfirst(last:last).eq.' ') then
            last=last-1
            goto 30
          endif
          write(16,'(A)') cfirst(1:last)
          goto 27
 35     close(unit=21,status='delete')
          
* Need to find photoelectron momentum.
* First, find kinetic energy.
        do i=1,j
          if (xk(i).ge.0.d0) then
            ekp=xk(i)**2/2.d0+cmu
          else
            ekp=-xk(i)**2/2.d0+cmu
          endif
          ekpg(i)=ekp
          if (itype(ikk).eq.1.or.itype(ikk).eq.3) epts2(i)=ekp
* Make arrays of 0 order self energies and 0 order estimates for momentum.
          if (ekp.ge.0.d0) then
            qpk=sqrt(qf**2+2.d0*(ekp-fmu))
            xpkg(i)=qpk
            se0=0.d0
            do ipl=1,npl
              call plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
              if (brpole) then
                call brsigma(0.d0,sse,sxise)
              else
                call renergies(0.d0,sse)
              endif
              se0=se0+sse*wt
            enddo
            seg(i)=se0+exchange(qpk)
          endif
        enddo
* Estimate momentum derivative renormalization constant.
        do i=1,j
          if (ekpg(i).ge.0) then
            if (i.ne.1.and.i.ne.j) then
              dsig=seg(i+1)-seg(i-1)
              dk2=xpkg(i+1)**2/2.d0-xpkg(i-1)**2/2.d0
            elseif (i.eq.1) then
              dsig=seg(i+1)-seg(i)
              dk2=xpkg(i+1)**2/2.d0-xpkg(i)**2/2.d0
            else
              dsig=seg(i)-seg(i-1)
              dk2=xpkg(i)**2/2.d0-xpkg(i-1)**2/2.d0
            endif
            zkk=1.d0/(1.d0+dsig/dk2)
* Find array of photoelectrom momenta.
            pk(i)=sqrt(xpkg(i)**2-2.d0*zkk*(seg(i)-sef0))
          endif
        enddo
* if running convolution is written, choose momentum point closest to desired energy
        if (iwrcfile.ne.0) then
          den=abs(ekpg(1)-cen)
          iwrconv=1
          do i=2,j
            den2=abs(ekpg(i)-cen)
            if (den2.lt.den) then
              den=den2
              iwrconv=i
            endif
          enddo
        endif
  
* Pad out the ends of the arrays so the convolution does not screw up the
* end data points.
        if (itype(ikk).eq.1.or.itype(ikk).eq.3) then
          dw=epts2(j)-epts2(j-1)
          do i=j+1,npts2
            epts2(i)=epts2(i-1)+dw
          enddo
        elseif (itype(ikk).eq.2) then
          dw=epts2(j)-epts2(j-1)
          do i=j,npts2
            e1(i)=e1(i-1)+dw
            epts2(i)=epts2(i-1)+dw
            xmu0(i)=xmu0(j)
            xmu(i)=xmu0(j)
            chi(i)=0.d0
          enddo
          call mkrmu(xmu,xmu0,rmu,epts2,npts2)
*          call mkrmu(xmu0,xmu0,rmu0,epts2,npts2)
          do i=1,npts2
            ximu(i)=xmu(i)-xmu0(i)
          enddo
        endif

* Find the spectral function and associated data.
        iout=0
* If specfunct.dat does not exist, or if it is for a material with 
* different electron gas properties, set flag 'iout' to recompute 
* spectral function.  Otherwise, read in spectral function.
        open(unit=23,file='specfunct.dat',status='old',
     2       access='sequential',form='unformatted',iostat=ios)
        if (ios.gt.0) then
          iout=1
        else
          read(23) rst,gcht,iasymt,isattypt,lowqt,nplt
          read(23) (plengyt(ii), ii=1,nplmax)
          read(23) (plbrdt(ii), ii=1,nplmax)
          read(23) (plwtt(ii), ii=1,nplmax)
          read(23) ((sfinfo(jj,ii), jj=1,nqpts), ii=1,8)
          read(23) ((wgts(jj,ii), jj=1,nqpts), ii=1,8)
          read(23) ((emsf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
          read(23) ((essf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
          read(23) ((xmsf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
          read(23) ((xssf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
          read(23) ((xissf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
          read(23) ((escsf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
          read(23) ((engrid(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        endif
        close(unit=23)
        if (rst.ne.rs) iout=1
        if (gcht.ne.gammach) iout=1
        if (iasymt.ne.iasym) iout=1
        if (lowqt.ne.lowq) iout=1
        if (isattypt.ne.isattype) iout=1
        if (nplt.ne.npl) iout=1
        do jj=1,npl
          if (plengy(jj).ne.plengyt(jj)) iout=1
          if (plbrd(jj).ne.plbrdt(jj)) iout=1
          if (plwt(jj).ne.plwtt(jj)) iout=1
        enddo
        do jj=1,nqpts
          if (real(sfinfo(jj,1)).ne.real(pgrid(jj))) iout=1
        enddo
        if (iwrite.ne.0.and.ikk.eq.1) iout=1

        npi=0
        if (iout.eq.1) then
          write(6,*) 'computing spectral function'
        endif
        if(ipsk.ne.0.and.ikk.eq.1) then
          jj=0
          call mkspectf(rs,wsigk*qf,gammach,xreduc,
     2                  epts,spectf,weights,isattype,
     3                  npl,nplmax,plengy,plwt,plbrd,brpole)

*          do ipl=1,npl
*            write(6,*) ipl,plengy(ipl),plbrd(ipl),plwt(ipl),
*     2        plengy(ipl)+sef0-se,sef0,se
*          enddo
  
        endif
        do jj=1,nqpts
          if (iout.eq.1) then
* Spectral function has not yet been computed, or was computed for the
* wrong material.  Compute spectral function.
            call mkspectf(rs,pgrid(jj),gammach,xreduc,
     2                    epts,spectf,weights,isattype,
     3                  npl,nplmax,plengy,plwt,plbrd,brpole)
            write(6,'(I3,A10)') int(real(jj)/real(nqpts)*100.0),
     &                '% computed'
            sfinfo(jj,1)=pgrid(jj)
            sfinfo(jj,2)=ekp
            sfinfo(jj,3)=ek
            sfinfo(jj,4)=se
            sfinfo(jj,5)=ce
            sfinfo(jj,6)=width
            sfinfo(jj,7)=z1
            sfinfo(jj,8)=z1i
            do ii=1,8
              wgts(jj,ii)=weights(ii)
            enddo
            do ii=1,nsfpts
              emsf(jj,ii)=spectf(1,ii)
              essf(jj,ii)=spectf(2,ii)
              xmsf(jj,ii)=spectf(3,ii)
              xssf(jj,ii)=spectf(4,ii)
              xissf(jj,ii)=spectf(5,ii)
              escsf(jj,ii)=spectf(8,ii)
              engrid(jj,ii)=epts(ii)
            enddo
          else
* Correct spectral function has already been computed.
            ekp=sfinfo(jj,2)
            ek=sfinfo(jj,3)
            se=sfinfo(jj,4)
            ce=sfinfo(jj,5)
            width=sfinfo(jj,6)
            z1=sfinfo(jj,7)
            z1i=sfinfo(jj,8)
            do ii=1,8
              weights(ii)=wgts(jj,ii)
            enddo
          endif
        enddo
        write(6,*) 'convoluting file '
     2           //cfile(ikk)(:ilast(ikk))
* Interpolate spectral function onto uniform momentum grid.
        do jj=1,j
          do i=1,nqpts-1
            if (pk(jj).ge.pgrid(i).and.pk(jj).lt.pgrid(i+1)) then
              delta=(pk(jj)-pgrid(i))/(pgrid(i+1)-pgrid(i))
              do ii=1,nsfpts
                epts(ii)=engrid(i,ii)
     2               +delta*(engrid(i+1,ii)-engrid(i,ii))
                spectf(1,ii)=emsf(i,ii)+delta*(emsf(i+1,ii)-emsf(i,ii))
                spectf(2,ii)=essf(i,ii)+delta*(essf(i+1,ii)-essf(i,ii))
                spectf(3,ii)=xmsf(i,ii)+delta*(xmsf(i+1,ii)-xmsf(i,ii))
                spectf(4,ii)=xssf(i,ii)+delta*(xssf(i+1,ii)-xssf(i,ii)) 
                spectf(5,ii)=xissf(i,ii)
     2               +delta*(xissf(i+1,ii)-xissf(i,ii))
                spectf(6,ii)=essf(i,ii)+xissf(i,ii)-2.d0*xssf(i,ii)
     2               +delta*(essf(i+1,ii)+xissf(i+1,ii)
     3                     -2.d0*xssf(i+1,ii)
     4                     -(essf(i,ii)+xissf(i,ii)-2.d0*xssf(i,ii)))
                spectf(7,ii)=essf(i,ii)-escsf(i,ii)
     2               +delta*(essf(i+1,ii)-escsf(i+1,ii)
     3                     -(essf(i,ii)-escsf(i,ii)))
                spectf(8,ii)=escsf(i,ii)
     2               +delta*(escsf(i+1,ii)-escsf(i,ii))
              enddo
              do ii=1,8
                weights(ii)=wgts(i,ii)+delta*(wgts(i+1,ii)-wgts(i,ii))
              enddo
              se=sfinfo(i,4)+delta*(sfinfo(i+1,4)-sfinfo(i,4))
              ce=sfinfo(i,5)+delta*(sfinfo(i+1,5)-sfinfo(i,5))
              width=sfinfo(i,6)+delta*(sfinfo(i+1,6)-sfinfo(i,6))
              z1=sfinfo(i,7)+delta*(sfinfo(i+1,7)-sfinfo(i,7))
              z1i=sfinfo(i,8)+delta*(sfinfo(i+1,8)-sfinfo(i,8))
            endif
          enddo
* Take special care with the endpoints.
          if (pk(jj).ge.pgrid(nqpts)) then
            do ii=1,nsfpts
              epts(ii)=engrid(nqpts,ii)
              spectf(1,ii)=emsf(nqpts,ii)
              spectf(2,ii)=essf(nqpts,ii)
              spectf(3,ii)=xmsf(nqpts,ii)
              spectf(4,ii)=xssf(nqpts,ii)
              spectf(5,ii)=xissf(nqpts,ii)
              spectf(6,ii)=essf(nqpts,ii)+xissf(nqpts,ii)
     2                     -2.d0*xssf(nqpts,ii)
              spectf(7,ii)=essf(nqpts,ii)-escsf(nqpts,ii)
              spectf(8,ii)=escsf(nqpts,ii)
            enddo
            do ii=1,8
              weights(ii)=wgts(nqpts,ii)
            enddo
            se=sfinfo(nqpts,4)
            ce=sfinfo(nqpts,5)
            width=sfinfo(nqpts,6)
            z1=sfinfo(nqpts,7)
            z1i=sfinfo(nqpts,8)
          elseif (pk(jj).lt.pgrid(1)) then
            do ii=1,nsfpts
              epts(ii)=engrid(nqpts,ii)
              spectf(1,ii)=emsf(1,ii)
              spectf(2,ii)=essf(1,ii)
              spectf(3,ii)=xmsf(1,ii)
              spectf(4,ii)=xssf(1,ii)
              spectf(5,ii)=xissf(1,ii)
              spectf(6,ii)=essf(1,ii)+xissf(1,ii)-2.d0*xssf(1,ii)
              spectf(7,ii)=essf(1,ii)-escsf(1,ii)
              spectf(8,ii)=escsf(1,ii)
            enddo
            do ii=1,8
              weights(ii)=wgts(1,ii)
            enddo
            se=sfinfo(1,4)
            ce=sfinfo(1,5)
            width=sfinfo(1,6)
            z1=sfinfo(1,7)
            z1i=sfinfo(1,8)
          endif
* Interpolate spectral function onto uniform energy grid.
          call interpsf(npts,epts,wpts,spectf,cspec)
* Write information to diagnostic and supplementary files.
          if (ikk.eq.1.and.ipwc.ne.0) then
            write(14,701) epts2(jj),weights(1)+weights(8),
     2                  weights(3),weights(7),weights(5),weights(6)
          endif
          if (ikk.eq.1.and.ipw.ne.0) then
            write(15,701) epts2(jj),weights(1),weights(3)/2.d0,
     2                  weights(4),weights(5),weights(6)
          endif
          if (ikk.eq.1.and.ipse.ne.0) then
            write(18,500) epts2(jj),se,width,z1,z1i
          endif
          do i=1,nsfpts
            w=epts(i)
            emain=spectf(1,i)
            esat =spectf(2,i)
            xmain=spectf(3,i)
            xsat =spectf(4,i)
            xisat =spectf(5,i)
            sat  =spectf(6,i)
            eclip=spectf(7,i)
            esatr=spectf(8,i)
            if (jj.eq.iwrite2.and.ikk.eq.1) then
              write(12,500) w,emain,xmain,eclip,esatr
              write(13,500) w,esat,-2.d0*xsat,xisat,
     2                      (esat+xisat-2.d0*xsat)
            endif
          enddo
          wp=epts2(jj)
* Begin convolution.
          if (itype(ikk).eq.1.or.itype(ikk).eq.3) then
            if (jj.eq.iwrconv.and.ikk.eq.iwrcfile) then
              intout=1
              open (unit=28,file='realint.dat',status='unknown')
            else
              intout=0
            endif
            call sfconv(wp,cmu,gammach,npts2,epts2,chir,npts,
     2                wpts,cspec,weights,xchir,phchir,iasym,
     3                1,intout,omp)
            if (jj.eq.iwrconv.and.ikk.eq.iwrcfile) then
              intout=1
              open (unit=28,file='imagint.dat',status='unknown')
            else
              intout=0
            endif
            call sfconv(wp,cmu,gammach,npts2,epts2,chii,npts,
     2                wpts,cspec,weights,xchii,phchii,iasym,
     3                1,intout,omp)
* Find real and imaginary many body EXAFS signal chi.
            chirr=xchir*cos(phchir)-xchii*sin(phchii)
            chiii=xchii*cos(phchii)+xchir*sin(phchir)
* Compute phase shift, remove jumps of 2 pi.
            phaseshft=datan2(chiii,chirr)
            if(phaseshft-phshftold.gt.5.d0) then
              npi=npi+2
            elseif(phaseshft-phshftold.lt.-5.d0) then
              npi=npi-2
            endif
            phshftold=phaseshft
            phaseshft=phaseshft-pi*npi
            if (itype(ikk).eq.1) then
* Write output file of many body EXAFS signal.
              write(16,630) xk(jj)*aangstrom,
     2                chiii,dsqrt(chirr**2+chiii**2),
     3                phaseshft,
     4                phaseshft+phm2kr(jj)-phase(jj)
            endif
 630        format (1x, f10.4, 3x, 4(1pe13.6,1x))
* Find amplitude reduction and phase shift.
            so2mag=dsqrt(chirr**2+chiii**2)/xmag(jj)
            phaseshft=datan2(chiii,chirr)
            if(phaseshft-phshftold.gt.5.d0) then
              npi=npi+2
            elseif(phaseshft-phshftold.lt.-5.d0) then
              npi=npi-2
            endif
            phshftold=phaseshft
            phaseshft=phaseshft-pi*npi-phase(jj)
            s02list(jj)=so2mag
            phlist(jj)=phaseshft
*            if (itype(ikk).eq.1) then
** Write output file of amplitude reduction and phase shift.
*              write(17,500) xk(jj)*aangstrom,
*     2                so2mag,phaseshft
*            endif
          elseif (itype(ikk).eq.2) then
* Find many body convolution on absorption signal, embedded atom background,
* and fine structure.
*            call sfconv(wp,cmu+vint,gammach,npts2,epts2,chi,npts,
*     2                wpts,cspec,weights,xchi2,phchi,iasym,1,0,omp)
            if (iasym.eq.0) then
              if (jj.eq.iwrconv) then
                intout=1
                open (unit=28,file='imagint.dat',status='unknown')
              else
                intout=0
              endif
              call sfconv(wp,cmu+vint,gammach,npts2,epts2,ximu,npts,
     2            wpts,cspec,weights,ximu2,phmu,iasym,icut,intout,omp)
              if (jj.eq.iwrconv) then
                intout=1
                open (unit=28,file='realint.dat',status='unknown')
              else
                intout=0
              endif
              call sfconv(wp,cmu+vint,gammach,npts2,epts2,rmu,npts,
     2            wpts,cspec,weights,rmu2,phrmu,iasym,icut,intout,omp)
            else
              if (jj.eq.iwrconv) then
                intout=1
                open (unit=28,file='realint.dat',status='unknown')
              else
                intout=0
              endif
              call sfconv(wp,cmu+vint,gammach,npts2,epts2,xmu,npts,
     2            wpts,cspec,weights,xmu2,phrmu,iasym,icut,intout,omp)
            endif
            if (jj.eq.iwrconv) then
              intout=1
              open (unit=28,file='xmu0int.dat',status='unknown')
            else
              intout=0
            endif
            call sfconv(wp,cmu+vint,gammach,npts2,epts2,xmu0,npts,
     2            wpts,cspec,weights,xmu02,phmu0,iasym,icut,intout,omp)
            if (iasym.eq.0) then
              xmu2=ximu2*cos(phmu)+rmu2*sin(phrmu)+xmu02
            endif
            write(16,800)
     2                e1(jj)/eV,epts2(jj)/eV,xk(jj)*aangstrom,
!     2                xmu2,xmu02,(xmu2-xmu02)/xmu02    !KJ this is the original instruction  3-06
     2                xmu2,xmu02,(xmu2-xmu02)   !KJ removed normalization of chi   3-06  
          endif
        enddo
        if (itype(ikk).eq.3) then
          dk=0.05d0
* Average over nearby points on uniform momentum grid to find
* values for coarser grid in feffnnnn.dat files.  Use a trianguar
* weighting function to ensure each point contributes its full weight
* to the average.
          do jj=1,ifeffct
            s02sum=0.d0
            dphsum=0.d0
            xnorm=0.d0
            do i=1,j
              if (xk2(jj).eq.xk(i)) then
                ww=1.d0
                s02sum=s02sum+s02list(i)*ww*dk
                dphsum=dphsum+phlist(i)*ww*dk
                xnorm=xnorm+ww*dk
              elseif (xk(i).gt.xk2(jj-1).and.xk(i).le.xk2(jj)
     2                .and.xk2(jj-1).ne.xk2(jj)) then
                ww=(xk(i)-xk2(jj-1))/(xk2(jj)-xk2(jj-1))
                s02sum=s02sum+s02list(i)*ww*dk
                dphsum=dphsum+phlist(i)*ww*dk
                xnorm=xnorm+ww*dk
              elseif(xk(i).gt.xk2(jj).and.xk(i).lt.xk2(jj+1)
     2                .and.xk2(jj+1).ne.xk2(jj)) then
                ww=(xk2(jj+1)-xk(i))/(xk2(jj+1)-xk2(jj))
                s02sum=s02sum+s02list(i)*ww*dk
                dphsum=dphsum+phlist(i)*ww*dk
                xnorm=xnorm+ww*dk
              else
                ww=0.d0
              endif
            enddo
* Find many body values of phase and reduction.
            redfac2(jj)=redfac2(jj)*s02sum/xnorm
            caph2(jj)=caph2(jj)+dphsum/xnorm
* Write convoluted feffnnnnc.dat.
            write(16,400) xk2(jj)*aangstrom,caph2(jj),
     2          xmfeff2(jj)/aangstrom,phfeff2(jj),redfac2(jj),
     2          xlam2(jj)/aangstrom,realck2(jj)*aangstrom
  400       format (1x, f6.3, 1x, 3(1pe11.4,1x),1pe10.3,1x,
     1                            2(1pe11.4,1x))
          enddo
        endif
* Write out the spectral function to a data file.
        open(unit=23,file='specfunct.dat',status='unknown',
     2       access='sequential',form='unformatted',iostat=ios)
        write(23) rs,gammach,iasym,isattype,lowq,npl
        write(23) (plengy(ii), ii=1,nplmax)
        write(23) (plbrd(ii), ii=1,nplmax)
        write(23) (plwt(ii), ii=1,nplmax)
        write(23) ((sfinfo(jj,ii), jj=1,nqpts), ii=1,8)
        write(23) ((wgts(jj,ii), jj=1,nqpts), ii=1,8)
        write(23) ((emsf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        write(23) ((essf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        write(23) ((xmsf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        write(23) ((xssf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        write(23) ((xissf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        write(23) ((escsf(jj,ii), jj=1,nqpts), ii=1,nsfpts)
        write(23) ((engrid(jj,ii), jj=1,nqpts), ii=1,nsfpts)
* Do a little housecleaning.
        close(unit=23)
        close(unit=21)
        close(unit=16)
        close(unit=17)
 640    continue
      enddo
 500  format(1x,5(e12.5,1x))
 700  format(1x,7(f10.5,1x))
 701  format(1x,e10.5,1x,6(f10.5,1x))
 800  format(1x,2f11.3,f8.3,1p,3e13.5)
* End of program.


      enddo  !KJ end of loop do ip=ipmin,ipmax,ipstep  2-06


c     sub-program so2conv
c!    stop
      return

      end
      subroutine res02 ( mso2conv, ispec, ipr6, ipse, ipsk, wsigk, cen,
     2                   cfname)

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

        integer  mso2conv, ipse, ipsk, ispec, ipr6
        double precision  wsigk, cen
        character*12 cfname

c     Local stuff
      character*512 slog
      character*80 head(nheadx)
      dimension lhead(nheadx)

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)


c     read s02.inp
      open (file='s02.inp', unit=3, status='old',iostat=ios)
        read (3,10)  slog
        read (3,20)  mso2conv, ipse, ipsk
        read (3,10)  slog
        read (3,30)  wsigk, cen
        read (3,10)  slog
        read (3,20)  ispec, ipr6
        read (3,10)  slog
        read (3,10)  cfname
      close(3)

      return
      end
      subroutine rdeps (omp,nplmax,npl,plengy,oscstr,plbrd)

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      integer  npl,nplmax,ipl
      double precision  plengy(nplmax),oscstr(nplmax),plbrd(nplmax)

c     Local stuff
      character*512 slog
      character*80 head(nheadx),line
      dimension lhead(nheadx)

*     initialize
      do ipl=1,nplmax
        plengy(ipl)=0.d0
        oscstr(ipl)=0.d0
        plbrd(ipl)=0.d0
      enddo

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)

c     read s02.inp
      open (file='exc.dat', unit=3, status='old',iostat=ios)
      if (ios.eq.0) then
        npl=0
 100      read (3,'(a)',end=200)  line
          istart=1
 110      if (line(istart:istart).eq.' ') then
            istart=istart+1
            goto 110
          endif
          if (line(istart:istart).ne.'#') then
            npl=npl+1
            read (line,*) plengy(npl),plbrd(npl),oscstr(npl)
          endif
          goto 100
 200    continue
        do ipl=1,npl
          plengy(ipl)=plengy(ipl)/hart
          plbrd(ipl)=plbrd(ipl)/hart
        enddo
      else
        npl=1
        plengy(1)=omp
        plbrd(1)=0.001d0*omp
        oscstr(1)=1.d0
        open (file='exc.dat', unit=3, status='unknown')
        write(3,30) plengy(1)*hart,plbrd(1)*hart,oscstr(1)
      endif
      close(3)
      


*      write(6,*) '***',npl,'*',plengy(1),'*',plbrd(1),'*',oscstr(1),'***'


      return
      end
      subroutine plset(ipl,nplmax,plengy,plwt,plbrd,ompl,wt,brd)
* Sets calculation parameters for a given pole in epsilon^{-1}
*        ipl - pole to set parameters for
*        nplmax - array dimensioning (maximum number of poles)
*        plengy - energy of poles (array)
*        plwt - weight of poles (array)
*        ompl - energy of selected pole
*        wt - weight of selected pole
*        adisp - dispersion parameter for selected pole
*        conc - electron density that would give plasma frequency
*               equal to pole energy
*        rs - Wigner Seitz radius that would give plasma frequency
*               equal to pole energy
*        ef - Fermi energy that would give plasma frequency
*               equal to pole energy
*        qf - Fermi momentum that would give plasma frequency
*               equal to pole energy
      implicit none
      integer ipl,nplmax
      double precision plengy(nplmax),plwt(nplmax),plbrd(nplmax)
      double precision ompl,wt,brd
*      double precision pi,adisp,conc,rs,ef,qf
      ompl=plengy(ipl)
      wt=plwt(ipl)
      brd=plbrd(ipl)
*      adisp=(0.75d0*pi/ompl**2)**(2.d0/3.d0)/3.d0
*      rs=(3.d0/ompl**2)**(1.d0/3.d0)
*      conc=3.d0/(4.d0*pi*(rs**3))
*      qf=((9.d0*pi/4.d0)**(1.d0/3.d0))/rs
*      ef=qf*qf/2.d0
      return
      end

      subroutine ppset(rs,pi,qf,ef,omp)
* Sets electron gas parameters for a given Wigner-Seitz radius rs.
*        rs - Wigner Seitz radius that would give plasma frequency
*               equal to pole energy
*        omp - plasma frequency
*        ef - Fermi energy that would give plasma frequency
*               equal to pole energy
*        qf - Fermi momentum that would give plasma frequency
*               equal to pole energy
      implicit none
      double precision rs,qf,ef,conc,omp,pi
      qf=((9.d0*pi/4.d0)**(1.d0/3.d0))/rs
      ef=qf*qf/2.d0
      conc=3.d0/(4.d0*pi*(rs**3))
      omp=dsqrt(4.d0*pi*conc)
      return
      end

c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c     sub-program exchange
!     program  ffmod2
      subroutine ffmod2

c     cross-section and phase shifts calculations
c     coded by a.ankudinov 2000

c     INPUT: mod2.inp geom.dat global.inp and pot.bin
c     OUTPUT: xsect.bin and xsph.bin

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

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
      character*6 potlbl
      dimension potlbl(0:nphx)
      dimension lmaxph(0:nphx), iatph(0:nphx), spinph(0:nphx)
      dimension rat(3, natx), iphat(natx)
      complex*16 ptz(-1:1, -1:1)

c     necessary input information from feff.inp file
c     see CARDs description in feff8 manual for more details
c     CONTROL mphase: 1-run (0-don't run)  the program
c     PRINT ipr2: for auxialry output files (default=0)
c     ispec: spectroscopy type (EXAFS, XANES, XES, DANES, FPRIME) 
c     vixan, xkstep, xkmax: energy grid for chosen spectroscopy
c     RDRIG rgrid: radial grid (default=0.05)
c     POTENTIAL info
c       nph: number of unique potentials
c       lmaxph: max orbital momentum for xsph calculations
c       potlbl: labels for unique potentials
c      ATOMS
c       nat: number of atoms
c       rat: their coordinates
c       iphat: type of potential for each site
c       iatph: representative atoms indices in atoms list
c      EXCHANGE ixc  vr0  vi0  ixc0 - exchange correlation model
c      RSIGMA (RPHASES) lreal (default=0)
c      FMS  rfms2 lfms2
       real rfms2
       integer lfms2
c      Global data
c        ipol - polarization type (default:0 - polarization average)
c        ispin - spin type (default=0 - spin independent)
c        le2 - include/exclude quad. transitions (default=2 - include)
c        angks - angle between x-ray propagation and spin (default=0)
c        ptz - polarization tenzor (default=0 for ipol=0)
      integer iPl, iGrid

      call par_begin
      if (worker) go to 400

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

c     read  INPUT data files: geom.dat, global.dat and mod2.inp.
c     Josh - added flag iPl for PLASMON card
      call rexsph(mphase, ipr2, ispec, vixan, xkstep,xkmax,gamach,rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl, iGrid,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis)

      if (mphase .eq. 1)  then
         call wlog(' Calculating cross-section and phases...')
         call xsph (ipr2, ispec, vixan, xkstep, xkmax, gamach, rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl, iGrid,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis)

         call wlog(' Done with module 2: cross-section and phases...')
      endif

c     OUTPUT: data for the next modules is written in xsph.bin
c     auxilary output can be obtained using 'ipr2' (see feff8.2 manual)

      close (unit=11)
  400 call par_barrier
      call par_end

c     sub-program exchange
!     stop
      return
      end
      subroutine axafs(em, emu, xsec,ne1,ik0)
c     extract axafs from xsec
c     written by a.l.ankudinov Dec. 1998

c     the file axafs.dat (format as in xmu.dat) will be written if
c     you use PRINT 0 1 0 0 0 0 (ipr2 > 0), and ran the second module.

c     the code draws a parabola using least mean square method
c     through xsec(i) * ee (i)**xn 
c     the weight for each point i, is defined as (ee(i)-E_F)**mm*
c     (ee(i+1)- ee(i-1)), where the last multiplier is used since the 
c     grid is not regular in energy.
c     E_F - energy that corresponds to Fermi level.

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      complex*16 em(nex), xsec(nex)
      dimension ee(nex), xmu(nex), wt(nex)
      dimension xx(0:4), yy(0:2), xm(3,3)

c     empirically I found that the best curve is drawn if xn=0 and mm=1
c     alex ankudinov, january 1999.
      xn = 0
      mm = 1
      np = ne1 - ik0
      ef = emu

      do 10 ie = 1, np
        ee(ie) = dble(em(ik0+ie)-em(ik0)) +emu
        xmu(ie) = dimag(xsec(ik0+ie)) * ee(ie)**xn
  10  continue
      do 20 ie = 1, np
        if (ie.eq.1) then
          wt(ie) = (ee(ie+1)-ef) * (abs(ee(ie)-ef))**mm
        elseif (ie.eq.np) then
          wt(ie) = (ee(ie)-ee(ie-1)) * (ee(ie)-ef)**mm
        else
          wt(ie) = (ee(ie+1)-ee(ie-1)) * (ee(ie)-ef)**mm
        endif
  20  continue
      do 30 i = 0, 4
  30  xx(i) = 0
      do 40 i = 0, 2
  40  yy(i) = 0

      do 100 ie = 1, np
         do 80 i = 0,4
  80     xx(i) = xx(i) + wt(ie)*ee(ie)**i
         do 90 i = 0,2
  90     yy(i) = yy(i) + wt(ie)*xmu(ie)*ee(ie)**i
 100  continue

      do 105 i=1,3
      do 105 j=1,3
 105  xm(i,j) = xx(i+j-2)
      denom = determ (xm, 3, 3)

      do 110 i=1,3
      do 110 j=1,3
 110  xm(i,j) = xx(i+j-2)
      do 120 i=1,3
 120  xm(i,1) = yy (i-1)
      aa = determ (xm,3,3)
      aa = aa / denom

      do 210 i=1,3
      do 210 j=1,3
 210  xm(i,j) = xx(i+j-2)
      do 220 i=1,3
 220  xm(i,2) = yy (i-1)
      bb = determ (xm,3,3)
      bb = bb / denom

      do 310 i=1,3
      do 310 j=1,3
 310  xm(i,j) = xx(i+j-2)
      do 320 i=1,3
 320  xm(i,3) = yy (i-1)
      cc = determ (xm,3,3)
      cc = cc / denom

c     find normalization at edge+100 eV
      eee = ee(1) + 100/hart
      xnorm = (aa+bb*eee+cc*eee**2) / eee**xn

      open (unit=1,file='axafs.dat', status='unknown')
      write (1,*) '# File contains AXAFS. See manual for details.'
      write (1,*)
     1 '#--------------------------------------------------------------'
      write(1,*) '#  e, e(wrt edge), k,',
     1           ' mu_at=(1+chi_at)*mu0_at, mu0_at, chi_at @#'
      do 400 ie = 1, np
        xmu(ie) = dimag(xsec(ie+ik0))
        xmu0 = (aa+bb*ee(ie)+cc*ee(ie)**2) / ee(ie)**xn
        chiat = (xmu(ie) - xmu0) / xmu0
        eee = ee(ie) -ef
        if (eee.ge.0.d0) then
           xk = sqrt(2*eee) /bohr
        else
           xk = -sqrt(-2*eee) /bohr
        endif
        write (1, 410) ee(ie)*hart, (ee(ie)-emu)*hart, xk,
     1              xmu(ie)/xnorm, xmu0/xnorm, chiat
 410    format (1x, 2f11.3, f8.3, 1p, 3e13.5)
 400  continue
      close (unit=1)

      return
      end
         

c     Josh - argument iPl has been added to arguments of xsect
      subroutine phase (iph, dx, x0, ri, ne, ne1, ne3, em,
     1                  ixc, nsp, lreal, rmt,rnrm, xmu,
     2                  vi0, iPl, gamach,
     2                  vtot, vvalgs, edens, dmag, edenvl,
     3                  dgcn, dpcn, adgc, adpc, eref, ph, lmax,
     2                  iz, ihole, xion, iunf, xnval, ispin)

      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     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        1 for real self energy and 2 for real phase shifts 
c     rmt          r muffin tin
c     xmu          fermi level
c     vi0          const imag part to add to complex potential
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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      complex*16 em(nex)
      dimension  ri(nrptx), vtot(nrptx), edens(nrptx)
      dimension  dmag(nrptx), vvalgs(nrptx), edenvl(nrptx)
      dimension  adgc(10,30), adpc(10,30), xnval(30)
      dimension  dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16  eref(nex)
      complex*16  ph(nex,-ltot:ltot)
      integer ispin

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, ck, xkmtp, xkmt, temp, pu, qu
      complex*16 jl(ltot+2), nl(ltot+2), jlp(ltot+2), nlp(ltot+2)

      complex*16 v(nrptx), vval(nrptx)
      character*512 slog
c     Josh - Added iPl switch for PLASMON card
c          - and WpCorr = Wi/Wp, Gamma, AmpFac
c          - to describe Im[eps^-1]
      integer iPl, ipole
      double precision WpCorr(MxPole), Gamma(MxPole), AmpFac(MxPole),
     &     rnrm
c     Josh END

c{#mn: g77 (and other compilers) have an intrinsic function besjn, 
c      so besjn should be declared  external 
         external besjn
c#mn}
c     zero phase shifts (some may not be set below)
      xkmax = 0
      ne12 = ne - ne3
      do 100  ie = 1, ne
         do 90  il = -ltot, ltot
            ph(ie,il) = 0
   90    continue
         if (ie.le.ne12 .and. xkmax.lt.dble(em(ie))) xkmax= dble(em(ie))
  100 continue
      xkmax = sqrt(xkmax * 2)

c     Use kmax to find accurate l-points
c     limit l, lmax = prefac* kmax * rmt
c     prefac is set not to have warning message for Cu metal for kmax=20
      prefac = 0.7d0
      lmax = prefac * rmt * xkmax
      lmax = max(lmax, 5)
      if (lmax.gt.ltot) then
        ik = nint( ltot / rmt / bohr / prefac )
        write (slog, 110) ik
  110   format('      Phase shift calculation is accurate to k=', i2)
        call wlog(slog)
        write (slog, 120)
  120   format('      See FEFF document to increase the range.')
        call wlog(slog)
      endif
      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)  call par_stop('jri .gt. nrptx in phase')

      ifirst = 0
      index = ixc
c     Josh - if PLASMON card is set, and using HL exc,
c          - read pole information from epsinv.dat
      IF( (iPl.gt.0).and.(ixc.eq.0) ) THEN
         open(file='exc.dat', unit=47, status='old',iostat=ios)
         call chopen(ios,'exc.dat','ffmod2(phase)')
         DO ipole = 1, MxPole
            call rdcmt(47,'#*cC')
            read(47,*,END=125) WpCorr(ipole), Gamma(ipole),
     &           AmpFac(ipole)
            Gamma(ipole)  = Gamma(ipole)/hart
            WpCorr(ipole) = (WpCorr(ipole)/hart) /
     &           SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)
         END DO
 125     CONTINUE
         WpCorr(ipole) = -1.d30
         CLOSE(47)
      END IF
      IF(ixc.eq.0) THEN
c     Write wp as calculated from density to sigma.dat
         open(file='mpse.dat', unit=45, status='replace', iostat=ios)
         call chopen(ios, 'sigma.dat', 'ffmod2(phase)')
         write(45,*) '# ', 'rs      wp(eV)'
         write(45,*) '# ', (3 / (4*pi*edens(jri+1))) ** third, 
     &        SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)*hart
         write(45,*) '# mu (eV)'
         write(45,*) '# ', xmu
         write(45,'(a)') 
     &         '# E-EFermi (eV)   Re[Sigma(E)] (eV)   Im[Sigma(E)] (eV)'
     &       // '   Re[Z]   Im[Z]   Mag[Z]   Phase[Z]   Lambda(E) (/A)'
      END IF
c     Josh END
      
c     calculate phase shifts
      do 220 ie = 1, ne12

c        Josh - xcpot now has new arguments:
c             - iPl, WpCorr, Gamma, AmpFac         
         call xcpot (iph, ie, index, lreal, ifirst, jri,
     1               em(ie), xmu,
     2               vtot, vvalgs, edens, dmag, edenvl,
     3               eref(ie), v, vval, iPl, WpCorr, Gamma, AmpFac,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim, rnrm)

         if (dble(em(ie)).lt.-10.d0 .or. dble(em(ie)) .gt.3.d2) goto 220
c        p2 is (complex momentum)**2 referenced to energy dep xc
c        notice that constant Im part (gamach/2+vi0) is cancelled,
c        since it is also present in v and vval.
         p2 = em(ie) - eref(ie) 
         if (lreal.gt.1 .and. ie.le.ne1) p2 = dble(p2)
         ck =  sqrt (2*p2+ (p2*alphfs)**2)
         xkmt = rmt * ck
         if (dble(p2).le.0.d0 .and. dimag(p2) .le.0.d0) goto 220

c{#mn  see note above about declaring besjn as external
c#mn}
         call besjn (xkmt, jl, nl)

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

         do 210  ll = -lmax, lmax
            il = abs(ll) +  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
            endif

c  v should be V_N+V_COUL+V_XCtotal-V_mt, vval= V_N+V_COUL+V_XCVAL-V_mt
            ikap = ll - 1
            if ( ll.gt.0 ) ikap=ll
            ilp = il + 1
            if (ikap.gt.0) ilp = il - 1
            ic3 = 0

            if(nsp.eq.1 .and. ispin.eq.0) then
c              remove spin-orbit interaction
c              otherwise, get wrong results e.g. for Pt metal
               if (ll.ne.0) ic3 = 1
               ikap = -1 - abs(ll)
               ilp = il + 1
            endif

c_lz  add term (C L_z) (p.32 of Ankoudinov's thesis) 
c     currently just add constant potential only within mt radius
c     keep intersitial level the same
c OPC for U for jj coupling
c           if (ll.eq.3 .and. iph.eq.1) then
c              clz = -0.5d0 / hart
c              if (ispin.lt.0) clz = -clz
c              do 180 i = 1, jri
c                 v(i) = v(i) + clz
c                 vval(i) = vval(i) + clz
c180           continue
c           endif
c OPC for U for LS coupling
            if (abs(ll).eq.3 .and. iph.eq.1 .and. ispin.eq.1) then
               clz = -0.0d0 / hart
               if (ikap.lt.0) clz = -clz
               do 180 i = 1, jri
                  v(i) = v(i) + clz
                  vval(i) = vval(i) + clz
 180           continue
            endif

c           never use irr=0, only positive or negative
            irr = -1
            call dfovrg (ncycle, ikap, rmt, jri, jri, p2, dx,
     1               ri, v,vval, dgcn, dpcn, adgc, adpc,
     1               xnval, pu, qu, p, q,
     1               iz, ihole, xion, iunf, irr, ic3)

c        restore potential for clz=0
c OPC for U for jj coupling
c           if (ll.eq.3 .and. iph.eq.1) then
c OPC for U for LS coupling
            if (abs(ll).eq.3 .and. iph.eq.1 .and. ispin.eq.1) then
               do 190 i = 1, jri
                  v(i) = v(i) - clz
                  vval(i) = vval(i) - clz
 190           continue
            endif
            call phamp (rmt, pu, qu, ck, jl(il), nl(il),
     1                  jl(ilp), nl(ilp), ikap, ph(ie,ll), temp)

c           cut phaseshift calculation if they become too small
            if (abs(ph(ie,ll)) .lt. 1.0e-6 .and. ll.ge.4)  goto 220
c           new cut function introduced by Rivas
            if(abs(exp((0,2)*ph(ie,ll))-1.).lt.1.0e-5) ph(ie,ll)=0
            if (abs(ph(ie,ll)) .lt. 1.0e-5 .and. ll.ge.4)  goto 220

  210    continue
  220 continue
c     Josh - Close sigma.dat
      close(45)
c     Josh END

      do 230 ie = ne12+1, ne
  230 eref(ie) = eref(ne1)

      return
      end
      SUBROUTINE phmesh2 (iprint, ispec, edge, emu, vi0, gamach,
     &     xkmax, xkstep, vixan, ne, ne1, em, ik0, ne3, iGrid)
!     This subroutine makes the energy mesh used for phases and cross sections,
!     as well as for the fms routine, path, and genfmt. For EXAFS, the final output
!     chi is on a different (usually finer) grid with mu0 interpolated.
!     This will reproduce the old (FEFF84) grids, as well as any combination of user
!     defined energy, k, exponential, or arbitrary (read from file) grids. The input
!     for the user defined grids is read from grid.inp. Details of grid.inp are given
!     in rdgrid.f
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

!     Input:
!     iprint - if > 3, print emesh.dat
!     ispec  - controls which grid to use (0=EXAFS,1=XANES,2=XES,3=DANES,4=FPRIME)
!     edge   - This name is misleading and is not the x-ray edge energy.
!              edge = xmu - vr0, where vr0 is given as an the first option in the
!              EXCHANGE card.
!     vi0    - Contant imaginary part added to the potential, second option in the
!              EXCHANGE card.
!     gamach - Core-Hole broadening. Gives an additional constant imaginary part to
!              the potential.
!     xkmax  - maximum k value for EXAFS/XANES calculations. holds emin for f'
!              calculations.
!     xkstep - k-grid spacing for XANES calculations. holds emax for f' calculations
!     vixan  - energy step for FMS calculations (grid is even in energy near edge)
      INTEGER iprint, ispec
      DOUBLE PRECISION edge, emu, vi0, gamach, xkmax, xkstep, vixan
      
!     Output:
!     ne     - Total number of energy points.
!     ne1    - Number of energy points on the horizontal grid.
!     ik0    - point where k=0
!     em(ne) - energy array
      INTEGER ne, ne1, ik0
      COMPLEX*16 em(nex)

!     Local Variables:
!     xloss  - total constant imaginary part of em
!     xim    - energy step near the fermi level
!     deltak - k step
!     emin   - minimum e for exponential grid used by DANES
!     emax   - maximum e for exponential grid used by DANES
!     del    - step for exponential grid
!     ios    - i/o errors
!     nemax  - temp variable to hold max # of energy points
      DOUBLE PRECISION xloss, xim, deltak, emin, emax, del
      INTEGER ios
!     User defined grid variables
!     nGridMax  - max number of grids
!     nGrid     - number of grids.
!     iGridType - Type of grid (1 = energy, 2 = k, 3 = exp)
!     GridMin   - minimum k or E of grid. k for k-grids, e for others
!     GridMax   - Maximum k or E of grid
!     GridStep  - step size.
      INTEGER nGridMax
      PARAMETER(nGridMax=10)
      INTEGER nGrid, iGridType(nGridMax)
      DOUBLE PRECISION GridMin(nGridMax), GridMax(nGridMax),
     &     GridStep(nGridMax)
      
!     Loop Variables:
      INTEGER i1
      DOUBLE PRECISION getxk
      EXTERNAL getxk
!     Initialization
!     Set total imaginary part, must be >= 0.02 eV
      xloss = MAX(gamach/2.d0 + vi0, 0.02/hart)
!     Set energy step to half of imaginary part, or
!     vixan if vixan is set.
      IF(vixan.gt.0.0001) THEN
         xim = vixan
      ELSE
         xim = xloss/2.d0
      END IF

      ik0 = 0
      
      IF(iGrid.eq.0) THEN
!     Use FEFF84 grids
         IF(ispec.eq.0) THEN
            ne = 1
            CALL ExafsGrid84(em, xkmax, ne, nex)
            ne1 = ne
            ik0 = 1
         ELSEIF((ABS(ispec).gt.0).and.(ABS(ispec).lt.4)) THEN
!     Use same grid for XANES, XES, DANES
            CALL XanesGrid84(em, xkmax, xkstep, xim, ne, ik0, nex)            
            ne1 = ne
         ELSEIF(ispec.eq.4) THEN
!     FPRIME
            CALL FPrimeGrid84(em, xkmax, xkstep, vixan, emu, edge, ne,
     &           ne1, ne3, nex)
         END IF
         
!     If ispec is negative, we are not running FMS. Make EXAFS grid
!     for points above the fermi level.
         IF(ispec.lt.0) THEN
            ne = 11
            CALL ExafsGrid84(em, xkmax, ne, nex)
            ne1 = ne
         END IF
      ELSE
!     User defined grids.
         ! Make sure there are enough points left over to make vertical grid etc.
         nemax = nex - 50
         ne = 0
         CALL RdGrid(em,ne,nGrid,iGridType,GridMin,GridMax,GridStep,
     &        nGridMax,nemax)

         DO i1 = 1, nGrid
            IF(iGridType(i1).eq.1) THEN
               ! grid is regular in energy
               ne = ne + 1
               CALL MkEMesh(em, ne, GridMin(i1), GridMax(i1),
     &              GridStep(i1), NPts, nex)
               ne = MIN(ne + NPts, nemax)
            ELSEIF(iGridType(i1).eq.2) THEN
               ! grid is regular in k
               ne = ne + 1
               CALL MkKMesh(em, ne, GridMin(i1), GridMax(i1),
     &              GridStep(i1), NPts, nex)
               ne = MIN(ne + NPts, nemax)
            ELSEIF(iGridType(i1).eq.3) THEN
               ! grid is exponential
               ne = ne + 1
               CALL MkExpMesh(em, ne, GridMin(i1), GridMax(i1),
     &              GridStep(i1), NPts, nex)
               ne = MIN(ne + NPts, nemax)
            END IF
         END DO
         
!        Add a point at E = 0 in case there is not one.
         IF(ne+1.lt.nex) THEN
            em(ne+1) = 0.d0
            ne = ne + 1
         ELSE
            em(ne) = 0.d0
         END IF
!        Now, sort energy grid and remove degenerate points.
         CALL SortE(em,ne,ik0,nex)
         ne1 = ne
      END IF

!     If XES, flip grid about 0.0
      IF(ABS(ispec).eq.2) CALL ReverseGrid(em,ne,0.d0)
         
!     Shift horizontal grid by edge + coni*xloss.
      IF(ispec.ne.4) THEN
         DO i1 = 1, ne
            em(i1) = em(i1) + edge + coni*xloss
         END DO
      END IF

!     If not fprime calculation, make vertical grid
      IF(ispec.ne.4) THEN
         ne = ne + 1
         CALL MkVGrid84(em, ne, xloss, nex)
!     Shift vertical grid by edge.
         DO i1 = ne1+1, ne
            em(i1) = em(i1) + edge
         END DO
      END IF
         
      IF(ABS(ispec).eq.3) THEN
!     DANES: add more points to horizontal grid.
         ne3  = MIN(nex,150) - ne
         emin = DBLE(2*em(ne1)-em(ne1-1))
         emax = 7.d4
         del  = LOG(emax/emin)/(ne3-1)
         ne = ne + 1
         CALL MkExpMesh(em, ne, emin, emax, del, ne3, nex)
         DO i1 = 0, ne3 - 1
            em(ne+i1) = em(ne+i1) + coni*1.d-8
         END DO
         ne = ne + ne3
      END IF      

      IF (iprint .ge. 3)  THEN
         OPEN (unit=44, file='emesh.dat', status='unknown')
         WRITE(44,*) 'edge, bohr, edge*hart ', edge, bohr, edge*hart
         WRITE(44,*) 'ispec, ik0 ', ispec, ik0
         WRITE(44,*) 'ie, em(ie)*hart, xk(ie)'
         DO ie = 1, ne
           WRITE (44,'(i5, 3f20.5)') ie, dble(em(ie))*hart,
     &                   getxk(dble(em(ie))-edge)/bohr
        END DO
         CLOSE(unit=44)
      endif

      RETURN
      END

      SUBROUTINE MkVGrid84(em, ne, xloss, nex)
!     make the vertical grid in energy plane
!     first point is at 0.005 ev, second at 0.01 ev and
!     exponential grid with step 0.4 after that up to 50 eV
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
!     Input:
!     ne    - first energy point
!     nex   - length of em array
!     xloss - total imaginary part of horizontal grid
      INTEGER ne, nex
      DOUBLE PRECISION xloss

!     Output:
!     ne      - number of energy points
!     em(nex) - energy grid
      COMPLEX*16 em(nex)

!     Local Variables:
!     n1     - number of points in exponential grid
!     estep0 - first two points are at estep0/2 and estep0
!     del    - spacing: em(j) = emin*exp(j*del)
!     expdel - exp(del)
!     emin   - minimum energy in exponential grid.
!     emax   - max energy in exponential grid
      INTEGER n1
      DOUBLE PRECISION estep0, del, expdel, emin, emax

!     Loop Variables:
      INTEGER i1

      estep0 = 0.01/hart
      em(ne) = coni*estep0/2
      em(ne+1) = coni*estep0
      ne = ne + 2
!     Exponential grid em(ne+1*j) = emin*exp(j*del)
!     del = 0.6 is ok for Cu K edge, but needs more testing
      del = 0.4d0

!     n1 is the # of points in a grid defined by estep0*exp(j*del) that lie below xloss.
      n1 = NINT(LOG(xloss/estep0)/del - 0.5)
      if (n1.le.0) n1 = 1

!     Now redefine the grid so that xloss is halfway between em(n) and em(n+1) 
!     Solving
!     xloss = [em(n1) + em(n1+1)]/2 = emin*[exp(n1*del) + exp((n1+1)*del)]/2
!     gives
!     emin = 2*xloss/(1+exp(del))*exp(-n1*del)
      expdel = EXP(del)
      emin = 2*xloss /(1+expdel)/expdel**n1
      if (emin.le.estep0) emin = emin*expdel

c     Josh         if (emin.le.estep0 .or. emin.ge.xloss) 
c     Josh     .     call par_stop(' Bad mesh in phmesh')
c     delk = log (xloss/tempk) /(n1+0.5)

!     Now change grid so that endpoint is at emax.
      emax = MIN(50.d0/hart,20.d0*xloss)
      CALL MkExpMesh(em, ne, emin, emax, del, n1, nex)
      DO i1 = 0, n1
         em(ne+i1) = (0,1)*em(ne+i1)
      END DO
      ne = ne + n1

      RETURN
      END
      
      SUBROUTINE MkExpMesh(em, iStart, emin, emax, del, NPts, nex)
      
      INTEGER iStart, nex
      DOUBLE PRECISION emin, emax, del
      COMPLEX*16 em(nex)
      
      INTEGER NPts

      INTEGER i1

      NPts = NINT( log(emax/emin) / del )

!     Fill grid
      DO i1 = 0, NPts
         em(iStart+i1) = emin*exp(del*i1)
      END DO
         
      RETURN
      END


      SUBROUTINE ExafsGrid84(em, xkmax, ne, nex)
!     Make old (FEFF8.4) grid for EXAFS calculations.
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
!     Input: 
!     xkmax - maximum k for grid
!     nex   - length of array em
      INTEGER nex
      DOUBLE PRECISION xkmax

!     Output:
!     em(nex) - energy grid array
!     ne      - number of points in energy grid
      COMPLEX*16 em(nex)
      INTEGER ne

!     Local Variables:
!     NPts   - Number of points that have been added to grid after a call
!              to MkKMesh
!     nemax  - maximum number of energy points (100)
!     deltak - k step (used when calling MkKMesh)
!     xkmin  - minimum (k used when calling MkKMesh)
!     xkmax2 - maximum (k used when calling MkKMesh)
      INTEGER NPts, nemax
      DOUBLE PRECISION deltak, xkmin, xkmax2, eps
      PARAMETER (small = 1.d-20)
      nemax = 100

!     20 pts (0 le k le 1.9, delk=0.1 ang(-1) )
      deltak = bohr/10
      xkmin = 0.d0
      xkmax2  = bohr*1.9d0*1.01d0
      CALL MkKMesh(em, ne, xkmin, xkmax2, deltak, NPts, nex)

!     20 pts (2 le k le 5.8, delk=0.2 ang(-1) )
      ne = ne + NPts + 1
      deltak = bohr/5
      xkmin  = bohr*2.d0
      xkmax2 = bohr*5.8d0*1.01d0
      CALL MkKMesh(em, ne, xkmin, xkmax2, deltak, NPts, nex)

!     9 pts (6 le k le 10., delk=0.5 ang(-1) )
      ne = ne + NPts + 1
      xkmin = bohr*6.d0
      xkmax2 = bohr*10.d0*1.01d0
      deltak = bohr*0.5d0
      CALL MkKMesh(em, ne, xkmin, xkmax2, deltak, NPts, nex)

!     make the rest of the points pts with deltak = 1.0 ang(-1)
      ne = ne + NPts + 1
      deltak = bohr
      xkmin = SQRT(2*DBLE(em(ne-1))) + deltak
!     Fill to end of grid, or max # of points.
      NPts = MIN(nemax-ne,NINT((xkmax-xkmin)/deltak)+1)
      xkmax2 = xkmin + (NPts)*deltak*1.01d0
      CALL MkKMesh(em, ne, xkmin, xkmax2, deltak, NPts, nex)
      ne = ne + NPts

      RETURN
      END

      SUBROUTINE XanesGrid84(em, xkmax, xkstep, estep, ne, ik0, nex)
!     Make old (FEFF8.4) grid for XANES calculations.
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
!     Input: 
!     xkmax  - maximum k for grid
!     xkstep - kstep at high k
!     estep  - estep near the fermi level
!     nex    - length of array em
      INTEGER nex
      DOUBLE PRECISION xkmax, xkstep, estep

!     Output:
!     emin    - -xim*n1
!     em(nex) - energy grid array
!     ik0     - zero point for k grid
      INTEGER ne
      COMPLEX*16 em(nex)

!     Local Variables:
      INTEGER n1, n2, nk, nemax, NPts
      DOUBLE PRECISION emin, emax, xkmin, dk, xkmax2
!     Make 10 points below fermi level
      nemax = 10
!     double k step below fermi level 
      dk = 2*xkstep
!     Not sure why to pick this number of steps regular in e?
      n1 = INT(estep/2/dk**2)
!     n2 is starting point of k grid minus 1 (int(k(emax)/dk) + 1)
      n2 = INT(SQRT(n1*2*estep)/dk)
!     If we can fit one more point in the egrid, do it
      If( (dk*(n2+1))**2 .gt. (n1+1)*2*estep ) n1 = n1+1

!     Make sure we don't use more than nemax points
      n1 = MIN(n1,nemax)
!     nk is number of points in k grid
      nk = nemax - n1

!     Fill k grid
      xkmin = -dk*(n2+nk)
      xkmax2 = -dk*(n2+1)
      ne = 1
      CALL MkKMesh(em, ne, xkmin, xkmax2, dk, nk, nex)  
      
!     Fill e grid
      ne = ne + nk + 1
      emin = -estep*n1
      emax = 0.d0
      CALL MkEMesh(em, ne, emin, emax, estep, NPts, nex)
      ne = ne + NPts + 1
      ik0 = ne
!     Fill grid above the fermi level.
!     Same grid as before except that k spacing is xkstep, and 90 points
      nemax = 90
!     Not sure why to pick this number of steps regular in e?
      n1 = INT(estep/2/xkstep**2)
!     n2 is starting point of k grid minus 1
      n2 = INT(SQRT(n1*2*estep)/xkstep)
      n1 = n1 + 1
!     If we can fit one more point in the egrid, do it
      If( (xkstep*(n2+1))**2 .gt. (n1)*2*xim ) n1 = n1+1
!     Make sure we don't use more than nemax points
      n1 = MIN(n1,nemax)

!     nk is number of points in k grid
      nk = nemax - n1

!     This time fill e grid first
      emin = estep
      emax = (n1-1)*estep
!     If k(emax) > xkmax set emax = e(xkmax) and nk = 0
      IF(SQRT(2*emax).gt.xkmax) THEN
         emax = xkmax**2/2
         nk = 0
      END IF
      CALL MkEMesh(em, ne, emin, emax, estep, NPts, nex)
 
!     Now fill k grid
      ne = ne + NPts + 1
      xkmin = xkstep*(n2+1)
      xkmax2 = xkstep*(n2+nk)
!     if xkmax2 > xkmax, set xkmax2 = xkmax
      IF(xkmax2.gt.xkmax) xkmax2 = xkmax
      CALL MkKMesh(em, ne, xkmin, xkmax2, xkstep, NPts, nex)  
      ne = ne + NPts
      
      RETURN
      END
      
      SUBROUTINE FPrimeGrid84(em,emin,emax,estep,emu,edge,ne,
     &     ne1,ne3,nex)
!     Make old (FEFF84) grid for FPRIME calculation
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c      include '../HEADERS/dim.h'
!     Input:
!     emin  - minimum energy
!     emax  - maximum energy
!     estep - energy step
!     emu   - x-ray edge energy
!     edge  - fermi level (xmu-vr0)
!     nex   - size of em array
      DOUBLE PRECISION emin, emax, estep, emu, edge
      INTEGER nex

!     Output:
!     ne      - total number of points in energy grid
!     ne1     - number of energy points in regular grid
!     em(nex) - energy grid
      INTEGER ne, ne1, ne3
      COMPLEX*16 em(nex)
      
!     Local variables:
!     nemax - maximum number of points in constant energy grid
!     del   - step for exponential grid.
!     
      INTEGER nemax
      DOUBLE PRECISION del, del2, elimit
!     Loop Variables:
      INTEGER i1
!     Initialization
      nemax = 100

      emin  = emin/bohr/hart - emu 
      emax  = emax/bohr/hart - emu

!     Fill a grid from emin to emax taking steps estep.
      em(1) = emin
      ne = 1
      IF(emin.lt.emax) THEN
         IF(estep.le.0.d0) estep = (emax-emin)/(nemax-1)
         ne = MIN(nemax,NINT((emax-emin)/estep))       
         DO i1 = 1, ne
            em(i1) = emin + (i1)*estep
         END DO
      END IF
      ne1 = ne

!     Now fill another grid for the KK-Transform
      nemax = MIN(nex-ne,100)
      del = 3.d0/hart

!     Set elimit = 20*emu, but make sure that 1.d3 .le. elimit .le. 2.d5
      elimit = MAX(1.d3/hart,MIN(20*emu,2.d5/hart))
      elimit = elimit - emu
      
      ne3 = nemax
      em(ne1+1) = edge
      DO i1 = 1, ne3-1
         del2 = 0
         IF(DBLE(em(ne1+i1)).gt.0.d0) del2 = em(ne1+i1)*
     &        (EXP( LOG( elimit/em(ne1+i1) ) / (ne3-i1) ) -1)
         em(ne1+i1+1) = em(ne1+i1) + MAX(del,del2)
      END DO
      ne = ne1 + ne3

      RETURN
      END

      SUBROUTINE ReverseGrid(em,ne,ZeroPoint)
!     Flips a grid about ZeroPoint.
!     Input:
!     em(ne)    - array to flip
!     ne        - number of elements
!     ZeroPoint - point to flip about
      INTEGER ne
      COMPLEX*16 em(ne), eTmp
      DOUBLE PRECISION ZeroPoint

!     Loop Variables
      INTEGER i1, i2, np
      np = ne/2
      DO i1 = 1, ne
         em(i1) = ZeroPoint - em(i1)
      END DO

      DO i1 = 1, np
         eTmp = em(i1)
         em(i1) = em(ne+1-i1)
         em(ne+1-i1) = eTmp
      END DO            
      
      RETURN
      END

      SUBROUTINE MkEMesh(em, iStart, emin, emax, estep, NPts, nex)
!     Make a grid even in k-space from xkmin to xkmax with grid spacing
!     deltak. If xkmin > xkmax, do nothing
      IMPLICIT NONE
!     Input
!     em(nex) - energy grid
!     iStart  - index of em to start at.
!     emin    - starting k
!     emax    - ending k
!     estep   - k spacing
!     nex     - lenth of em array
      INTEGER iStart, nex
      COMPLEX*16 em(nex)
      DOUBLE PRECISION estep, emin, emax

!     Output:
!     NPts    - index of the last point added to the energy grid.
      INTEGER NPts

!     Loop variables
      INTEGER i1

      NPts = NINT((emax - emin)/estep) 
      IF(NPts.le.0) THEN
         NPts = 0
         RETURN
      END IF
      DO i1=0, NPts
         IF(i1.le.nex) THEN 
            em(iStart + i1) = emin + estep*i1
         ELSE
c            CALL wlog('Energy grid is too large: truncating.')
            EXIT
         END IF
      END DO

      RETURN
      END

      
      SUBROUTINE MkKMesh(em, iStart, xkmin, xkmax, deltak, NPts, nex)
!     Make a grid even in k-space from xkmin to xkmax with grid spacing
!     deltak.
      IMPLICIT NONE
!     Input
!     em(nex) - energy grid
!     iStart  - index of em to start at.
!     xkmin   - starting k
!     xkmax   - ending k
!     deltak  - k spacing
!     nex     - lenth of em array
      INTEGER iStart, nex
      COMPLEX*16 em(nex)
      DOUBLE PRECISION deltak, xkmin, xkmax

!     Output:
!     NPts    - index of the last point added to energy grid.
      INTEGER NPts

!     Loop variables
      INTEGER i1, isgn

      NPts = NINT((xkmax - xkmin)/deltak) 
      IF(NPts.le.0) THEN
         NPts = 0
         RETURN
      END IF
      isgn = 1
      IF(xkmin.lt.0.d0) isgn = -1
      DO i1=0, NPts
         IF(i1.le.nex) THEN 
            em(iStart + i1) = isgn*(xkmin + deltak*(i1))**2/2
         ELSE
c            CALL wlog('Energy grid is too large: truncating.')
            EXIT
         END IF
      END DO

      RETURN
      END
 

      SUBROUTINE WrtE(em, ne, fl)
!     WrtE made for debugging.
      INTEGER ne, iU
      COMPLEX*16 em(ne)
      CHARACTER*(*) fl
      CHARACTER(300) fl2
      INTEGER i1

      fl2 = 'DEBUG/' // fl
      iU = 23
      OPEN(unit=iU,file=fl2,status='replace')
      DO i1 = 1, ne
         WRITE(iU,*) i1, em(i1)
      END DO
      CLOSE(iU)

      RETURN
      END

      SUBROUTINE SortE(em,ne,ik0,nex)
!     Sorts energy array em, eliminating degenerate points.
!     Also, set ik0.
!     Input:
!     ne     - number of energy points
!     em(ne) - energy grid
      INTEGER ne
      COMPLEX*16 em(ne)

!     Output: sorted array of energies, and number of unique energy points.
!     Also ik0
      INTEGER ik0

!     Local Variables:
!     RealE(nex)  - Re[em]
!     iOrder(nex) - Holds ordering for em.
!     nUE         - number of unique energy points
!     tol         - tolerence for degeneracy of energy points (in eV)
      DOUBLE PRECISION RealE(nex), E0, tol
      INTEGER iOrder(nex), nUE
      
!     Loop Variables:
      INTEGER i1, i2
      
      PARAMETER(tol = 0.001d0)
      ik0 = -1
      
      DO i1 = 1, ne
         RealE(i1) = DBLE(em(i1))
      END DO

!     Do sorting of RealE.
      CALL qsorti(iOrder,ne,RealE)
      
!     Replace em with sorted values and remove degeneracy.
      nUE   = 1
      IF((ABS(RealE(iOrder(1))).lt.tol)) THEN
         em(1) = 0.d0
         ik0 = 1
      ELSE
         em(1) = RealE(iOrder(1))
      END IF

!     Remove degenerate points
      DO i1 = 2, ne
         
!        find next point that is not degenerate and set next em to the
!        value of the non-degenerate point.
         DO i2 = i1, ne
            PRINT*, ABS(RealE(iOrder(i2))-DBLE(em(i1-1)))
            IF(ABS(RealE(iOrder(i2))-DBLE(em(i1-1))).gt.tol) THEN
               nUE = nUE + 1
               em(nUE) = RealE(iOrder(i2))
               EXIT
            END IF
         END DO
      END DO
      PRINT*, nUE, ne      
      ne = nUE
      
!     Set ik0
      ik0 = 1
      E0 = ABS(DBLE(em(1)))
      DO i1 = 1, nUE
         IF(ABS(DBLE(em(i1))).lt.E0) THEN
            PRINT*, em(i1), E0
            E0 = ABS(DBLE(em(i1)))
            ik0 = i1
         END IF
      END DO
      PRINT*, ik0
      em(ik0) = 0.d0
      
      RETURN
      END
c     make e mesh for phase
c     input:  iprint, ispec, edge, vi0, gamach, xkmax, xkstep
c     output: ne, ne1, em(ne), ik0 [grid point with k=0]
c             ne -  total number of points in array em
c             ne1 - number of points on horizontal grid 

      subroutine phmesh (iprint, ispec, edge, emu, vi0, gamach, ecv,
     1                  xkmax, xkstep, vixan, ne, ne1, em, ik0, ne3)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 em(nex), tempc

c     see arrays.h
c#mn
      external getxk

c     nemax - max number of points on horizontal axis
      xloss = gamach/2 + vi0
      if (xloss.lt.0) xloss = 0
      xvert = max(xloss, 0.02/hart)
      xloss = xvert
      aa = 0.5d0
      ne3 = 0
      xim = xloss*aa
      if (vixan.gt.0.0001) xim = vixan
      ik0 = 0

      if (ispec.le.3)  then
c        make energy mesh for XANES with FMS
c        around fermi level step is regular in energy (xloss/2)
c        and regular in k at high energies

c        10 points below Fermi level
         nemax = 10
c        dk = 0.14*bohr
         dk = 2*xkstep
         n1 = int (xim/2/dk**2)         
         n2 = int ( sqrt(n1*2*xim) / dk )
         if ( (dk*(n2+1))**2 .gt. (n1+1)*2*xim ) n1 = n1+1
         n1 = min (n1,nemax)
         do 10 i = 1, n1
  10     em(nemax+1-i) = -xim*i + edge + coni*xloss
         nb = nemax-n1
         do 20 i = 1, nb
  20     em(nb + 1 -i) = -(dk*(n2+i))**2/2 + edge + coni*xloss
         nmin = nemax
         ik0 = nemax+1
      endif

      if (ispec .gt. 0 .and. ispec.le.3)  then
c        make energy mesh for XANES with FMS
c        around fermi level step is regular in energy (xloss/2)
c        and regular in k at high energies
c        90 points above Fermi level
         nemax = 100 - nemax 
         n1 = int (xim/2/xkstep**2)
         n2 = int ( sqrt(n1*2*xim) / xkstep )
         n1 = n1 + 1
         if ( (xkstep*(n2+1))**2 .gt. n1*2*xim ) n1 = n1+1
         n1 = min (n1,nemax)
         if (ispec.ne.2) then
            nb = int (xkmax**2 /xim/2) + 1
         else
            nb = int (abs(edge - xkmax/bohr/hart) /xim) + 1
         endif
         if (nb .le. n1) n1 = nb
         do 30 i = 1, n1
  30     em(nmin+i) = xim*(i-1)
         if (ispec.ne.2) then
            nb = int( xkmax / xkstep)  - n2
         else
            nb = int( sqrt(abs(2*(edge-xkmax/bohr/hart))) / xkstep) - n2
         endif
         nb = min(nb, nemax-n1)
         nb = max(nb,0)
         do 40 i = 1, nb
  40     em(nmin+n1+i) = (xkstep*(n2+i))**2 /2
         ne1 = nmin+n1+nb
         do 50 i = ik0, ne1
  50     em(i) = em(i) + edge + coni*xloss

      elseif (ispec.eq.4) then
c        grid for atomic f' calculation regular in energy
         nemax = 100
         emin = xkmax / bohr /hart
         emax = xkstep / bohr / hart
         ne = 1
         emin = emin - emu + edge
         emax  = emax - emu + edge
         em(1) = emin
         if (emin .lt. emax) then
            if (vixan.le.0.d0) vixan = (emax-emin) / (nemax-1)

  85        ne = ne + 1
            em(ne) = em(ne-1) + vixan
            if ( ne.lt.nemax .and. dble(em(ne)).lt.emax) goto 85
         endif

         ne1 = ne
         nemax = nex-ne
         if (nemax.gt.100) nemax=100
         de = 3.d0 /hart
         elimit = min (2.0d5/hart, 20*emu)
         elimit = max (elimit, 1.0d3/hart)
         elimit = elimit - emu

         ne2 = 0
         ne3 = nemax
         ne = ne1+ne2+ne3
         em(ne1+1) = edge
         do 88 i = 1,ne3-1
            dep = 0
            if (dble(em(ne1+i)).gt.0) 
     1      dep=em(ne1+i)*(exp( log( elimit/em(ne1+i) ) / (ne3-i) ) -1)
            if (dep.lt.de) dep = de
            em(ne1+i+1) = em(ne1+i) + dep
  88     continue
      else
c        energy mesh for EXAFS or XANES without FMS
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
         if (ispec.lt.0) ne = 10
         nemax = 100
         delk = bohr/10
         do 111 i=1,20
            tempk=(i-1)*delk
            ne = ne+1
            em(ne)=tempk**2/2 +edge + coni*xloss
            if (i.eq.1)  ik0 = ne
  111    continue
         delk = bohr/5
         n2 = 20
         do 112 i=1,n2
            tempk=2*bohr + (i-1)*delk
            ne = ne+1
            em(ne)=tempk**2/2 +edge + coni*xloss
  112    continue
         delk = bohr/2
         do 113 i=1,9
            tempk=6*bohr + (i-1)*delk
            ne = ne+1
            em(ne)=tempk**2/2 +edge + coni*xloss
  113    continue
         delk=bohr
         do 114 i=1,10
            tempk=11*bohr + (i-1)*delk
            ne = ne+1
            em(ne)=tempk**2/2 +edge + coni*xloss
  114    continue

c        while loop
  115    if (tempk. lt.xkmax) then
            tempk = tempk + delk
            ne = ne+1
            em(ne)=tempk**2/2 +edge + coni*xloss
            goto 115
         endif

         ne = min (ne, nemax)
         ne1 = ne
      endif

      if (ispec.le.3)  then
c        make the vertical grid in energy plane
c        first point is at 0.005 ev, second at 0.01 ev and
c        exponential grid with step 0.4 after that up to 50 eV
         tempk = 0.005d0/hart
         em(ne1+1) = edge + coni*tempk
         tempk = tempk*2
         em(ne1+2) = edge + coni*tempk
c        chose delk that point edge+coni*xloss is in the middle of step
c        delk = 0.6 is ok for Cu K edge, but needs more testing
         delk = 0.4d0
         n1 = nint ( log(xloss/tempk)/delk - 0.5d0)
         if (n1.le.0) n1 = 1
         bb = exp(delk)
         aa = 2*xloss /(1+bb)
         aa = aa/bb**n1
         if (aa.le. tempk) aa = aa*bb
cJosh         if (aa.le.tempk .or. aa.ge. xloss) 
cJosh     .     call par_stop(' Bad mesh in phmesh')
c        delk = log (xloss/tempk) /(n1+0.5)
c        n1 = nint( log(1000/hart/tempk) / delk )
c        n1 = nint( log(50/hart/aa) / delk )
         ee = min(50.d0/hart,20.d0*xloss)
         print*, ee, aa, xloss, n1
         n1 = nint( log(ee/aa) / delk )
         do 60 i = 0, n1
  60     em(ne1+3+i) = edge +coni*aa*exp(delk*i)
         ne = ne1 + n1 + 3

c        for DANES need additional points
         if (abs(ispec).eq.3) then
            ne3 = min(nex,150) - ne
            em(ne+1) = dble(2*em(ne1)-em(ne1-1))
            dk = log(7.d4/dble(em(ne+1))) / (ne3-1)
            dk = exp(dk)
            do 80 i = 1, ne3-1
  80        em(ne+i+1)= em(ne+i)*dk
            do 90 i = 1, ne3
  90        em(ne+i)= em(ne+i)+coni*1.d-8
            ne = ne + ne3
            
         endif
      endif

c     need to reverse order for horizontal grid for XES
      if (ispec.eq.2) then
         do 150 ie = 1, ne1
  150    em(ie) = 2*(edge + coni*xloss) - em(ie)
         np = ne1 / 2
         do 160 ie=1,np
            ip = ne1+1-ie
            tempc = em(ie)
            em(ie) = em(ip)
            em(ip) = tempc
  160    continue
         ik0 = ne1+1-ik0
      endif

      if (iprint .ge. 3)  then
         open (unit=44, file='emesh.dat', status='unknown')
         write(44,*) 'edge, bohr, edge*hart ', edge, bohr, edge*hart
         write(44,*) 'ispec, ik0 ', ispec, ik0
         write(44,*) 'ie, em(ie)*hart, xk(ie)'
         do 230  ie = 1, ne
           write(44,220) ie, dble(em(ie))*hart,
     1                   getxk(dble(em(ie))-edge)/bohr
  220      format (i5, 3f20.5)
  230    continue
         close (unit=44)
      endif

      return
      end
      subroutine radint (ifl, mult, bf, kinit, dgc0, dpc0, ikap, p, q,
     1   pn, qn, ri, dx, ilast, iold, xrc, xnc, xrcold, xncold, xirf)
c     performs radial integration for multipole matrix element
c     or central atom absorption depending on flag 'ifl'.
      implicit double precision (a-h, o-z)

c     INPUT
c     ifl - number corresponds to the calling order in xsect.f
c         - 1 - calculate matrix element (rkk)
c         - -1 - calculate matrix element (rkk) in nonrelativistic limit
c         - 2 - calculate cross section (xsec)
c             cross term needed for spin-dependent potential only
c         - 3 - cross term (xsec) with irregular part for current kappa
c         - 4 - cross term (xsec) with regular part for current kappa
c     mult - specifies multipole transition
c     bf - bessel functions for x-ray k-vector for l=0,1,2
c     kinit - initial kappa
c     dgc0,dpc0 - large (small) dirac components for initial orbital 
c     ikap  = final state kappa
c     p,q   Dirac components for regular (R) final state solution
c     pn,qn  Dirac components for irregular(N) final state solution
c     ri,dx - radial grid
c     ilast - last integration point
c     iold  - 0 - do nothing to xrcold, xncold (ic3=0 case)
c             1 - store intermediate results in xrcold, xncold (ic3=1)
c             2 - use intermediate results in xrcold, xncold (ic3=1)
c
c     OUTPUT
c     xrcold,xncold - coupling to regular (R) and irregular(N) solutions
c                     both output and input
c     xirf  - value of the radial integral

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension ri(nrptx), dgc0(nrptx), dpc0(nrptx)
      dimension bf(0:2, nrptx)
      complex*16 p(nrptx), q(nrptx), pn(nrptx), qn(nrptx)
c     storage for calculation of cross term (SPIN 1 only)
      complex*16 xrcold(nrptx) , xncold(nrptx)
      complex*16  xirf, temp

c     local staff
      complex*16  xm(4)
      complex*16 xrc(nrptx), xnc(nrptx)
      complex*16 coni
      parameter (coni = (0.d0, 1.d0))

      linit = kinit
      if (kinit.lt.0) linit = - kinit - 1
      lfin = ikap
      if (ikap.lt.0) lfin = - ikap - 1
c     set multipliers  from Grant,Advan.Phys.,v.19,747(1970) eq. 6.30,
c     using Messiah's "Q.M." appendices to calculate 9j,3j symbols
      if (ifl.lt.0) then
        ji2 = 2*abs(kinit)-1
        jf2 = 2*abs(ikap)-1
        if (mult.eq.0 .or. mult.eq.2) then
           ll = 1
           if (mult.eq.2) ll = 2
           ll2 = 2*ll
           temp = sqrt(dble((ji2+1)*(jf2+1))) *cwig3j(jf2,ll2,ji2,1,0,2)
c          sign of temp is (-)**(j+1/2): compare eq. 6.2 and 6.30 
c          of Grant, Adv. Phys. 19, 747 (1970).
           temp = temp * (-1)**(abs(ikap))
           ls = ll-1
           xm(1) = temp * (ll2+1) *coni**ls *(2*ls+1) *
     1     cwig3j(ls,1,ll,0,0,1) * cwig3j(ls,1,ll,0,1,1)
           ls = ll+1
           xm(3) = 0
c          xm(3) = temp * (ll2+1) *coni**ls *(2*ls+1) *
c    1     cwig3j(ls,1,ll,0,0,1) * cwig3j(ls,1,ll,0,1,1)
        else
c          if (mult.eq.1) then
           stop 'not set up for M1 transition in nonrelativistic limit'
        endif
      elseif (mult.eq.0) then
        call xmult( ikap, kinit, 0, 1, xm(1), xm(2))
        call xmult( ikap, kinit, 2, 1, xm(3), xm(4))
      else
        xm(3) = 0
        xm(4) = 0
        if (mult.eq.2) then
          call xmult( ikap, kinit, 1, 2, xm(1), xm(2))
        else
c         mult=1 - M1 transition
          call xmult( ikap, kinit, 1, 1, xm(1), xm(2))
        endif
      endif

c     radial integrals depending on case
      ia = abs(ifl)
      is = ifl /ia
      if (ia.eq.1) then
c       single radial integral for rkk - reduced matrix elements
c       xirf = <f |p| i> relativistic version of dipole m.e.
        do 10  i = 1, ilast
          xnc(i) = 0.0d0
          if (is.gt.0) then
           call xrci(mult,xm,dgc0(i),dpc0(i),p(i),q(i),bf(0,i),xrc(i))
          else
c          nonrelativistic case 
           if (mult.eq.0) then
             temp = xm(1)*bf(0,i)+ xm(3)*bf(2,i)
           elseif (mult.eq.2) then
             temp = xm(1)*bf(1,i)
           endif
           temp = temp *coni
           xrc(i) = ri(i) * (dgc0(i)*p(i) + dpc0(i)*q(i)) *temp
c          xrc(i) = ri(i) * (dgc0(i)*p(i) ) *temp
          endif

c         store xrc if needed
          if (iold.eq.1) xrcold(i) = xrc(i)
  10    continue
        xirf=lfin+linit+2
        if (mult.gt.0) xirf = xirf + 1
        call csomm (ri, xrc, xnc, dx, xirf, 0, ilast)
      else
c       need to perform double radial integral in all cases below
        if (ia.eq.2) then
c         combine regular(kdif) and irregular(kdif) solution into
c         the central atom absorption coefficient xsec (mu = dimag(xsec))
c         thus for real energy dimag(xsec)=xsnorm
          do 20  i = 1, ilast
           if (is.gt.0) then
           call xrci(mult,xm,dgc0(i),dpc0(i),pn(i),qn(i),bf(0,i),xnc(i))
           call xrci(mult,xm,dgc0(i),dpc0(i),p(i),q(i),bf(0,i),xrc(i))
           else
c            nonrelativistic case 
             if (mult.eq.0) then
               temp = xm(1)*bf(0,i)+ xm(3)*bf(2,i)
             elseif (mult.eq.2) then
               temp = xm(1)*bf(1,i)
             endif
             temp = temp*coni
             xrc(i) = ri(i) * (dgc0(i)*p(i) + dpc0(i)*q(i)) *temp
             xnc(i) = ri(i) * (dgc0(i)*pn(i) + dpc0(i)*qn(i)) *temp
c            xrc(i) = ri(i) * (dgc0(i)*p(i) ) *temp
c            xnc(i) = ri(i) * (dgc0(i)*pn(i) ) *temp
           endif
c           store irregular contribution for later use
            if (iold.eq.1) xncold(i) = xnc(i)
  20      continue
        elseif (ifl.eq.3 .and. iold.eq.2) then
c         combine regular(k1) and irregular (kdif) solutions into the
c         central atom absorption coefficient xsec (mu = dimag(xsec))
c         nonzero only for |ispin=1| and same angular momenta in k1,kdif
          do 30  i = 1, ilast
            xrc(i)= xrcold(i)
           call xrci(mult,xm,dgc0(i),dpc0(i),pn(i),qn(i),bf(0,i),xnc(i))
  30      continue
        elseif(ifl.eq.4 .and. iold.eq.2) then
c         combine regular(kdif) and irregular (k1) solutions into the
c         central atom absorption coefficient xsec (mu = dimag(xsec))
c         nonzero only for |ispin=1| and same angular momenta in k1,kdif
          do 40  i = 1, ilast
            call xrci( mult,xm,dgc0(i),dpc0(i),p(i),q(i),bf(0,i),xrc(i))
            xnc(i) = xncold(i)
  40      continue
        endif

c       same staff for all double integrals
        if ((iold.eq.0.and.ia.eq.2) .or. (ifl.gt.2.and.iold.eq.2)) then
c          do radial integration for r'>r first
c          power of xrc near zero
           lpwr = lfin + linit +2
c          factor 2 since integral(r<r')=integral(r>r')
           xirf = 2 * xrc(1) * ri(1) /(lpwr+1)
           xnc(1) = xnc(1) * xirf
           do 70 i = 2, ilast
             xirf = xirf + (xrc(i-1)+xrc(i)) * (ri(i)-ri(i-1))
             xnc(i) = xnc(i) * xirf
  70       continue
           do 80 i = 1,ilast
  80       xrc(i) = 0
           xirf = lpwr+1+linit+1-lfin
c          ready for second integral over r from 0 to \infty
           call csomm (ri, xrc, xnc, dx, xirf, 0, ilast)
        endif
      endif

      return
      end

      subroutine xrci( mult, xm, dgc0, dpc0, p, q, bf, value)
c     r-dependent multipole matrix element (before r-integration)
      implicit double precision (a-h, o-z)
      complex*16 xm(4), p, q, value
      dimension bf(0:2)

      if (mult.eq.0) then
c       el. dipole transition with both j0 and j2 contributions
        value = dgc0*q* (xm(2)*bf(0) + xm(4)*bf(2)) +
     1         dpc0*p* (xm(1)*bf(0) + xm(3)*bf(2))
       else
         value = (xm(2)*dgc0*q+xm(1)*dpc0*p) * bf(1)
       endif

      return
      end
      subroutine wphase (nph, em, eref, lmax, ne, ph, ntitle, title)

c     Writes phase data to file PHASExx.DAT for each shell

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

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      complex*16 eref(nex, nspx)
      complex*16 ph( nex, -ltot:ltot, nspx, 0:nphx)
      complex*16  em(nex)
      dimension lmax(0:nphx)
      character*30  fname
      character*80  title(ntitle)
      character*2 coment
      parameter (coment='# ')

c     Dump phase data, eref and complex phase for each shell
      do 200  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,20)  iph
  20     format('phase', i2.2, '.dat')
         open (unit=1, file=fname, status='unknown', iostat=ios)
         call chopen (ios, fname, 'wphase')

         write(fname,30)  iph
  30     format('phmin', i2.2, '.dat')
         open (unit=2, file=fname, status='unknown', iostat=ios)
         call chopen (ios, fname, 'wphase')

         do 50 i = 1, ntitle
            ll = istrln(title(i))
            write(1,40)  coment, title(i)(1:ll)
            write(2,40)  coment, title(i)(1:ll)
  40        format (a,a)
  50     continue
c        write out unique pot and lmax
         write(1,60)   coment, iph, lmax(iph), ne
         write(2,60)   coment, iph, lmax(iph), ne
  60     format (a, 1x, 3i4, '   unique pot,  lmax, ne')
         write(2,70) coment, linit,linit+1,linit+2
  70     format (a,'      energy      re(eref)     re(p)    phase( ',i2,
     1         ')  phase(',i2,') phase(',i2,')' ) 

c        for each energy
c        ie, em, eref, p=sqrt(2*(em-eref))
c        ph array from 0 to ltot, 5 values per line
         do 150  ie = 1, ne
           write(1,110) coment, ie, dble(em(ie)), eref(ie,1),
     1                  sqrt(2*(em(ie)-eref(ie,1)))
  110      format (a, '   ie        energy      re(eref)',
     1             '      im(eref)',
     2             '         re(p)         im(p)', /,
     3             1x, i4, 1p, 5e14.6)

           write(1,120)  (ph(ie,ll,1,iph), ll=0,lmax(iph))
  120      format (1x, 1p, 4e14.6)

           write(2,130) dble(em(ie)), dble(eref(ie,1)),
     1     dble(sqrt(2*(em(ie)-eref(ie,1)))),
     2     (dble(ph(ie,ll,1,iph)), ll=linit,linit+2)
  130       format (1p, 6e13.5)
  150    continue
         close(unit=1)
         close(unit=2)
  200 continue

      return
      end
      subroutine wrxsph (nsp, ne, ne1, ne3, nph, ihole, rnrmav,xmu,edge,
     1                   ik0, em, eref, lmax, iz, potlbl, ph, rkk)
      implicit double precision (a-h, o-z)
c     writes down file 'phase.bin' to be read by rphbin
c  Energy grid information
c     em   - complex energy grid
c     eref - V_int + i*gamach/2 + self-energy correction
c     ne   - total number of points in complex energy grid
c     ne1  - number of points on main horizontal axis
c     ne2  - number of points on vertical vertical axis ne2=ne-ne1-ne3
c     ne3  - number of points on auxilary horizontal axis (need for f')
c     xmu  - Fermi energy
c     edge - x-ray frequency for final state at Fermi level
c     ik0  - grid point index at Fermi level
c  Potential type information
c     nph - number of potential types
c     iz  - charge of nuclei (atomic number)
c     potlbl - label for each potential type
c     lmax - max orb momentum for each potential type
c     ihole - index of core-hole orbital for absorber (iph=0)
c     rnrmav - average Norman radius (used in headers only)
c  Main output of xsect and phases module (except that in xsect.bin)
c     ph  - complex scattering phase shifts
c     rkk - complex multipole matrix elements

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      character*6  potlbl
      dimension  potlbl(0:nphx)

      complex*16 ph(nex,-ltot:ltot,nspx,0:nphx), eref(nex,nspx), em(nex)
      complex*16 rkk(nex, 8, nspx)
      dimension lmax(0:nphx)
      dimension iz(0:nphx)

c     Local staff
c     npadx control padlib precision (see padlib package)
      parameter (npadx=8)
c     use temp to write ph, rkk, since ne < nex
      complex*16 temp(nex*(2*ltot+1))
      dimension dum(3)

      open (unit=1, file='phase.bin', status='unknown', iostat=ios)
      call chopen (ios, 'phase.bin', 'wrxsph')

      write(1,10) nsp, ne, ne1, ne3, nph, ihole, ik0, npadx
  10  format (8(1x,i4))

      dum(1) = rnrmav
      dum(2) = xmu 
      dum(3) = edge
      call wrpadd(1, npadx, dum(1), 3)

      call wrpadx(1, npadx, em(1), ne)
      ii = 0
      do 60 isp = 1, nsp
      do 60 ie=1, ne
        ii = ii + 1
        temp(ii) = eref (ie, isp)
  60  continue
      call wrpadx (1, npadx, temp(1), ii)

      do 80  iph = 0, nph
         write(1, 20) lmax(iph), iz(iph), potlbl(iph)
  20     format(2(1x,i3), 1x, a6)
         do 75  isp = 1, nsp
            ii = 0
            do 70  ie = 1, ne
            do 70  ll = -lmax(iph), lmax(iph)
               ii = ii+ 1
               temp(ii) = ph(ie, ll, isp, iph)
   70       continue
            call wrpadx (1, npadx, temp(1), ii )
   75    continue
   80 continue

      ii = 0
      do 90 isp = 1, nsp
      do 90 kdif = 1, 8
      do 90 ie=1, ne
        ii = ii + 1
        temp(ii) = rkk (ie, kdif, isp)
  90  continue
      call wrpadx (1, npadx, temp(1), ii)

      close (unit=1)

      return
      end
      subroutine xmult (k, kp, ls, lb, xm1, xm2)

      implicit double precision (a-h, o-z)
      complex*16 xm1, xm2, alslb
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c     xm1, xm2 both either real or pure imaginary
      integer a, ap

c     see Grant eq. 6.30. calculate the factors 
c     <k|alpha*A( l, L)|k'> = (-)**(j-m) * 3j( j L j'; -m p m')*R_k,k'
c     R_k,k'(l,L) = \int dr (xm1*P_k*Q_k'+ xm2*Q_k*P_k') * j_l(wr)

c     set the factor in front of bessel function (eq.6.26)
      if (ls+1.eq.lb) then
c        e.g. dipole and quadrupole transition
         aa = (2*lb-1) * (lb+1) / 2.d0
         alslb = coni**ls * sqrt(aa)
      elseif (ls-1.eq.lb) then
c        e.g. cross dipole-octupole
         aa = (2*lb+3) * lb / 2.d0
         alslb = coni**ls * sqrt(aa)
      elseif (ls.eq.lb) then
c        e.g. magnetic dipole
         alslb = coni**ls * (2*lb+1) /sqrt(2.d0)
      else
         alslb = 0
      endif

c     set all angular momenta
      j2 = 2*abs(k) -1
      a = 1
      if (k.gt.0) a=-1
      jp2 = 2*abs(kp) -1
      ap = 1
      if (kp.gt.0) ap=-1

c     calculate xm1 (beta=1 in eq.6.30)
c     check out 2 Kronecker symbols
      lam = (j2-a) / 2
      lamp = (jp2+ap) / 2
      if ( 2*lam.eq.j2-a .and. 2*lamp.eq.jp2+ap) then
         call ninej (lam, lamp, ls, j2,jp2, lb, aa)
         xm1 = alslb * aa * cwig3j(lam, ls, lamp, 0, 0, 1) * (-1)**lam
     1        * sqrt(6.d0*(j2+1)*(jp2+1)*(2*lb+1)*(2*lam+1)*(2*lamp+1) )
         xm1 = xm1 * coni
      else
         xm1 = 0
      endif

c     calculate xm2 (beta=-1 in eq.6.30)
c     check out 2 Kronecker symbols
      lam = (j2+a) / 2
      lamp = (jp2-ap) / 2
      if ( 2*lam.eq.j2+a .and. 2*lamp.eq.jp2-ap) then
         call ninej (lam, lamp, ls, j2,jp2, lb, aa)
         xm2 = alslb * aa * cwig3j(lam, ls, lamp, 0, 0, 1) * (-1)**lam
     1       * sqrt(6.d0*(j2+1)*(jp2+1)*(2*lb+1)*(2*lam+1)*(2*lamp+1) )
c        factor -1 due to complex conjugation of i*Q_k
         xm2 = - coni * xm2
      else
         xm2 = 0
      endif

      return
      end

      subroutine ninej (lam, lamp, ls, j2,jp2, lb, aa)
      implicit double precision (a-h, o-z)
c     calculate 9j-symbol in 6.30 of Grant using eq. C.41 in Messiah

      if (ls.gt.lb) then
        aa = - (ls+lb+1)* sixj(1,2,2*lb,ls+lb,2*ls) *
     1       sixj(2*lb, ls+lb, 2*lamp, jp2, j2) *
     1       sixj(ls+lb,2*ls, 2*lam, j2, 2*lamp)
      elseif (ls.lt.lb) then
        aa = - (ls+lb+1)* sixj(1,2,2*lb,ls+lb,2*ls) *
     1       sixj(ls+lb, 2*lb, jp2, 2*lamp, j2) *
     1       sixj(2*ls, ls+lb, j2, 2*lam, 2*lamp)
      else
c       ls=lb (magnetic dipole)
        aa = -(2*ls+2) * sixj(1,2,2*lb,2*lb+1,2*lb) *
     1       sixj(2*lb, 2*lb+1, 2*lamp, jp2, j2) *
     1       sixj(2*lb, 2*lb+1, j2, 2*lam, 2*lamp)
        aa = aa -(2*ls) * sixj(1,2,2*lb,2*lb-1,2*lb) *
     1       sixj(2*lb-1, 2*lb, jp2, 2*lamp, j2) *
     1       sixj(2*lb-1, 2*lb, 2*lam, j2, 2*lamp)
      endif

      return
      end

      double precision function sixj(j1,j2,j3,j4,j5)
      implicit double precision (a-h, o-z)
c     calculate 6j symbols in eq. c.38, c39 of Messiah
c     all input angular momenta are multiplied by 2 and
c     j2 should be equal to j1+1
      integer g2

      aa = 0
      if (j2.eq.j1+1) then
        if (j4.eq.j3+1) then
c         eq.c.38
          g2 = j5 - 1
          if (g2.ge.abs(j1-j3) .and. g2.le.j1+j3) then
            aa = (1.d0 + (g2+j1-j3)/2.d0) * (1.d0 +(g2-j1+j3)/2.d0) /
     1           (j1+1) /(j1+2)/(j3+1)/(j3+2)
            aa = sqrt(aa) * (-1)**(nint(1+(g2+j1+j3)/2.d0))
          endif
        elseif(j3.eq.j4+1) then
c         eq.c.39
          g2 = j5
          if (g2.ge.abs(j1-j4) .and. g2.le.j1+j4) then
            aa = (1.d0 - (g2-j1-j4)/2.d0) * (2.d0 +(g2+j1+j4)/2.d0) /
     1           (j1+1) /(j1+2)/(j4+1)/(j4+2)
            aa = sqrt(aa) * (-1)**(nint(1+(g2+j1+j4)/2.d0))
          endif
        endif
      endif
      sixj = aa

      return
      end

      subroutine rexsph ( mphase, ipr2, ispec, vixan, xkstep, xkmax,
     1             gamach, rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl, iGrid,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis)

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

cc    geom.dat
        integer  nat, iatph(0:nphx), iphat(natx)
        double precision  rat(3,natx)
cc    global.dat 
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    mod2.inp
        integer mphase, ipr2, ixc, ixc0, ispec, lreal, lfms2, l2lp, iPl, 
     &       iGrid
        double precision rgrd, gamach, xkstep, xkmax, vixan
        double precision vr0, vi0, spinph(0:nphx)
        real rfms2
        integer lmaxph(0:nphx)
        character*6  potlbl(0:nphx)
        integer izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis

c     Local stuff
      character*512 slog
      character*80 head(nheadx)
      dimension lhead(nheadx)

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)


c     Read  geom.dat file
      open (file='geom.dat', unit=3, status='old',iostat=ios)
c       read header from geom.dat
        nhead = nheadx
        call rdhead (3, nhead, head, lhead)
        nat = 0
        nph = 0
        do 40 iph = 0, nphx
  40    iatph(iph) = 0
  50    continue
           nat = nat+1
           if (nat .gt. natx)  then
              write(slog,55) ' nat, natx ', nat, natx
              call wlog(slog)
  55          format(a, 2i10)
              stop 'Bad input'
           endif
           read(3,*,end=60)  idum, (rat(j,nat),j=1,3), iphat(nat), i1b
           if (iphat(nat).gt.nph) nph = iphat(nat)
           if ( iatph(iphat(nat)).eq.0) iatph(iphat(nat)) = nat
        goto 50
  60    continue
        nat = nat-1
      close(3)
cc    global.inp
      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c       configuration average data
        read  (3, 10) slog
        read  (3, 65) nabs, iphabs, rclabs
  65    format ( 2i8, f13.5)
c       global polarization data
        read  (3,10)   slog
        read  (3, 70)  ipol, ispin, le2, elpty, angks
  70    format ( 3i5, 2f12.4)
        read  (3, 10) slog
        do 80 i = 1,3
          read  (3,30) evec(i), xivec(i), spvec(i)
  80    continue
        read  (3, 10) slog
        do 90 i = -1, 1
          read (3,30) a1, b1, a2, b2, a3, b3
          ptz(-1,i)= cmplx(a1,b1)
          ptz(0,i) = cmplx(a2,b2)
          ptz(1,i) = cmplx(a3,b3)
  90    continue
      close(3)
c     read mod2.inp
c     Josh - added flag iPl for PLASMON card
c     Josh - added flag iGrid for user controlled grids.
      open (file='mod2.inp', unit=3, status='old',iostat=ios)
        read (3,10)  slog
        read (3,20)  mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,
     &       iPl,iGrid
        read (3,10)  slog
        read (3,30)  vr0, vi0
        read (3,10)  slog
        read (3,20)  (lmaxph(iph),iph=0,nph)
        read (3,10)  slog
        read (3,170)  (potlbl(iph),iph=0,nph)
  170   format (13a6)
        read (3,10)  slog
        read (3,30)  rgrd, rfms2, gamach, xkstep, xkmax, vixan
        read (3,30)  (spinph(iph),iph=0,nph)
        read (3,20)  izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis
      close(3)

!KJ next section added for ELNES calculations 1-06
      open(3,file='eels.inp',status='old',err=100)
        read(3,*)
	read(3,20,end=100,err=100) melnes
      close(3)
      if(melnes.eq.1.and.mphase.eq.1) then
        call wlog(':INFO : rexsph reduces your polarization tensor to 
     1   the unit matrix, because eels.inp says you are doing ELNES.')
        do i=-1,1
	do j=-1,1
	ptz(i,j)=dcmplx(0,0)
	enddo
	  ptz(i,i)=dble(1)/dble(3)
	  write(*,*) (ptz(i,j),j=-1,1)
	enddo
      endif
100   continue
c !KJ end of my modifications      



c     transform to code units (bohrs and hartrees - atomic unuts)
      rfms2 = rfms2 / bohr
      vr0   = vr0 / hart
      vi0   = vi0 / hart
      gamach = gamach / hart
      vixan = vixan / hart
      xkstep = xkstep * bohr
      xkmax  = xkmax  * bohr
      do 210 i = 1,3
      do 210 iat = 1, nat
        rat(i,iat) = rat(i,iat) / bohr
 210  continue

      return
      end
c     Josh - argument iPl has been added to arguments of xsect
      subroutine xsect (ipr2, dx, x0, ri, ne, ne1, ik0, em, edge,
     1                  ihole, emu, corr, dgc0, dpc0, jnew,
     2                  ixc, lreal, rmt, rnrm, xmu,
     2                  vi0, iPl, gamach,
     3                  vtot, vvalgs, edens, dmag, edenvl,
     4                  dgcn, dpcn, adgc, adpc, xsec, xsnorm, rkk,
     5                  iz, xion, iunf, xnval,
     5                  izstd, ifxc, eorb, kappa, iorb, l2lp,
     6                  ipol, ispin, le2, angks, ptz)

c     right know the same self-energy is used for calculation
c     of the central atom part (xsec) and dipole m.e. for
c     scattering (rkk). You may want to run xsect separately
c     for xsec and for rkk, if you want to use different self-energy
c     for central and scattering parts.  ala. fix later

      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     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
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, 8)  normalized reduced matrix elements for construction
c                 of termination matrix in genfmt.

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 ptz
      dimension ptz(-1:1, -1:1)

      complex*16 em(nex)
      dimension ri(nrptx), vtot(nrptx), edens(nrptx),dmag(nrptx)
      dimension dgc0(nrptx), dpc0(nrptx), vvalgs(nrptx), edenvl(nrptx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30), eorb(30), kappa(30)
      dimension adgc(10,30), adpc(10,30), xnval(30), iorb(-4:3)
      complex*16 rkk(nex, 8), xsec(nex)
      complex*16 bmat(-lx:lx,0:1,8, -lx:lx,0:1,8)
      dimension kind(8), lind(8)
      dimension xsnorm(nex)

      dimension xp(nrptx), xq(nrptx)

c     work space for xcpot
      dimension vxcrmu(nrptx), vxcimu(nrptx), gsrel(nrptx)
      dimension vvxcrm(nrptx), vvxcim(nrptx)

c     work space for fovrg
      complex*16 p(nrptx), q(nrptx), pn(nrptx), qn(nrptx), fscf(nrptx)
      complex*16 pp(nrptx), qp(nrptx), pnp(nrptx), qnp(nrptx)
c     storage for calculation of cross term (SPIN 1 only)
      complex*16 xrcold(nrptx) , xncold(nrptx), yvec(nrptx,1)

      complex*16  p2, ck, xkmt, xkmtp
      complex*16  pu, qu, dum1, factor
      complex*16  xfnorm, xirf, xirf1
      complex*16  temp, aa, bb, cc, rkk1, rkk0, phold
      complex*16  phx(8), ph0
      complex*16  eref, xm1, xm2, xm3, xm4

      complex*16 jl,jlp1,nl,nlp1
      complex*16  v(nrptx), vval(nrptx)
      complex*16  xrc(nrptx), xnc(nrptx)
      character*512 slog
      logical ltrace
c     nesvi:  
      complex*16 xrhoce(nex), xrhopr(nex), chia(nex), cchi(nex)
      dimension omega1(nex), bf(0:2, nrptx)

      dimension pat(nrptx),qat(nrptx)
      complex*16 intr(nrptx),var(nrptx) 
c     to pass energy levels and projected DOS
      dimension neg(30), eng(nex, 30), rhoj(nex,30)
c     Josh - Added iPl switch for PLASMON card
c          - and WpCorr = Wi/Wp, Gamma, AmpFac
c          - to describe Im[eps^-1]
      integer iPl, ipole
      double precision WpCorr(MxPole), Gamma(MxPole), AmpFac(MxPole)
c     Josh END
      
      call setkap(ihole, kinit, linit)
      PRINT*, 'dx=',dx
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)  call par_stop('jri .gt. nrptx in phase')

c     nesvi: define jnrm
      inrm = (log(rnrm) + x0) / dx + 1
      jnrm = inrm + 1

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 10  i = 1, nrptx
         xp(i) = dpc0(i)**2
         xq(i) = dgc0(i)**2
  10  continue
c     nb, xinorm is used for exponent on input to somm
      xinorm = 2*linit + 2
      call somm (ri, xp, xq, dx, xinorm, 0, jnrm)
      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 (lreal.lt.2)  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

c     use ixc for testing
      index = ixc
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
      ltrace = .true.
      call bcoef(kinit, ipol, ptz, le2, ltrace, ispin, angks, 
     1           kind, lind, bmat)
c     set spin index to use bmat
      isp = 0
      if (ispin.eq.1) isp = nspx - 1

c     zero rkk and phx
      do 20 ie = 1,nex
      do 20 k1 = 1,8
 20   rkk(ie,k1) = 0
      do 30 k1 = 1,8
 30   phx(k1) = 0

      ifirst = 0
c     Josh - if PLASMON card is set, and using HL exc,
c          - read pole information from epsinv.dat
      IF( (iPl.gt.0).and.(ixc.eq.0) ) THEN
         open(file='exc.dat', unit=47, status='old',iostat=ios)
         call chopen (ios, 'exc.dat', 'ffmod2(xsect)')
         DO ipole = 1, MxPole
            call rdcmt(47,'#*cC')
            read(47,*,END=35) WpCorr(ipole), Gamma(ipole), AmpFac(ipole)
            Gamma(ipole)  = Gamma(ipole)/hart
            WpCorr(ipole) = (WpCorr(ipole)/hart) /
     &           SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)
         END DO
 35      CONTINUE
         WpCorr(ipole) = -1.d30
         CLOSE(47)
      END IF
      IF(ixc.eq.0) THEN
c        Write wp as calculated from density to sigma.dat
         open(file='mpse.dat', unit=45, status='replace',iostat=ios)
         call chopen (ios, 'sigma.dat', 'ffmod2(xsect)')
         write(45,*) '# ', 'rs      wp(Hartrees)'
         write(45,*) '# ', (3 / (4*pi*edens(jri+1))) ** third,
     &        SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)*hart
         write(45,'(a)')
     &        '# E-EFermi (eV)   Re[Sigma(E)] (eV)   Im[Sigma(E)] (eV)'
     &        // '   Re[Z]   Im[Z]   Mag[Z]   Phase[Z]   Lambda(E) (/A)'
      END IF
c     Josh END
      
      do 400 ie = 1, ne
         iph = 0
c        Josh - xcpot now has new arguments:
c             - iPl, WpCorr, Gamma, AmpFac         
         call xcpot (iph, ie, index, lreal, ifirst, jri,
     1               em(ie), xmu,
     2               vtot, vvalgs, edens, dmag, edenvl,
     3               eref, v, vval, iPl, WpCorr, Gamma, AmpFac,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim,rnrm)

c       set the method to calculate atomic cross section
c       p2 is (complex momentum)**2 referenced to energy dep xc
        p2 = em(ie) - eref
        p2f = edge - dble(eref)
        ck = sqrt (2*p2 + (p2*alphfs)**2)
        xkmt = rmt * ck

        if (mod(index,10) .lt. 5) then
           ncycle = 0
        else
c          fix later . may be ncycle can be less
           ncycle = 3
        endif
        omega = (dble(em(ie)) - edge) + emu
        omega = max (omega, 0.001d0 / hart)
c       nesvi: add omega1(ie)- need it later
        omega1(ie) = omega

c       remember the bessel functions for multipole matrix elements
        xk0 = omega * alphfs
        ilast = jnrm+6
        if (ilast.lt.jnew) ilast = jnew
        if (ilast.gt.nrptx) ilast = nrptx
        do 50 i = 1, ilast
          temp = xk0 * ri(i)
          if (abs(temp).lt.1.d0) then
c           use series expansion
            do 40 ll = 0,2
              call bjnser(temp,ll, xirf, dum1,1)
              bf(ll,i) = dble(xirf)
 40         continue
          else
c           use formula
            x = dble(temp)
            sinx = sin(x)
            cosx = cos(x)
            bf(0,i) = sinx/x
            bf(1,i) = sinx/x**2 - cosx/x
            bf(2,i) = sinx*(3/x**3-1/x) - 3*cosx/x**2
          endif
 50     continue

c       notice for spin-dep case xsnorm and xsec are spin-dep
c       and kept separately (see call to xsect in subroutine xsph)
        xsnorm(ie) = 0 
        xsec(ie) = 0
        if (dble(em(ie)).lt.-10.d0) goto 400
        if (dimag(p2).le.0.d0 .and. dble(p2).le.0.d0) goto 400

c       matrix elements for multipole (E1,E2,M1) transitions
c       The terms up to (k/c)^2 for absorption are kept.
c       L3 edge: kdif=1 (3d5/2)      kdif=2 (3d3/2), kdif=3(4s)
c       L2 edge: kdif=1 (no transition), 2 (4s),      3 (3d3/2)
        do 350 mult = 0, 2
          if (mult.eq.0) then
c           E1 transitions
            kx = 1
            ks = 2
          else
c           M1 transitions
            kx = 1
            ks = 6
c           E2 transitions
            if (mult.eq.2) kx = 2
          endif 
c         skip unnecessary calculations
          if (mult.gt.0 .and. (mult.ne.le2)) goto 350
 
c         set ilast larger than jri for better interpolation for pu
c         also need 5 points after jri for irregular solution
          ilast = jnrm + 6
          if (ilast.lt.jnew) ilast = jnew

cc        calculate screened dipole field
          ww = dble(emu+p2-edge)
          if (mult.eq.0 .and. izstd.gt.0) then
            if (ie.eq.1) call correorb(iz, ihole, rmt, jri, dx,ri,
     1                   p2f,edge, v, dgcn, dpcn, adgc, adpc,
     2                   eorb, neg, eng, rhoj, kappa, norbp)
            maxsize = 1
            matsize = 0
            sfun = 1.d0
            call phiscf (ifxc, rmt, ilast, jri, p2, p2f, emu, dx,
     1                  ri, v, edens, dgcn, dpcn, adgc, adpc,
     2                  iz, ihole, neg, eng, rhoj,kappa, norbp, fscf,
     3                  yvec, maxsize, matsize, sfun)
            wse = dble(p2-eng(1,ihole))
          else
            do 159 i = 1, nrptx 
  159       fscf(i) = 1.d0
            wse = ww
          endif
      
c         ww = 1
c         ww = wse / ww
          ww = sqrt(wse/ww)

          do 300 kdif = -kx, kx
            if (omega.le.0.0) goto 300
            ind = kdif + ks
            ikap = kind (ind)
            if (ikap .eq. 0) goto 300
c           use l2lp =0 to include both transitions l-->l+/-1
c           if (l2lp.ne.0) only dipole transitions are calculated.
c            l-->l+1 transitions
            if (l2lp.eq.1 .and. ((kinit.lt.0 .and. ind.ge.3) .or.
     1          (kinit.gt.0 .and. ind.ne.3)) ) goto 300
c            l-->l-1 transitions
            if (l2lp.eq.-1 .and. ((kinit.lt.0 .and. ind.ne.3) .or.
     1          (kinit.gt.0 .and. ind.ge.3)) ) goto 300

            iold = 0
            ic3=0
c           start cycle  do ic3=0,1
c           return for ic3=1 calculations only for |ispin|=1
c           where the central atom cross terms are needed
  100       continue

            irr = -1
c           ic3p=1 to test K2Cr2O7  L3 XES 
            ic3p = ic3
            call dfovrg ( ncycle, ikap, rmt, ilast, jri, p2, dx,
     1      ri, v, vval, dgcn, dpcn, adgc, adpc,
     2               xnval, pu, qu, p, q,
     3               iz, ihole, xion, iunf, irr, ic3p)
            lfin = lind (ind)
            ilp = lfin - 1
            if (ikap .lt. 0) ilp = lfin + 1
            call exjlnl (xkmt, lfin, jl, nl)
            call exjlnl (xkmt, ilp, jlp1, nlp1)
            call phamp(rmt,pu,qu, ck, jl,nl,jlp1,nlp1, ikap, ph0,temp)

            sign = -1.0
            if (ikap.gt.0) sign = 1.0
            factor = ck*alphfs 
            factor = sign * factor/(1+sqrt(1+factor**2))
            dum1 = 1/ sqrt(1+factor**2)
            xfnorm = 1 / temp *dum1
c           normalization factor
c           xfnorm = dum1*rmt*(jl*cos(delta) - nl*sin(delta))/ Rl(rmt)
c           dum1 is relativistic correction to normalization
c           normalize regular solution
            do 130  i = 1,ilast
              p(i)=p(i)*xfnorm
              q(i)=q(i)*xfnorm
  130       continue

cc          calculate xirf including fscf - TDLDA result
            do 140 id = 1, 2
              if (id.eq.1) then
                do 121 j = 1,ilast 
                  pp(j)  = p(j)*dble(fscf(j))
                  qp(j)  = q(j)*dble(fscf(j))
  121           continue
              else
                do 122 j = 1,ilast
                  pp(j)  = p(j)*dimag(fscf(j))
                  qp(j)  = q(j)*dimag(fscf(j))
  122           continue
              endif
              ifl = 1
              if (izstd.gt.0) ifl = -1
              xirf1 = 0
              call radint(ifl, mult, bf, kinit, dgc0,dpc0, ikap, pp,qp,
     1        pn,qn,ri,dx, ilast,iold, xrc,xnc, xrcold,xncold, xirf1)
c             if (ifl.lt.0) xirf1 = xirf1 * xk0 * ww
              if (ifl.lt.0) xirf1 = xirf1 * xk0 
              if (id.eq.1) then
                xirf = xirf1
              else
                if (abs(xirf) .eq. 0.d0) then
                  xirf = xirf1
                elseif (abs(xirf1) .eq. 0.d0) then
                  xirf = xirf
                elseif (abs(xirf1) .lt. abs(xirf)) then
                  dum = abs(xirf1) / abs(xirf)
                  xirf = xirf * sqrt(1.d0 + dum**2)
                else
                  dum = abs(xirf) / abs(xirf1)
                  xirf = xirf1 * sqrt(1.d0 + dum**2)
                endif
              endif
  140       continue

c           note that for real potential  xirf is real or reduced matrix
c           element for dipole transition is pure imaginary.
            if (ic3.eq.0) then
c              can remember only E2 or M1 matrix elements
               if (mult.eq.0 .or. le2.eq.mult) then
                 rkk(ie,ind)=xirf 
                 phx(ind) = ph0
               endif
c              for f' want to include both E2 and M1 for xsnorm and xsec
c              but now only one of them is included (fix later)
               xsnorm(ie)=xsnorm(ie) +
     1         ( dble(xirf)**2 + dimag(xirf)**2 )/ (2*kx+1)
               aa =  - coni*xirf**2
               xsec(ie) = xsec(ie) -  aa * bmat(0,isp,ind, 0,isp,ind)
            elseif (iold.eq.1) then
                rkk1=xirf
                phold = ph0
            elseif (iold.eq.2) then
                rkk0=xirf
            endif

c           get irregular solution and atomic cross-section xsec
c           find irregular solution

            if(dimag(em(ie)).gt.0.d0) then
              irr = 1
c             set pu, qu - initial condition for irregular solution 
              pu = (nl*cos(ph0)+jl*sin(ph0)) *rmt * dum1
              qu=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1
             
c             test on bessel functions
c             if (ikap.gt.0) print*,'test1',xkmt**2*(jl*nlp1-nl*jlp1)

              call dfovrg (ncycle, ikap, rmt, ilast, jri, p2, dx,
     1              ri, v,vval, dgcn, dpcn, adgc, adpc,
     1              xnval, pu, qu, pn, qn,
     1              iz, ihole, xion, iunf, irr, ic3p)
cc            set N- irregular solution , which is outside
cc            N=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1
cc            N = i*R - H*exp(i*ph0)
              temp = exp(coni*ph0)
              do i = 1, ilast
                pn(i) = coni * p(i) - temp * pn(i)
                qn(i) = coni * q(i) - temp * qn(i)
              enddo
            else
              do 150 i = 1, ilast
                pn(i) = 0
                qn(i) = 0
  150         continue
            endif

c           combine regular and irregular solution into the
c           central atom absorption coefficient xsec (mu = dimag(xsec))
c           thus for real energy dimag(xsec)=xsnorm

c           also include TDLDA effects
            do 170 id = 1, 2
              if (id.eq.1) then
                do 131 j = 1,ilast
                  pp(j)  = p(j)*dble(fscf(j))
                  qp(j)  = q(j)*dble(fscf(j))
                  pnp(j)  = pn(j)*dble(fscf(j))
                  qnp(j)  = qn(j)*dble(fscf(j))
  131           continue
              else
                do 132 j = 1,ilast
                  pp(j)  = p(j)*dimag(fscf(j))
                  qp(j)  = q(j)*dimag(fscf(j))
                  pnp(j)  = pn(j)*dimag(fscf(j))
                  qnp(j)  = qn(j)*dimag(fscf(j))
  132           continue
              endif

c           TDLDA theory is written for the r-form of matrix elements
c           so one might want to use ifl=-1,-2 for these calculations
c           on the other hand want ifl=1,2 for DANES calculations
c           since it is more reliable at high energies and gives
c           better results for Cu test.
              ifl = 2
              if (izstd.gt.0) ifl = -2

              call radint(ifl,mult, bf, kinit, dgc0, dpc0, ikap, pp, qp,
     1            pnp, qnp, ri,dx, ilast,iold, xrc, xnc, xrcold, xncold,
     2            xirf1)
              if (ifl.lt.0) xirf1 = xirf1 * xk0**2 * ww**2
              if (id.eq.1) then
                xirf = xirf1
              else
                if (abs(xirf) .eq. 0.d0) then
                  xirf = xirf1
                elseif (abs(xirf1) .eq. 0.d0) then
                  xirf = xirf
                elseif (abs(xirf1) .lt. abs(xirf)) then
                  dum = abs(xirf1) / abs(xirf)
                  xirf = xirf * sqrt(1.d0 + dum**2)
                else
                  dum = abs(xirf) / abs(xirf1)
                  xirf = xirf1 * sqrt(1.d0 + dum**2)
                endif
              endif
  170       continue

            if (ic3.eq.0) then
               xsec(ie) = xsec(ie) - xirf * bmat(0,isp,ind, 0,isp,ind)
            endif

c           ------start of density of states part------------- 
c           added by nesvi 07/12/00
c
c           Calculate rhoc00 and rho_projected on 
c           the same grid as xsect. Need this to calculate the smooth
c           atomic ratio rho_0/mu_0 or rho_proj/mu_0.              
c           The atomic functions are normalized to 1 inside Norman radius.
c           This procedure can be called 'Renormalized atomic sphere method".
c           It gives very reasonable numbers for hole counts. In order to
c           get Mulliken counts one can extend integration limits till very
c           large R, but it's currently not recommended because of the problems
c           with the wave function's tails above Rnm.
 

            jproj =  iorb(ikap)
            if (jproj.eq.0 .and. ikap.lt.0) jproj = iorb(-ikap-1)
            kdif1 = -1
            if(kinit.gt.0) kdif1 =  1
                
            if (kdif .eq. kdif1 .and. ic3.eq.0 .and. jproj.gt.0) then
c              calculate rhoc00 (rho_0)

               temp = (2*lfin+1.0d0) / (1+factor**2) /pi *4*ck /hart
               do 500 i = 1, ilast
                 xrc(i) = pn(i)*p(i) - coni*p(i)*p(i) 
     1                   + qn(i)*q(i) - coni*q(i)*q(i)
  500          continue    
               xirf = 1
c              integration is till Norman radius, not Rmt as in xsect
               i0 = jnrm + 1
               call csomm2 (ri, xrc, dx, xirf, rnrm, i0)
               xrhoce(ie) = - xirf * temp
            
c              calculate rho_projected:              

c              pat, qat - atomic functions that we make projection on.
               do 510 i=1,nrptx
                 pat(i) = dgcn(i,jproj)
                 qat(i) = dpcn(i,jproj)
  510          continue

c     normalize pat and qat in the Norman radius sphere: <n|n>=1,
c     (renormalized atomic sphere method)
     
               do 520  i = 1, ilast
                  xp(i) = pat(i)**2 + qat(i)**2
                  xq(i) = 0
  520          continue
c     nb, xinorm is used for exponent on input to somm 
               xinorm = 2*lfin + 2
               call somm2 (ri, xp, dx, xinorm, rnrm, 0, i0)
c              call somm (ri, xp, xq, dx, xinorm, 0, jnrm)
      
               xinorm = sqrt(xinorm)
               do 530 i=1,nrptx
                  pat(i) = pat(i) / xinorm
                  qat(i) = qat(i) / xinorm
  530          continue
  
c              calculate overlap integral between f and atomic function
c              (integral Rl(r)*Psi_at(r)dr from 0 till r') 
c              intr(i) is that overlap integral. Later it
c              will be multiplied by pr(i)*Psi_at(r') and integrated 
c              till Norman radius.

               do 540 i=1,ilast
                  var(i)=pat(i)*p(i)+qat(i)*q(i)
c                 factor of 2 -integration r< r>  -->2 r r'
  540          continue

c              integration by trapezoid method
               intr(1)=var(1)*ri(1)
               do 550 i=2,ilast
                  intr(i)=intr(i-1)+ (var(i)+var(i-1))*(ri(i)-ri(i-1))
  550          continue 


c         now calculate rho_projected - xrhopr
               temp = (2*lfin+1.0d0) / (1+factor**2) /pi *4*ck /hart
c              temp = abs(ikap) / (1+factor**2) /pi *4*ck /hart
               do 560  i = 1, ilast
                 xrc(i) = pn(i)*pat(i)*intr(i)+ 
     1                    qn(i)*qat(i)*intr(i)
                 xrc(i) = xrc(i) - coni*(p(i)*pat(i)*intr(i) + 
     1                    q(i)*qat(i)*intr(i))
  560          continue

               xirf =  1
               call csomm2 (ri, xrc, dx, xirf, rnrm, i0)
               xrhopr(ie) = - xirf * temp
    
            endif
c           ----------end of density of states part---


            if (iold.gt.0) then
c             calculate cross term contribution to XMCD
c             in both cases coupling between neighbors 
c             need to remove SO interaction (ic3=1) in order
c             to avoid unphysical peak in Gd XMCD. a.l. ankudinov
              k1 = ind - 1
              if (k1.ge.1 .and.k1.le.8) then
              if (lind(k1).eq.lind(ind) .and. lind(k1).gt.0) then
                aa = exp( coni*(ph0 - phold))
                bb = 1/aa
                cc = - ( bmat(0,isp,k1, 0,isp,ind) +
     1                 bmat(0,isp,ind, 0,isp,k1) ) / 2.d0
                xsec(ie) = xsec(ie) - coni * rkk1 * rkk0 * (bb+aa) * cc
cc              combine regular and irregular solution into the
cc              central atom absorption coefficient (mu=dimag(xsec))
cc              thus for real energy dimag(xsec)=xsnorm
                call radint (3, mult, bf, kinit, dgc0, dpc0, ikap, p, q,
     1            pn, qn, ri, dx, ilast, iold, xrc, xnc, xrcold, xncold,
     2            xirf)
                xsec(ie) = xsec(ie) + xirf * cc * bb
  
                call radint (4, mult, bf, kinit, dgc0, dpc0, ikap, p, q,
     1            pn, qn, ri, dx, ilast, iold, xrc, xnc, xrcold, xncold,
     2             xirf)
                xsec(ie) = xsec(ie) + xirf * cc * aa
              endif
              endif
            endif
cc          end of |ispin=1| cross term calculations

c           prepare for ic3=1 cross term calculations if needed
            if (ic3.eq.0 .and. abs(ispin).eq.1) then
              iold = 0
              if (ind.lt.8 .and. lind(ind).gt.0) then
                k1 = ind + 1
                if (lind(k1).eq.lind(ind)) iold = 1
              endif
              if (ind.gt.1 .and. lind(ind).gt.0) then
                k1 = ind - 1
                if (lind(k1).eq.lind(ind)) iold = 2
              endif
c             need to remove SO interaction to calculate cross term
c             big effect for Gd XMCD calculations
              if (iold.gt.0) then
c               repeat calculation for current kdif with SO turned off
                ic3 = 1
                goto 100
              endif
            endif

  300     continue
  350   continue

        if (omega.gt.0.0) then
c         prefac = (8 * pi / 3)  * alphfs * omega  -- nonrelativistic
c         relativistic is (for alpha form)
          prefac = 4 * pi * alpinv / omega * bohr**2
          xsnorm(ie) =  xsnorm(ie) * prefac * 2*abs(ck) 
          xnorm= sqrt( xsnorm(ie) )
          xsec(ie) = xsec(ie) * prefac* 2*ck

c         put complex sqrt(prefactor) into reduced matrix elements rkk
          ck = sqrt ( prefac * (2*ck))
c         guarantee that we have the right root
          if (dimag(ck) .lt. 0) ck = -ck
c         add central atom phase shift here. 
          do 360 kdif = 1 , 8
 360      rkk(ie,kdif)= rkk(ie,kdif) * ck/xnorm * exp(coni*phx(kdif))
        endif
 400  continue
c     end of energy cycle

c     Josh - Close sigma.dat
      close(45)
c     Josh END

      if (ipr2.ge.3) then
c       calculate mu_0/rho_0 for XMCD normalization.
        do 410 ie=1,ne
           chia(ie) = 0
  410   continue
        vrcorr = 0
        vicorr = 0
        call xscorr(1, em, ne1, ne, ik0, xrhoce,xsnorm,chia,
     1     vrcorr, vicorr, cchi)
        do 420 ie = 1, ne1
            xrhoce(ie)  = coni* dimag(xrhoce(ie)+cchi(ie))
  420   continue
        call xscorr(1, em, ne1, ne, ik0, xrhopr,xsnorm,chia,
     1     vrcorr, vicorr, cchi)
        do 425 ie = 1, ne1
            xrhopr(ie)  = coni* dimag(xrhopr(ie)+cchi(ie))
  425   continue    
        call xscorr(1, em, ne1, ne, ik0, xsec,xsnorm,chia,
     1     vrcorr, vicorr, cchi)
        do 430 ie = 1, ne1
            cchi(ie)  = coni* dimag(xsec(ie)+cchi(ie))
  430   continue

        open(unit=3,file='ratio.dat',status='unknown', iostat=ios)
        open(unit=4,file='ratiop.dat',status='unknown', iostat=ios)
c       normalize to xsec at 50 ev above edge
        edg50 = emu +50.0 / hart
        call terp (omega1, xsnorm, ne1, 1, edg50, xsedge)
        write(3,440) xsedge, emu * hart 
  440   format ('# Normalization factor:', e12.4,
     1     ' Angstrom**2. Fermi level at ', f7.1, ' eV.')
        write(3,450)
  450   format ('#   Energy      rho_0        mu_0       rho_0/mu_0 ')
     
        write(4,440) xsedge, emu * hart 
        write(4,455)
  455   format ('#   Energy      rho_proj      mu_0      rho_proj/mu_0',
     1   '    mu_deloc ')

        do 470 ie=1,ne1 
           if (dimag(cchi(ie)).eq.0.d0 .and. ie.lt.ik0) then
              cchi(ie)=cchi(ik0)
              xrhoce(ie)=xrhoce(ik0)
              xrhopr(ie)=xrhopr(ik0)
           endif
           ratio = dimag(xrhoce(ie)) / dimag(cchi(ie)) * xsedge
           ratiop = dimag(xrhopr(ie)) / dimag(cchi(ie)) * xsedge

           write(3,460)  dble(em(ie))*hart, dimag(xrhoce(ie)),
     1          dimag(cchi(ie))/xsedge, ratio*corr
c          corr is the ratio N_av/N_j, responsible for difference in
c          counts due to variation of wave function due to spin-orbit
  460      format(f12.6, 2x, e12.6,2x,e12.6,2x,e12.6,1x,e12.6)      
           write(4,465)  dble(em(ie))*hart, dimag(xrhopr(ie)),
     1          dimag(cchi(ie))/xsedge, ratiop,
     2          dimag(xrhoce(ie)-xrhopr(ie))/ratio 
c     also write contribution to mu_0 from delocalized states defined as
c     (rho-rho_proj)/ratio 
  465      format(f12.6, 2x, e12.6,2x,e12.6,2x,e12.6,1x,e12.6,2x,e12.6)    
      
  470   continue    
        close(unit=3)
        close(unit=4)
      endif 

      return
      end
c     Josh - added argument iPl to control many pole self energy.
      subroutine xsph (ipr2, ispec, vixan, xkstep, xkmax, gamach, rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl, iGrid,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis)

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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     Notes:
c        nat    number of atoms in problem
c        nph    number of unique potentials
c        ihole  hole code of absorbing atom
c        iph=0 for central atom

c     Specific atom input data
c     iphat(natx)  -  given specific atom, which unique pot?
      dimension iphat(natx)
c     rat(3,natx)  -  cartesian coords of specific atom
      dimension rat(3,natx)

c     Unique potential input data
c     iatph(0:nphx)  - given unique pot, which atom is model?
c                      (0 if none specified for this unique pot)
      dimension iatph(0:nphx)
c     xnatph(0:nphx) - given unique pot, how many atoms are there
c                      of this type? (used for interstitial calc)
      dimension xnatph(0:nphx), spinph(0:nphx)
c     potlbl(0:nphx)    -   label for user convienence
      character*6 potlbl(0:nphx)

c     folp(0:nphx) -  overlap factor for rmt calculation
      dimension folp(0:nphx)
c     novr(0:nphx) -  number of overlap shells for unique pot
      dimension novr(0:nphx)
c     iphovr(novrx,0:nphx) -  unique pot for this overlap shell
      dimension iphovr(novrx,0:nphx)
c     nnovr(novrx,0:nphx) -   number of atoms in overlap shell
      dimension nnovr(novrx,0:nphx)
c     rovr(novrx,0:nphx)  -   r for overlap shell
      dimension rovr(novrx,0:nphx)

c     Free atom data
c     xion(0:nphx)  - ionicity, input
      dimension xion(0:nphx)
c     iz(0:nphx)    - atomic number, input
      dimension iz(0:nphx)

c     Overlap calculation results
c     edens(251,0:nphx)   -   overlapped density*4*pi
      dimension edens(251,0:nphx)
c     vtot (251,0:nphx)   -   overlapped total potential
      dimension vtot (251,0:nphx), vclap (251,0:nphx)

c     Muffin tin calculation results
c     imt(0:nphx)  -  r mesh index just inside rmt
      dimension imt(0:nphx), inrm(0:nphx), folpx(0:nphx)
c     rmt(0:nphx)  -  muffin tin radius
      dimension rmt(0:nphx)
c     rnrm(0:nphx)  -  Norman radius
      dimension rnrm(0:nphx), qnrm(0:nphx)
      dimension xnmues(0:lx,0:nphx)
      real rfms2
      integer ipol, ispin, lfms2
      complex*16 ptz
      dimension ptz(-1:1, -1:1)
      dimension lmaxph(0:nphx)

c     PHASE output
c     eref(nex, nspx)         -     interstitial energy ref
      complex*16 eref(nex, nspx)
c     ph(nex,-ltot:ltot,nspx,0:nphx) - phase shifts
      complex*16 ph( nex, -ltot:ltot, nspx, 0:nphx)
c     lmax(0:nphx)      -     number of ang mom levels
      dimension lmax(0:nphx)

      character*80 title(nheadx)

      complex*16  em(nex)
      complex*16  rkk(nex,8,nspx), xsec(nex,nspx)
      dimension xsnorm(nex, nspx)
      dimension dgc0(251), dpc0(251)

c     additioal data needed for relativistic version
      dimension dgc(251,30,0:nphx), dpc(251,30,0:nphx)
      dimension adgc(10,30,0:nphx), adpc(10,30,0:nphx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension edenvl(251,0:nphx), eorb(30), kappa(30)
      dimension vvalgs (251,0:nphx), xnval(30,0:nphx), iorb(-4:3,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:nphx)
      dimension dgcx(nrptx), dpcx(nrptx), vvalph(nrx), rhphvl(nrx)
      dimension vch (251), vchp(nrx)

      logical lopt
      character*512 slog

c     Josh - Added iPl for PLASMON card, and iexist for mpse.dat
      integer iPl, iexist
      

   10 format (4x, a, i5)

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

      call rdpot ( ntitle, title, rnrmav, xmu, vint, rhoint,
     1                  emu, s02, erelax, wp, ecv,rs,xf, qtotel,
     2                  imt, rmt, inrm, rnrm, folp, folpx, xnatph,
     3                  dgc0, dpc0, dgc, dpc, adgc, adpc,
     3                  edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     4                  eorb, kappa, iorb, qnrm, xnmues, nohole, ihole,
     5                  inters, totvol, iafolp, xion, iunf, iz, jumprm)
c      lopt=true for the Rivas code of optical constants
       lopt = .false.
       if (lopt) call getedg(ihole,iz(0), emu)
       if (lopt) ik0 = 1
       if (lopt) then
         call wlog('   Fixing edge energy from Elam table...')
         write(slog,fmt="('   emu = ',f10.3,' eV')") emu*hart
         call wlog(slog)
       endif

       do 15 iph = 0, nph
 15    novr(iph) = 0

c  update header, since e.g. one may use diff ixc for the same potential
        call sthead (ntitle, title, nph, iz, rmt, rnrm,
     1          xion, ihole, ixc,
     2          vr0, vi0, gamach, xmu, xf, vint, rs,
     2          nohole, lreal, rgrd)
c     Make energy mesh
      edge = xmu - vr0
      if (.not.lopt) emu = emu - vr0

cc    manual input. Later make TDLDA and PMBSE cards
cc    TDLDA ifxc  (izstd=1 if TDLDA card is present)
c     izstd = 0
c     ifxc = 0
cc    PMBSE  ipmbse  nonlocal ifxc itdlda
c     ipmbse = 2
c     ibasis = 2
cc    ipmbse=0 (do not run); 1-LF only; 2-PM only; 3-combined; 
cc           4-combined with s-function kernel splitting
c     nonlocal = 0
cc    nonlocal = 0 (local fxc); 1-read W from pot.ch; 2-from yoshi.dat
c     itdlda = 2
cc    itdlda = 0, 1, 2 should be run in sequence
cc    end of manual input

c     check that logic is set up correctly
      if (ipmbse.le.0) itdlda = 0
      if (nohole.lt.0) then
c       core-hole potential is used already
        if (ifxc.ne.0) then
          call wlog(' Reset ifxc=0 since NOHOLE card is absent')
          ifxc = 0
          if (ipmbse.gt.0) nonlocal = 0
        endif
        if (ipmbse.eq.3 .and. izstd.eq.0) then
          call wlog(' Reset ipmbse=1 since NOHOLE card is absent')
          ipmbse = 1
        endif
      endif
      if (izstd.gt.0 .and. itdlda.gt.0) then
c       no need run PMBSE in this case
        call wlog(' Ignored PMBSE cards since TDLDA is present')
        itdlda = 0
      endif
      if (ipmbse.eq.2 .and. nonlocal.gt.0 .and. ifxc.gt.0) then
c       accounting for core-hole twice. reset ifxc=0
        call wlog(' Reset ifxc=0 since core-hole potential is used.')
        ifxc = 0
      endif
      if (ipmbse.eq.1 .and. nonlocal.gt.0) then
c       V_ch should be zero
        nonlocal = 0
      endif

c     Josh - if nohole = 2, read wscrn.dat and add ch pot to vtot.
c     Need to add file check and emesh check.
      if (nohole.eq.2)  then
         open (unit=13, file='wscrn.dat', status='old', iostat=ios)
         call chopen (ios, 'wscrn.dat', 'ffmod2(xsph)')
         open (unit=14, file='vtot.dat', status='replace',iostat=ios)
         call chopen (ios, 'vtot.dat', 'ffmod2(xsph)')
         do i = 1, 251
            read(13,'(2e20.10)',end=20) dum1, dum2
            dum3 = vtot(i,0)
            vtot(i,0) = vtot(i,0) - dum2
            write(14,'(3e20.10)') dum1, dum3, dum2
         end do
 20      continue
         nohole = 0
         close(13)
         close(14)
      end if
c     Josh END
      
      if (itdlda.eq.0)  then 
!     Josh - Replaced call to phmesh with phmesh2, which allows user
!     defined grids read from grid.inp. Details can be found in phmesh2.f
!         call phmesh2 (ipr2, ispec, edge, emu, vi0, gamach, xkmax,
!     &        xkstep, vixan, ne, ne1, em, ik0, ne3,iGrid)
        call phmesh (ipr2, ispec, edge, emu, vi0, gamach, ecv,
     1                 xkmax, xkstep, vixan, ne, ne1, em, ik0, ne3)
      else
c       nesvi TDLDA
        call meshlda (xkstep, ne, ne1, em, ik0)
        corr = 1.0
      endif

      if (itdlda.eq.1) then
c       to get the mesh only
        do 93  i = 1, ne1
          write(3,94) dble(em(i))*hart
 94       format (7f10.5)
 93     continue
        stop 'TDLDA energy mesh is written out'
c       end of itdlda=1 calculations
      endif

c     Make old grid to report distances in xsect.bin
      do 95 i = 1, 251
 95   ri(i) = exp(-x0+dx*(i-1))

c     open xsect.bin and write the header
      open (unit=1, file='xsect.bin', status='unknown', iostat=ios)
      call chopen (ios, 'xsect.bin', 'potph')
      call wthead (1, ntitle, title)
c skip old output in title ( title lines are above ------ )
c     write(1,*) 'vtot in eV, rho in code units, includes 4pi'
c     write(1,*) 'ipot, vtot(imt), rho(imt) '
c     write(1,122) 'interstitial', vint*hart, rhoint
c     do 386  iph = 0, nph
c        write(1,123)iph,vtot(imt(iph),iph)*hart,edens(imt(iph),iph)
c 386 continue
c 122 format (1x, a, 1p, 2e20.6)
c 123 format (i10, 1p, 2e20.6)
c     write(1,42)  emu*hart
c  42 format ('       edge ', 2f20.5)
c     write(1,*)  imt(0), ' imt(0)'
c     write(1,200)  vint*hart, rhoint, ri(imt(0)+1)
c 200 format ('  v, rho, r', /, 1p, 3e20.4, ' intersitial')
c     do 220  iii = imt(0), imt(0)-4, -1
c        write(1,210)  vtot(iii,0)* hart, edens(iii,0), ri(iii), iii
c 210 format (1p, 3e20.4, i6)
c 220 continue

      write(1,45)
   45 format (1x, 71('-'))
      write(1,55) s02, erelax, wp, edge, emu
   55 format ( 3e13.5, 2e15.7, ' method to calculate xsect')
      write(1,56) gamach*hart, ne1, ik0
   56 format (1p, e15.7, 2i4,
     1       ' gamach in eV, # of points on horizintal axis')
      write(1,57)
   57 format ('        em              xsnorm            xsec  ')
c     end of the xsect.bin header

c     nsp = 1 - spin average caclulations; 2 - spin up and down
      nsp = 1
      if (abs(ispin).eq.1) nsp = nspx
c     scale spin density on each atom appropriately
      do iph = 0, nph
       do i = 1, 251
         dmag(i,iph) = dmag(i, iph) * spinph(iph)
       enddo
      enddo

      do 300 isp = 1, nsp
        if (ispin.ne.0) then
c         make spin dependent potential if needed
c         isp = 1-spin-down; 2-spin-up potentials
          idmag = (-1)**isp
          if (nsp.eq.1) then
             idmag = 1
             if(ispin.lt.0) idmag=-1
          endif
          call  istprm (nph, nat, iphat, rat, iatph, xnatph,
     1               novr, iphovr, nnovr, rovr, folp, folpx, iafolp,
     1               edens, edenvl, idmag,
     2               dmag, vclap, vtot, vvalgs, imt, inrm, rmt, rnrm,
     3               ixc, rhoint,vint, rs, xf, xmu, xmunew,
     5               rnrmav, qtotel, inters, totvol)
          xmunew = xmu
          if (abs(ispin).eq.1 .and. nsp.eq.2) then
c           |ispinp| = |ispin|, but sign is determined by isp
             ispinp = abs(ispin)
             if (isp.eq.1) ispinp = -ispinp
          else
c            sign is determined by spin (always for ispin=-2,2)
             ispinp = ispin
          endif
        else
c         spin-independent case
          ispinp = 0
        endif

c       calculate operators of interest (s_z, l_z, t_z)
        xmuvr = xmu - vr0
        if (ipr2.ge.3) call szlz(ispinp,ecv,nph,nat,rgrd,nohole,rfms2,
     2     lfms2, lmaxph, edens, edenvl, dmag, vtot, vvalgs, rmt, rnrm,
     2     ixc, rhoint, vint, xmuvr, jumprm,
     3     xnval, iorb, x0, dx, xion, iunf, iz,
     5     adgc, adpc, dgc, dpc, ihole, rat, iphat, corr)
c    1                   em, ne1, ne, ik0 )

c       Cross section calculation, use phase mesh for now
c       Absorbing atom is iph=0
        write(slog,10) 'absorption cross section'
        call wlog(slog)
        iph = 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 (iph, 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             vint, rhoint, dx, dxnew, jumprm,
     2             vjump, ri, vvalph, rhphvl, dmagx)
           if (jumprm .gt. 0) jumprm = 1
        endif
        call fixdsp (dx, dxnew, dgc0, dpc0, dgcx, dpcx, jnew)
  
        if (itdlda.eq.0) then
c         Josh - added argument iPl to control many pole self energy
          call xsect (ipr2, dxnew, x0, ri, ne, ne1, ik0, em, edge,
     1       ihole, emu, corr, dgcx, dpcx, jnew,
     2       ixc0, lreal, rmt(0), rnrm(0), xmuvr, vi0, iPl,
     3       gamach, vtotph, vvalph, rhoph, dmagx, rhphvl, 
     4       dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), xsec(1,isp),
     5       xsnorm(1,isp), rkk(1,1,isp), iz(0), xion(0), iunf,
     6       xnval(1,iph), izstd, ifxc, eorb, kappa, iorb(-4,iph), l2lp,
     7       ipol, ispinp, le2, angks,ptz)
        else
          if (nonlocal.gt.0) then
c           read potential with core-hole from a file
            if (nonlocal.eq.1) then
              call rdpotp(vch)
            elseif (nonlocal.eq.2) then
c             open (unit=3, file='MgO_Mgk.dat', status='old')
              open (unit=3, file='wscrn.dat', status='old')
c             open (unit=3, file='w_m5p.dat', status='old')
c             open (unit=3, file='ni_l2.dat', status='old')
c             open (unit=3, file='ni_l2_sp.dat', status='old')
              n=0
 338          n = n+1
                read(3,337, end=339) dum1, dum2
c               use frac.ne.1  to mix bare and screened ch pot
c                frac = 0.80
c                frac = 1.00
                vch(n) = -1.d0*dum2
 337            format(6e20.10)
                goto 338
 339          continue
              close (unit=3)
            endif
            call fixvar (rmt(0), edens(1,0), vch, dmag(1,0),
     1             vint, rhoint, dx, dxnew, jumprm,
     2             vjump, ri, vchp, rhoph, dmagx)
            do 333 i = 1, nrptx
               if (ri(i).lt.rmt(0)) then
                 if (nonlocal.eq.1) then
                   vchp(i) = vchp(i) - vtotph(i)
                 endif
               elseif (ri(i).lt.40.d0) then
c                 assume const/r behaviour
                  vchp(i) = vchp(i-1) * ri(i-1) / ri(i) 
               else
                  vchp(i) = 0
               endif
c           testing: write core-hole potential in fort.17
               if (ri(i).lt.40.d0) write(17,332) ri(i), vchp(i)
 332            format(2f30.5)
 333        continue
           
            close (unit=17)
c           itest = 2
c           if (itest.eq.2) stop
          else
            do 334 i =1, nrptx
 334        vchp(i) = 0
          endif
          
c         Josh - added argument iPl to control many pole self energy
          call xsectd (ipr2,dxnew, x0, ri, ne, ne1, ik0, em, edge,
     1       ihole, emu, corr, dgcx, dpcx, jnew,
     2       ixc0, lreal, rmt(0), rnrm(0), xmuvr, vi0, iPl,
     3       gamach, vtotph, vvalph,vchp, rhoph, dmagx, rhphvl,
     4       dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), xsec(1,isp),
     5       xsnorm(1,isp), rkk(1,1,isp),iz(0), xion(0), iunf,
     6       xnval(1,iph), ipmbse, ifxc, ibasis, eorb, kappa,
     7       iorb(-4,iph), l2lp, ipol, ispinp, le2, angks,ptz, itdlda)
        endif


        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), vint, rhoint, dx, dxnew, jumprm,
     2                vjump, ri, vvalph, rhphvl, dmagx)
            if (jumprm .gt. 0) jumprm = 1
            call fixdsx (iph, dx, dxnew, dgc, dpc, dgcn, dpcn)
          endif
          if (iph .eq. 0)  then
            itmp = ihole
          else
            itmp = 0
          endif

          call phase (iph, dxnew, x0, ri, ne, ne1, ne3, em, ixc, nsp,
     1            lreal, rmt(iph),rnrm(iph), xmuvr, vi0, iPl,
     2            gamach, vtotph, vvalph, rhoph, dmagx, rhphvl,
     3            dgcn, dpcn, adgc(1,1,iph), adpc(1,1,iph), eref(1,isp),
     4            ph(1,-ltot,isp,iph), lmax(iph), iz(iph), itmp,
     5            xion(iph), iunf, xnval(1,iph), ispinp)
 60     continue

 300  continue

c     write main output to xsect.bin
  340 format (e17.9, 4e13.5)
      if (abs(ispin).ne.1 .or. nspx.eq.1) then
        do 350  ie = 1, ne
           write(1,340) dble(em(ie))*hart, dimag(em(ie))*hart,
     1                 xsnorm(ie,1), dble(xsec(ie,1)), dimag(xsec(ie,1))
  350   continue
      else
c       nspx = 2
        do 380  ie = 1, ne
           write(1,340) dble(em(ie))*hart, dimag(em(ie))*hart,
     1             (xsnorm(ie,1) + xsnorm(ie,nspx)) / 2.d0 ,
     2           dble( (xsec(ie,1) + xsec(ie,nspx)) ),
     3          dimag( (xsec(ie,1) + xsec(ie,nspx)) )
c          Normalize rkk to the average over up/down spin
c          nsp=2
           xnorm1 = sqrt( 2*xsnorm(ie,1) /
     1                         (xsnorm(ie,1) + xsnorm(ie,nspx)) )
           xnorm2 = sqrt( 2*xsnorm(ie,nspx) /
     1                         (xsnorm(ie,1) + xsnorm(ie,nspx)) )
           do 360 kdif = 1,8
             rkk (ie, kdif, 1) = rkk (ie, kdif, 1) * xnorm1
             rkk (ie, kdif, nspx) = rkk (ie, kdif, nspx) * xnorm2
  360      continue
  380   continue
      endif
      close (unit=1)

c     disable for now since dimensions are different
      if (ipr2 .ge. 2)  then
         call wphase (nph, em, eref, lmax, ne, ph, ntitle, title)
      endif

c     Write out phases for paths and genfmt
      call wrxsph (nsp, ne, ne1, ne3, nph, ihole, rnrmav, xmuvr,
     &     edge,ik0,em, eref, lmax, iz, potlbl, ph, rkk)

      if (ipr2 .ge. 1) then
c       calculate axafs
c       axafs does not make sense for |ispin| = 1
        call axafs (em, emu, xsec(1,1), ne1, ik0)
      endif

      return
      end
      subroutine szlz (ispin, ecv, nph, nat, rgrd, nohole, rfms2, lfms2,
     2           lmaxph, edens, edenvl, dmag, vtot, vvalgs, rmt, rnrm,
     2           ixc, rhoint, vint, xmu, jumprm,
     3           xnval, iorb, x0, dx, xion, iunf, iz,
     5           adgc, adpc, dgc, dpc, ihole, rat, iphat, corr)


c     Finds new Fermi level (xmu), electron counts 

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      integer ispin

c     input
      dimension dmagx(nrptx), dmag(251,0:nphx+1)
      dimension vtot (251,0:nphx), vvalgs (251,0:nphx)
      dimension rmt(0:nphx),rnrm(0:nphx)
      dimension xnval (30,0:nphx), iorb (-4:3,0:nphx)
      dimension ri(nrptx)
      dimension iz(0:nphx), xion(0:nphx), lmaxph(0:nphx)
      dimension rat(3,natx),iphat(natx)
      real  rfms, rfms2
c     input and output
      dimension edens(251,0:nphx), edenvl(251,0:nphx)

c     work space
      dimension xnmues(3,0:lx,0:nphx)
      complex*16 fl(3,0:lx,0:nphx), fr(3,0:lx,0:nphx)
      complex gtr(2,2, 3,0:lx, 0:nphx)
      real amat(-lx:lx,2,2, 3,0:lx), gctr(2,2, 3,0:lx,0:nphx)
      dimension dum(nrptx), vtotph(nrptx),vvalph(nrptx)
      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      dimension adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      complex*16 xrhoce(-4:3, -4:3, 0:nphx), xrhole(-4:3, -4:3, 0:nphx)
      complex*16 ph(lx+1, 0:nphx)
      integer iph
c     complex energy grid emg is decomposed into em and eref
      parameter (negx = 80)
      complex*16 emg(negx), em, eref, ee, ep, cchi, de
c     nflrx should be odd and defines the max of Im energy for
c     the countour 
      parameter (nflrx = 17)
      dimension step(nflrx)
      character*512 slog

      call setkap(ihole, kinit, linit)

      if (ispin.eq.0) then
        write (slog,8)
   8    format('              N_l, N_j- and N_j+ calculation')
        write (slog,9)
   9    format('              ONLY central atom contribution! ')
      elseif (abs(ispin).le.1) then
        write (slog,10)
  10    format('              S_z, L_z and t_z calculation')
      else 
        write (slog,11)
  11    format('              S_z, N_l and N_j calculation')
      endif
      call wlog(slog)

      call wlog (' Calculating energy and space dependent l-DOS.')
      call wlog (' It takes time ...')

c     calculate energy independent matrix of angular coefficients
      call acoef(ispin, amat)

      call grids (ecv, xmu, negx, neg, emg, step, nflrx)

c     ie - is number of energy points calculated
      ie = 0
      ee = emg(1)
      ep = dble(ee)
      do 22 iph=0,nphx
      do 22 il=0,lx
      do 22 i=1,3
        xnmues(i, il,iph) = 0
  22  continue

c     Start the cycle over energy points (ie)
  25  continue
      ie = ie + 1

      if (ie.eq.1 .or. mod(ie,20).eq.0) then
         write(slog,30) ie, dble(ee)*hart
   30    format('     point # ', i3, '  energy = ', f7.3)
         call wlog(slog)
      endif

      do 100  iph = 0, nph

         call fixvar (rmt(iph),edens(1,iph),vtot(1,iph),dmag(1,iph),
     1                vint, rhoint, dx, rgrd, jumprm,
     2                vjump, ri, vtotph, dum, 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), vint, rhoint, dx, rgrd , jumprm,
     2                vjump, ri, vvalph, dum, dmagx)
            if (jumprm .gt. 0) jumprm = 1
         endif

         call fixdsx (iph, dx, rgrd , dgc, dpc, dgcn, dpcn)
        jri = (log(rmt(iph)) + x0) / rgrd + 2
        jri1 = jri+1
        eref = vtotph(jri1)
        do 40 i = 1, jri1
  40    vtotph(i) = vtotph(i) - eref
        if (ixc.ge.5) then
           do 50 i = 1, jri1
  50       vvalph(i) = vvalph(i) - eref
        else
           do 60 i = 1, jri1
  60       vvalph(i) = vtotph(i)
        endif

         itmp = 0
c        icount=1 for Renormalized atom counts
c        icount=2 for Mulliken counts
         icount = 0
         if (iph.eq.0 .and. nohole.lt.0) itmp = ihole
         if (icount.gt.0) then
            call rholat( icount, rgrd, x0, ri, ee,
     2           ixc, rmt(iph), rnrm(iph),
     3           vtotph, vvalph, xnval(1,iph), iorb(-4,iph),
     3           dgcn, dpcn, eref,
     4           adgc(1,1,iph), adpc(1,1,iph), xrhole(-4,-4,iph),
     5           xrhoce(-4,-4,iph), ph(1,iph),
     6           iz(iph), xion(iph), iunf, itmp,3)
         else
            call rholsz( rgrd, x0, ri, ee,
     2           ixc, rmt(iph), rnrm(iph),
     3           vtotph, vvalph, xnval(1,iph), dgcn, dpcn, eref,
     4           adgc(1,1,iph), adpc(1,1,iph), xrhole(-4,-4,iph),
     5           xrhoce(-4,-4,iph), ph(1,iph),
     6           iz(iph), xion(iph), iunf, itmp,3)
         endif
  100 continue

c     Write out phases for fmssz
c     transform neg,emg to em,ne,eref first
      em= dble(ee)
      eref=dble(eref)-coni*dimag(ee)

cc    call fms for a cluster around central atom
      do 195 iph0 = 0,nph
      do 195 il = 0, lx
      do 195 i = 1, 3
      do 195 i2= 1, 2
      do 195 i1= 1, 2
         gtr( i1,i2, i, il, iph0) = 0
         gctr(i1,i2, i, il, iph0) = 0
  195 continue

      rfms = 0
c     only central atom contribution for ispin = 0
ctemp if (ispin.ne.0)  rfms = rfms2
      rfms = rfms2

      if (lfms2 .ne. 0) then
        iph0 = 0
        call fmssz( iph0, ie,  em, eref, ph, iz, nph,
     1        rfms, lfms2, nat, iphat, rat, amat, lmaxph, gctr, gtr)
      else
        do 190 iph0 = 0, nph 
  190   call fmssz( iph0,  ie, em, eref, ph, iz, nph,
     1        rfms, lfms2, nat, iphat, rat, amat, lmaxph, gctr, gtr)
      endif

      de = ee-ep
      do 300 iph = 0,nph
      do 300 lpp = 0,lx
      do 300 iop = 1,3
c       calculate density and integrated number of electrons in each
c       channel for each type of atoms density, etc.
        if (ie.gt.1) fl(iop,lpp,iph) = fr( iop,lpp,iph)
        fr( iop,lpp,iph) = 0
        call kfromi (1, lpp, j1, kk1)
        call kfromi (2, lpp, j1, kk2)
        do 200 i1=1,2
        do 200 i2=1,2
          call kfromi (i1, lpp, j1, k1)
          call kfromi (i2, lpp, j1, k2)
          if (k1.eq.0 .or. k2.eq.0) goto 200

          cchi =  dble( real( gtr(i1,i2, iop,lpp,iph) )) + 
     1           coni* dble(aimag( gtr(i1,i2, iop,lpp,iph) ))
c         fr( iop,lpp,iph) = fr( iop,lpp,iph) + cchi * xrhole(k1,k2,iph)
c         use above kk1,kk1 for j- value, kk2,kk2 for j+ value
          if (ispin.ne.0 .or. iop.eq.1) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph) + cchi*xrhole(k1,k2,iph)
          elseif(iop.eq.2) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhole(kk1,kk1,iph)
          elseif(iop.eq.3) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhole(kk2,kk2,iph)
          endif

c         add central atom part
          cchi =  dble(  gctr(i1,i2, iop,lpp,iph) ) 
          if (ispin.ne.0 .or. iop.eq.1) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph) + cchi*xrhoce(k1,k2,iph)
c           use above k1,k1 for j- value, k2,k2 for j+ value
          elseif(iop.eq.2) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhoce(kk1,kk1,iph)
          elseif(iop.eq.3) then
            fr( iop,lpp,iph) = fr( iop,lpp,iph)+cchi*xrhoce(kk2,kk2,iph)
          endif
 200    continue

c       do integral over energy with trapezoidal rule
        if (ie.eq.1)  fl( iop,lpp,iph) = fr( iop,lpp,iph)
        xnmues(iop,lpp,iph) =  xnmues(iop,lpp,iph) +
     1  dimag((fl(iop,lpp,iph) + fr(iop,lpp,iph)) * de /2)
        if (ie.eq.neg) then
c          end point correction
           xnmues(iop,lpp,iph) =  xnmues(iop,lpp,iph) +
     1     dimag( fr(iop,lpp,iph) * (dble(ee)-ee) )
        endif

  300 continue

c     next energy point
      if (ie.lt.neg) then
         ep = ee
         ee = emg(ie+1)
         goto 25
      endif

c     report configuration; repeat iteration if found bad counts.
      call wlog('  Electronic configuration')
      call wlog('  Electronic configuration:Mulliken counts')
      if (ispin.eq.0) then
         call wlog('   iph    il      N_l   N_j-  N_j+')
      elseif (abs(ispin).eq.1) then
         call wlog('   iph    il      S_z   L_z   T_z')
      else
         call wlog('   iph    il      S_z   N_l   N_j')
      endif
 310  format (2i6, 3f9.4)
      do 320 ip= 0,nph
      do 320 il = 0,lx
         write (slog,310) ip,il,(xnmues(i,il,ip), i=1,3)
         call wlog(slog)
 320  continue
      corr = 1.d0
      if (ispin.eq.0 .and. kinit.ne.-1) then
c       calculation  changes in counts due to spin-orbit interaction
        ip = 2
        if (kinit.lt.0) ip = 3
        il = linit + 1
        if (linit.eq.3) il = linit - 1
        corr = xnmues(1,il,0) /xnmues (ip,il, 0)
      endif

      return
      end
      subroutine acoef(ispin, amat)
c     performs the sum of the product of 4 3j symbols
c       ispin - type of spin calculation
c       amat  - matrix to calculate density via
c             \mu=\mu_at*(1- Im \sum_kp,kpp rkk(kp)*rkk(kpp)*
c                         \sum_m1,m2 bmat(kp,kpp,m1,m2)*G_lp,m2;lpp,m1 )

      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      integer ispin

      real  amat(-lx:lx,2,2, 3,0:lx)
      real t3j(0:lx,0:lx,0:1), operls (0:1, 0:1, 3)
      real xms, xml, xmj

      external cwig3j

      do 10 i5 =  0,lx
      do 10 i4 =  1,3 
      do 10 i3 =  1,2
      do 10 i2 =  1,2
      do 10 i1 = -lx,lx
         amat(i1,i2,i3,i4,i5)=0
  10  continue
      ms = 1
      if (ispin.lt.0) ms=0
      print*, ' Spin = ', 2*ms-1

      do 100 ml = -lx, lx
        mj = 2*ml + (2*ms-1)
        xmj = 0.5e0*mj
        mj = -mj
c       mj is conserved for all operators of interst (s_z, l_z, t_z)
c       tabulate necessary Clebsh-Gordon coefficients
        do 20 lp = 0,lx
        do 20 jp = 0,lx
        do 20 mp = 0,1
           lp2 = 2*lp
           jp2 = 2*jp+1
           mp2 = 2*mp-1
           t3j(lp,jp,mp) = (-1)**lp *sqrt(jp2+1.e0) * 
     1                    real( cwig3j ( 1, jp2, lp2, mp2, mj, 2) )
 20     continue

        do 90 lpp = 0,lx
          do 30 m1=0,1
          do 30 m2=0,1
          do 30 iop=1,3
            operls(m1,m2,iop) = 0
            if (m1.eq.m2) then
              xms =  m1 - 0.5e0
              xml = xmj-xms
              if (abs(ml+ms-m1).le.lpp) then
                if (ispin.eq.0) then
c                 occupation numbers N_l, N_j- , N_j+
                  operls(m1,m2,iop) = 2
                elseif (iop.eq.1) then
c                 s_z operator in ls basis
                  operls(m1,m2,iop) = xms
                elseif (iop.eq.2 .and. abs(ispin).eq.1) then
c                 l_z operator
                  operls(m1,m2,iop) = xml
                elseif (iop.eq.2 .and. abs(ispin).eq.2) then
c                 unit operator for occupation numbers
                  operls(m1,m2,iop) = 1
                elseif (iop.eq.3 .and. abs(ispin).eq.1) then
c                 t_z operator
                  operls(m1,m2,iop) = xms*2*(3*xml**2-lpp*(lpp+1))
     1                                /(2*lpp+3) /(2*lpp-1)
                elseif (iop.eq.3 .and. abs(ispin).eq.2) then
c                 occupation number for j=l+1/2
                  operls(m1,m2,iop) = t3j(lpp,lpp,m1)**2
                endif
              endif
            else
c             t_z only has nonzero off diagonal matrix elements 
              if (iop.eq.3 .and. abs(ispin).le.1 .and.
     1        nint( 0.5e0+abs(xmj)).lt.lpp)  then
                 operls(m1,m2,iop)=3*xmj*
     1           sqrt(lpp*(lpp+1)-(xmj**2-0.25e0)) /(2*lpp+3) /(2*lpp-1)
              elseif (iop.eq.3 .and. abs(ispin).gt.1) then
                 operls(m1,m2,iop)= t3j(lpp,lpp,m1)* t3j(lpp,lpp,m2)
              endif
            endif
  30      continue

c         calculate energy and r independent matrix amat
c         which is equivalent to integration over angular coordinates
c         for assumed density matrix
          do 80 i1=1,2
             call kfromi(i1,lpp,jj,k1)
             if (k1.eq.0) goto 80
             do 70 i2=1,2
                call kfromi(i2,lpp,jp,k2)
                if (k2.eq.0) goto 70
                do 60 iop=1,3
                do 60 m2=0,1
                do 60 m1=0,1
                  amat(ml,i1,i2,iop,lpp) =  amat(ml,i1,i2,iop,lpp) +
     1            operls(m1,m2,iop) * t3j(lpp,jp,ms)* t3j(lpp,jp,m1)*
     2            t3j(lpp,jj,m2)*t3j(lpp,jj,ms)
  60            continue
  70         continue
  80      continue
  90    continue
 100  continue

      return
      end

      subroutine kfromi (i, lpp, jj, k)
c     input index i1 and orb. mom. lpp
c     output: final state kappa - k; jj=tot.mom(k)-1/2
      integer i, lpp, jj, k

      jj = lpp + i - 2
      k = - lpp - 1
      if (i.eq.1) k = lpp

      return
      end
      subroutine fmssz( iph0, ie, em, eref, ph, iz, nph,
     1           rfms, lfms, nat, iphat, rath, amat, lipotx, gctr, gtr)
c     uses Bruce Ravel subroutine to do FMS in self-consistency loop
c     written by alexei ankudinov 06.1997

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     input
      dimension iphat(natx), rath(3,natx)
      real rat(3,natx), rfms
      real rpart,aipart
      integer nph
      dimension iz(0:nphx)

c     work space
      complex*16 ph(lx+1, 0:nphx)
      integer iph
      complex*16 em, eref
      character*512 slog
c     fms staff
      integer lipotx(0:nphx)
      complex gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphx)
      complex gtr(2,2, 3,0:lx, 0:nphx)
      real amat(-lx:lx,2,2, 3,0:lx), gctr(2,2, 3,0:lx, 0:nphx)
      complex xphase(nspx, -lx:lx, 0:nphx), ck(nspx)
      complex*16 dck
      real  rdirec, toler1, toler2
      logical lcalc
      dimension lcalc(0:lx)
      save

      if (rfms .gt. 0) then
        do 25 iat=1,nat
        do 25 j=1,3
   25   rat(j,iat) = real (rath(j,iat))

c       transform to single precision
        minv = 0
        rdirec = 2*rfms
        toler1 = 0.e0
        toler2 = 0.e0


c       it will be nice to call yprep once for all energy points,
c       fix later, and now call it every time
        if (ie.eq.1 .or. lfms.eq.0) 
     1    call yprep(iph0, nat, inclus, nph, iphat, rfms, rat,
     2       iz, rdirec)

        if (inclus.gt.1) then
cc        call fms for a cluster around central atom
          if (ie.eq.1) then
             write (slog,35) inclus, iph0
  35         format ('        Doing FMS for a cluster of ',i3,
     1       ' atoms around iph = ',i2)
             call wlog (slog)
          endif

          dck=sqrt(2*(em-eref))
          rpart  = real(dble(dck))
          aipart = real(dimag(dck))
          ck(1) = cmplx(rpart, aipart)
          do 50 ipp = 0,nph
            do 40 ill = -lipotx(ipp), lipotx(ipp)
              rpart  = real(dble( ph(abs(ill)+1,ipp)))
              aipart = real(dimag(ph(abs(ill)+1,ipp)))
              xphase(1, ill, ipp) = cmplx(rpart, aipart)
  40        continue
  50      continue
          iverb=0
          if (ie.eq.1) iverb = 1
c         neglect spin-flip processes (fix later for ispin=1)
          nsp = 1
          ispin = 0
          do 55 ill = 0, lx
  55      lcalc(ill) = .true.
          call fms(lfms, nsp, ispin, inclus, nph, ck, lipotx, xphase,ie,
     1     iverb, minv, rdirec, toler1, toler2, lcalc,gg)
        endif
      endif

      do 200 ip=0,nph

        if (lfms.ne.0 .or. ip.eq.iph0) then
          do 190 lpp =0,lipotx(ip)
             ix1 = lpp**2 
             do 170 im=1,2*lpp+1
c              now cycle over gtr dimensions
               do 100 iop = 1,3
               do 100 i2 = 1,2
               do 100 i1 = 1,2
                 if (rfms.gt.0 .and. inclus.gt.0) gtr(i1,i2,iop,lpp,ip)= 
     1             gtr(i1,i2,iop,lpp,ip) + amat(im-lpp-1,i1,i2,iop,lpp)
     2             * gg(ix1+im,ix1+im,ip)
                 gctr(i1, i2, iop,lpp,ip)= gctr(i1, i2, iop,lpp,ip)
     1             + amat(im-lpp-1,i1,i2,iop,lpp)
 100           continue
 170         continue
 190      continue
        endif
 200  continue

      return
      end
      subroutine rholsz ( dx, x0, ri, em,
     2                  ixc, rmt, rnrm,
     3                  vtot, vvalgs, xnval, dgcn, dpcn, eref,
     4                  adgc, adpc, xrhole, xrhoce, ph,
     i                  iz, xion, iunf, ihole, lmaxsc)

      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,  complex energy grid
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     rmt          r muffin tin
c     rnrm         r norman
c     vtot(nr)     total potential, including gsxc, final state
c     dgcn(dpcn)   large (small) dirac components for central atom
c     adgc(adpc)   their development coefficients
c
c     OUTPUT
c     xrhole(0:lx)  integral over r of density function
c     xrhoce(0:lx)  the same integral for embedded atom only


c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     max number allowed in xsect r-grid
      parameter (nrx = nrptx)

c     output
      complex*16  xrhole(-4:3,-4:3)
      complex*16  xrhoce(-4:3, -4:3)
      complex*16  ph(lx+1)

      dimension ri(nrptx), ri05(251)
      dimension  vtot(nrptx), vvalgs(nrptx)
      complex*16 vtotc(nrptx), vvalc(nrptx)
      dimension xnval(30), dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30)

c     energy grid in complex e-plane
      complex*16 em, eref

c     work space for dfovrg: regular and irregular solutions
      complex*16 pr(nrx,2,2), qr(nrx,2,2), pn(nrx,2,2), qn(nrx,2,2)

      complex*16  p2, xkmt, ck, xck
      complex*16  pu, qu
      complex*16  xfnorm, xirf, xmp, xpm
      complex*16  temp,  phx, phm(2,2), factor

      complex*16 jl,jlp1,nl,nlp1
      complex*16  xpc(nrx)

c     initialize
      lmax=lmaxsc
      if (lmax.gt.lx) lmax = lx
      if (iz.le.4) lmax=2
      if (iz.le.2) lmax=1
      do 20 i = 1, nrptx
         vtotc(i)=vtot(i)
         vvalc(i)= vvalgs(i)
  20  continue
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
      if (jri .gt. nrptx)  call par_stop('jri .gt. nrptx in phase')
      inrm = (log(rnrm) + x0) / dx  +  1
      jnrm = inrm+1

c     set limits for tabulations
      nr05= (log(rnrm) + x0) / 0.05d0 + 5
      if (nr05.gt.251) nr05 = 251
c     ilast is the last integration point
c     it is larger than jnrm for better interpolations
      ilast = nint( (nr05-1) *0.05d0 / dx ) + 1
      if (ilast.gt.nrptx) ilast=nrptx

      do 10 i = -4,3
      do 10 j = -4,3
         xrhole(i,j) = 0
         xrhoce(i,j) = 0
  10  continue
      do 15 i=1,lx+1
  15  ph(i) = 0

c     p2 is 0.5*(complex momentum)**2 referenced to energy dep xc
c     need hartree units for dfovrg
      p2 = em - eref
      if (mod(ixc,10) .lt. 5) then
        ncycle = 0
      else
        ncycle = 3
      endif
      ck = sqrt(2*p2 + (p2*alphfs)**2)
      xkmt = rmt * ck

      do 200 lll=0,lmax
        do 199 jd = 0,1
          ikap = (lll+jd)* (-1)**jd
          if (ikap.eq.0) goto 199

          ilp = lll + 1
          if (ikap.gt.0) ilp = lll - 1
          im = 1+ jd

          do 150 j = 1, 2
            ic3 = j-1
            if (lll.eq.0 .and. ic3.eq.1) goto 150

            irr = -1
            call dfovrg ( ncycle, ikap, rmt, ilast, jri, p2, dx,
     $                ri, vtotc, vvalc, dgcn, dpcn, adgc, adpc,
     $                xnval, pu, qu, pn(1,im,j), qn(1,im,j),
     $                iz, ihole, xion, iunf, irr, ic3)
            
            call exjlnl (xkmt, lll, jl, nl)
            call exjlnl (xkmt, ilp, jlp1, nlp1)
            call phamp (rmt, pu, qu, ck,  jl, nl, jlp1, nlp1, ikap,
     1                  phx, temp)
            if (lll.eq.0)  ph(1)=phx
            phm(im,j) = phx

c           Normalize final state  at rmt to
c           rmt*(jl*cos(delta) - nl*sin(delta))
            xfnorm = 1 / temp
c           normalize regular solution
            do 133  i = 1,ilast
              pr(i,im,j)=pn(i,im,j)*xfnorm
              qr(i,im,j)=qn(i,im,j)*xfnorm
  133       continue

c          find irregular solution
            irr = 1
            pu = ck*alphfs
            factor = pu/(1+sqrt(1+pu**2))
            if (ikap.lt.0) factor = -factor
c           set pu, qu - initial condition for irregular solution at ilast
c           qu=(nlp1*cos(phx)+jlp1*sin(phx))*pu *rmt
c           pu = (nl*cos(phx)+jl*sin(phx)) *rmt
            qu=(nlp1*cos(phx)+jlp1*sin(phx))* factor *rmt 
            pu = (nl*cos(phx)+jl*sin(phx)) *rmt 

            call dfovrg (ncycle, ikap, rmt, ilast, jri, p2, dx,
     1              ri, vtotc,vvalc, dgcn, dpcn, adgc, adpc,
     1              xnval, pu, qu, pn(1,im,j), qn(1,im,j),
     1              iz, ihole, xion, iunf, irr, ic3)
cc            set N- irregular solution , which is outside
cc            N=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1
cc            N = i*R - H*exp(i*ph0)
              temp = exp(coni*phx)
              do i = 1, ilast
                pn(i,im,j) = coni * pr(i,im,j) - temp * pn(i,im,j)
                qn(i,im,j) = coni * qr(i,im,j) - temp * qn(i,im,j)
              enddo

 150      continue

c         combine all constant factors to temp
c         add relativistic correction to normaliz. and factor 2*lll+1
          temp = 2*ck / (1+factor**2) / pi
  
c         ic3 = 0, j= ic3+1
          j = 1
c         calculate diagonal radial integrals R(k1,k1) - xrhoce and xrhole
            do 190  i = 1, ilast
              xpc(i) = pr(i,im,j) **2 + qr(i,im,j) **2
 190        continue
            xirf = lll*2 + 2
c           i0 should be less or equal to  ilast
            i0=jnrm+1
            call csomm2 (ri, xpc, dx, xirf, rnrm, i0)
            xrhole(ikap,ikap) =xirf*temp*exp(coni*(phm(im,j)+phm(im,j)))

c         only central atom contribution needs irregular solution
            do 195  i = 1, ilast
              xpc(i) = pn(i,im,j)*pr(i,im,j)+ qn(i,im,j) *qr(i,im,j)
              xpc(i) = xpc(i) - coni*(pr(i,im,j)**2 + qr(i,im,j)**2)
 195        continue
            xirf =  1
            call csomm2 (ri, xpc, dx, xirf, rnrm, i0)
            xrhoce(ikap,ikap) = - xirf * temp

c         calculate cross terms
          if (ikap.lt.-1) then
            k1 = ikap + 2*lll + 1
            do 290  i = 1, ilast
              xpc(i) = pr(i,1,j) * pr(i,2,j) + qr(i,1,j) * qr(i,2,j) 
 290        continue
            xirf = lll*2 + 2
c           i0 should be less or equal to  ilast
            i0=jnrm+1
            call csomm2 (ri, xpc, dx, xirf, rnrm, i0)
            xrhole (ikap, k1) = xirf*temp* exp(coni*(phm(1,j)+phm(2,j)))
            xrhole (k1, ikap) = xrhole (ikap, k1)

c           ic3 = 1, j= ic3+1
            j = 2
            xpm =  exp(coni*(phm(1,j)-phm(2,j))) / 2
            xmp =  exp(coni*(phm(2,j)-phm(1,j))) / 2
            do 295  i = 1, ilast
              xpc(i) = (pn(i,1,j)*pr(i,2,j)+ qn(i,1,j) *qr(i,2,j)) * xmp
     1               + (pn(i,2,j)*pr(i,1,j)+ qn(i,2,j) *qr(i,1,j)) * xpm
              xpc(i) = xpc(i) - coni*(xpm+xmp) *
     1                 (pr(i,1,j)*pr(i,2,j) + qr(i,1,j)*qr(i,2,j))
 295        continue
            xirf =  1
            call csomm2 (ri, xpc, dx, xirf, rnrm, i0)
            xrhoce(ikap,k1) = - xirf * temp
            xrhoce(k1,ikap) =  xrhoce(ikap,k1)
          endif
 199    continue 
 200  continue 

c     calculate phase shift in old way (ic3=1) test new one
c     which is commented out above later
      do 300 lll = 1,lmax
          im = 1
          ikap = -lll-1
          irr = -1
          ic3 = 1
          call dfovrg ( ncycle, ikap, rmt, ilast, jri, p2, dx,
     $                ri, vtotc, vvalc, dgcn, dpcn, adgc, adpc,
     $                xnval, pu, qu, pr(1,im,1), qr(1,im,1),
     $                iz, ihole, xion, iunf, irr, ic3)
            
          call exjlnl (xkmt, lll, jl, nl)
          call exjlnl (xkmt, lll+1, jlp1, nlp1)
          call phamp (rmt, pu, qu, ck,  jl, nl, jlp1, nlp1, ikap,
     1                  phx, temp)
          ph(1+lll)=phx
 300  continue

      return
      end
      subroutine rholat ( icount, dx, x0, ri, em,
     2                  ixc, rmt, rnrm,
     3                  vtot, vvalgs, xnval, iorb, dgcn, dpcn, eref,
     4                  adgc, adpc, xrhole, xrhoce, ph,
     i                  iz, xion, iunf, ihole, lmaxsc)

      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,  complex energy grid
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     rmt          r muffin tin
c     rnrm         r norman
c     vtot(nr)     total potential, including gsxc, final state
c     dgcn(dpcn)   large (small) dirac components for central atom
c     adgc(adpc)   their development coefficients
c
c     OUTPUT
c     xrhole(0:lx)  integral over r of density function
c     xrhoce(0:lx)  the same integral for embedded atom only


c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     max number allowed in xsect r-grid
      parameter (nrx = nrptx)

c     output
      complex*16  xrhole(-4:3,-4:3)
      complex*16  xrhoce(-4:3, -4:3)
      complex*16  ph(lx+1)

      dimension ri(nrptx), ri05(251)
      dimension  vtot(nrptx), vvalgs(nrptx)
      complex*16 vtotc(nrptx), vvalc(nrptx)
      dimension xnval(30), iorb(-4:3), dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30)

c     energy grid in complex e-plane
      complex*16 em, eref

c     work space for dfovrg: regular and irregular solutions
      complex*16 pr(nrx,2,2), qr(nrx,2,2), pn(nrx,2,2), qn(nrx,2,2)

      complex*16  p2, xkmt, ck, xck
      complex*16  pu, qu
      complex*16  xfnorm, xirf, xmp, xpm
      complex*16  temp,  phx, phm(2,2), factor

      complex*16 jl,jlp1,nl,nlp1
      complex*16  xpc(nrx)

c     nesvi
      dimension pat(nrx,2,2),qat(nrx,2,2)
      complex*16 intr(nrx,2,2),var(nrx) 
      dimension xq(nrptx),xp(nrptx)
      complex*16 xkmi

c     initialize
      lmax=lmaxsc
      if (lmax.gt.lx) lmax = lx
      if (iz.le.4) lmax=2
      if (iz.le.2) lmax=1
      do 20 i = 1, nrptx
         vtotc(i)=vtot(i)
         vvalc(i)= vvalgs(i)
  20  continue
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
      if (jri .gt. nrptx)  call par_stop('jri .gt. nrptx in phase')

      inrm = (log(rnrm) + x0) / dx  +  1
      jnrm = inrm+1

c     define ilast1,rlast
      rlast=rnrm
      if (icount.eq.2) rlast=10*rnrm
      jlast1=(log(rlast) + x0)/ dx + 2
      ilast1=jlast1 + 6

cc    nesvi
cc    dgcn and dpcn should be normalized <n|n>=1, check this here
     
      do 440 j = -4, 3
        jj = iorb(j)
        if (jj.le.0) goto 440

        do 420  i = 1, jlast1
         xp(i) = dpcn(i,jj)**2 + dgcn(i,jj)**2
         xq(i) = 0
  420   continue
cc      nb, xinorm is used for exponent on input to somm
        lfin = j
        if (j.lt.0) lfin = -j - 1
        xinorm = 2*lfin + 2
        i0 = jnrm + 1
        call somm2 (ri, xp, dx, xinorm, rnrm, 0, i0)
        if (xinorm.lt.0.99 .and. icount.eq.2) then
           call wlog
     1     ('  WARNING: small overlap integral for Mulliken count')
        endif
    
        xinorm = 1.d0 / sqrt(xinorm)
        do 430 i=1,nrptx
          dpcn(i,jj)=dpcn(i,jj) * xinorm
          dgcn(i,jj)=dgcn(i,jj) * xinorm
  430   continue
  440 continue

c     set limits for tabulations
      nr05= (log(rnrm) + x0) / 0.05d0 + 5
      if (nr05.gt.251) nr05 = 251
c     ilast is the last integration point
c     it is larger than jnrm for better interpolations
      ilast = nint( (nr05-1) *0.05d0 / dx ) + 1
      if (ilast.gt.nrptx) ilast=nrptx

      if (ilast1.gt.nrptx) ilast1=nrptx

      do 10 i = -4,3
      do 10 j = -4,3
         xrhole(i,j) = 0
         xrhoce(i,j) = 0
  10  continue
      do 15 i=1,lx+1
  15  ph(i) = 0

c     p2 is 0.5*(complex momentum)**2 referenced to energy dep xc
c     need hartree units for dfovrg
      p2 = em - eref
      if (mod(ixc,10) .lt. 5) then
        ncycle = 0
      else
        ncycle = 3
      endif
      ck = sqrt(2*p2 + (p2*alphfs)**2)
      xkmt = rmt * ck

      do 200 lll=0,lmax
        do 199 jd = 0,1
          ikap = (lll+jd)* (-1)**jd
          if (ikap.eq.0) goto 199

          ilp = lll + 1
          if (ikap.gt.0) ilp = lll - 1
          im = 1+ jd

          do 150 j = 1, 2
            ic3 = j-1
            if (lll.eq.0 .and. ic3.eq.1) goto 150

            irr = -1
            call dfovrg ( ncycle, ikap, rmt, ilast1, jri, p2, dx,
     $                ri, vtotc, vvalc, dgcn, dpcn, adgc, adpc,
     $                xnval, pu, qu, pn(1,im,j), qn(1,im,j),
     $                iz, ihole, xion, iunf, irr, ic3)
            
            call exjlnl (xkmt, lll, jl, nl)
            call exjlnl (xkmt, ilp, jlp1, nlp1)
            call phamp (rmt, pu, qu, ck,  jl, nl, jlp1, nlp1, ikap,
     1                  phx, temp)
            if (lll.eq.0)  ph(1)=phx
            phm(im,j) = phx

c           Normalize final state  at rmt to
c           rmt*(jl*cos(delta) - nl*sin(delta))
            xfnorm = 1 / temp
c           normalize regular solution
            do 133  i = 1,ilast1
              pr(i,im,j)=pn(i,im,j)*xfnorm
              qr(i,im,j)=qn(i,im,j)*xfnorm
  133       continue

c-----------------------
c           nesvi            

cc           add solution beyond Rmt:
c             do 1010 i=jri+1, ilast1
c                xkmi=ri(i)*ck
c                call exjlnl(xkmi,lll,jl,nl)
c                pr(i,im,j)=(jl*cos(phx)-nl*sin(phx))*ri(i)
c                qr(i,im,j)=0.0d0
c1010         continue

c             chose atomic function for making projection.
c             Project on corresponding atomic states. 
              jj = iorb(ikap)

c             make corresponding atomic functions
              if (jj.eq.0) then
                do 397 i=1,nrptx
                  pat(i,im,j)=0
                  qat(i,im,j)=0
  397           continue
              else
                do 398 i=1,nrptx
                  pat(i,im,j)=dgcn(i,jj)
                  qat(i,im,j)=dpcn(i,jj)    
  398           continue
              endif

            open(unit=3,file='wfat.dat',status='unknown')    

c         only central atom contribution needs irregular solution
            do 194  i = 1, ilast1           
                write(3,1019) ri(i)/rnrm, dgcn(i,6),dgcn(i,8),
     1          dgcn(i,10),dgcn(i,12)
 1019           format(f10.5,1x,e10.4,1x,e10.4,1x,e10.4,1x,e10.4)

 194         continue

            close(3)




c             calculate overlap integral between f and atomic function
c             (integral Rl(r)*Psi_at(r)dr from 0 till r') 
c             intr(i) is that overlap integral. Later it
c             will be multiplied by pr(i)*Psi_at(r') and integrated till
c             r=infinity (ideal case), but actually till rlast.

              do 400 i=1,ilast1
                var(i)=pat(i,im,j)*pr(i,im,j)+qat(i,im,j)*qr(i,im,j)
c             factor of 2 -integration r< r>  -->2 r r'
  400         continue

c             integration by trapezoid method
              
              intr(1,im,j)=var(1)*ri(1)
   
              do 410 i=2,ilast1
                intr(i,im,j)=intr(i-1,im,j)+
     1                       (var(i)+var(i-1))*(ri(i)-ri(i-1))
  410         continue 

cc              old way, no double integration 
c              do 415 i=1,ilast1
c                 intr(i,im,j)=intr(ilast1,im,j)/2.0                
c  415         continue    

              
c----------------


c          find irregular solution
            irr = 1
            pu = ck*alphfs
            factor = pu/(1+sqrt(1+pu**2))
            if (ikap.lt.0) factor = -factor
c           set pu, qu - initial condition for irregular solution at ilast
c           qu=(nlp1*cos(phx)+jlp1*sin(phx))*pu *rmt
c           pu = (nl*cos(phx)+jl*sin(phx)) *rmt
            qu=(nlp1*cos(phx)+jlp1*sin(phx))* factor *rmt 
            pu = (nl*cos(phx)+jl*sin(phx)) *rmt 

            call dfovrg (ncycle, ikap, rmt, ilast1, jri, p2, dx,
     1              ri, vtotc,vvalc, dgcn, dpcn, adgc, adpc,
     1              xnval, pu, qu, pn(1,im,j), qn(1,im,j),
     1              iz, ihole, xion, iunf, irr, ic3)
cc            set N- irregular solution , which is outside
cc            N=(nlp1*cos(ph0)+jlp1*sin(ph0))*factor *rmt * dum1
cc            N = i*R - H*exp(i*ph0)
              temp = exp(coni*phx)
              do i = 1, ilast
                pn(i,im,j) = coni * pr(i,im,j) - temp * pn(i,im,j)
                qn(i,im,j) = coni * qr(i,im,j) - temp * qn(i,im,j)
              enddo

 150      continue

c         combine all constant factors to temp
c         add relativistic correction to normaliz. and factor 2*lll+1
          temp = 2*ck / (1+factor**2) / pi

c         nesvi add irregular solution beyond Rmt          
c           do 1020 i=(jri+1), ilast1
c                xkmi=ri(i)*ck
c                call exjlnl(xkmi,lll,jl,nl)
c                pn(i,im,j)=(nl*cos(phx)+jl*sin(phx))*ri(i)
c                qn(i,im,j)=0.0d0
c1020        continue
     
c          open(unit=2,file='wfunc1.dat',status='unknown')    
c         ic3 = 0, j= ic3+1
          j = 1
c         calculate diagonal radial integrals R(k1,k1) - xrhoce and xrhole
            do 190  i = 1, ilast1
              xpc(i) = pr(i,im,j)*pat(i,im,j)*intr(i,im,j)+ 
     1              qr(i,im,j)*qat(i,im,j)*intr(i,im,j)

c            if (ikap .eq. -3 .and. (dble(em) +12.0/hart)
c     1          .le. 1.0/hart) then
c                write(2,1015) ri(i)/rnrm, dble(pr(i,im,j)),
c     1          pat(i,im,j), dble(intr(i,im,j)),dble(xpc(i))
c 1015           format(f10.6,1x,e10.4,1x,e10.4,1x,e10.4,1x,e10.4)
c             endif

 190        continue
            xirf = lll*2 + 2
            i0=jlast1+1
            call csomm2 (ri, xpc, dx, xirf, rlast, i0)
            xrhole(ikap,ikap) =xirf*temp*exp(coni*(phm(im,j)+phm(im,j)))

c            close(2)
            open(unit=2,file='wfunc.dat',status='unknown')    

c         only central atom contribution needs irregular solution
            do 195  i = 1, ilast1
              xpc(i) = pn(i,im,j)*pat(i,im,j)*intr(i,im,j)+ 
     1              qn(i,im,j)*qat(i,im,j)*intr(i,im,j)
              xpc(i) = xpc(i) - 
     1              coni*(pr(i,im,j)*pat(i,im,j)*intr(i,im,j) + 
     2              qr(i,im,j)*qat(i,im,j)*intr(i,im,j))

c         for test purposes
 
c           do 195  i = 1, ilast1
c              xpc(i) = pn(i,im,j)*pat(i,im,j)*intr(i,im,j)
c            xpc(i) = -1.0*coni*(pr(i,im,j)*pat(i,im,j)*intr(i,im,j))
           
             if (ikap .eq. 1 .and. (dble(em) +12.0/hart)
     1          .lt. 1.0/hart) then
                write(2,1016) ri(i)/rnrm, dble(pr(i,im,j)),
     1          pat(i,im,j), dble(intr(i,im,j)),-dimag(xpc(i))
 1016           format(f10.4,1x,e10.4,1x,e10.4,1x,e10.4,1x,e10.4)
             endif

 195        continue

            close(2)

            xirf =  1
            call csomm2 (ri, xpc, dx, xirf, rlast, i0)
            xrhoce(ikap,ikap) = - xirf * temp

c         calculate cross terms
          if (ikap.lt.-1) then
            k1 = ikap + 2*lll + 1
            do 290  i = 1, ilast1
              xpc(i) = pr(i,1,j)*pat(i,1,j)*intr(i,2,j) +
     1                 qr(i,1,j)*qat(i,1,j)*intr(i,2,j) 
 290        continue
            xirf = lll*2 + 2
c           i0 should be less or equal to  ilast
            i0=jlast1+1
            call csomm2 (ri, xpc, dx, xirf, rlast, i0)
c            xrhole (ikap, k1) = xirf*temp* exp(coni*(phm(1,j)+phm(2,j)))
c             xrhoce(ikap,k1)=0.0d0           
             xrhole (k1, ikap) = xrhole (ikap, k1)
c            nesvi: checked that cross-terms are not important for N_h 
            
c           ic3 = 1, j= ic3+1
            j = 2
            xpm =  exp(coni*(phm(1,j)-phm(2,j))) / 2
            xmp =  exp(coni*(phm(2,j)-phm(1,j))) / 2
            do 295  i = 1, ilast1
              xpc(i) = (pn(i,1,j)*pat(i,1,j)*intr(i,2,j)+ 
     1                  qn(i,1,j)*qat(i,1,j)*intr(i,2,j)) * xmp +
     2                 (pn(i,2,j)*pat(i,2,j)*intr(i,1,j)+ 
     3                  qn(i,2,j)*qat(i,2,j)*intr(i,1,j)) * xpm
              xpc(i) = xpc(i) - coni*(xpm+xmp) *
     1                 (pr(i,1,j)*pat(i,1,j)*intr(i,2,j) +
     2                  qr(i,1,j)*qat(i,1,j)*intr(i,2,j))
 295        continue
            xirf =  1
            call csomm2 (ri, xpc, dx, xirf, rlast, i0)
            xrhoce(ikap,k1) = - xirf * temp
c        cross term not important for N_h
c            xrhoce(ikap,k1)=0.0d0
            xrhoce(k1,ikap) =  xrhoce(ikap,k1)
          endif
 199    continue 
 200  continue 


           
          if ((dble(em) +12.0/hart) .lt. 1.0/hart) then
          open(unit=4,file='xrhocet.dat',status='unknown')  
          do 1195  i=-4,3
              do 1195 j=-4,3
                write(4,1018) i,j,dimag(xrhoce(i,j))
 1018           format(i3,1x,i3,1x,f10.4)
 1195        continue
          close(4)
          endif
         



c     calculate phase shift in old way (ic3=1) test new one
c     which is commented out above later
      do 300 lll = 1,lmax
          im = 1
          ikap = -lll-1
          irr = -1
          ic3 = 1
          call dfovrg ( ncycle, ikap, rmt, ilast1, jri, p2, dx,
     $                ri, vtotc, vvalc, dgcn, dpcn, adgc, adpc,
     $                xnval, pu, qu, pr(1,im,1), qr(1,im,1),
     $                iz, ihole, xion, iunf, irr, ic3)
            
          call exjlnl (xkmt, lll, jl, nl)
          call exjlnl (xkmt, lll+1, jlp1, nlp1)
          call phamp (rmt, pu, qu, ck,  jl, nl, jlp1, nlp1, ikap,
     1                  phx, temp)
          ph(1+lll)=phx
 300  continue

      return
      end
      subroutine getedg (ihole, iz, emu)
      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c Insert corrected edges from G.P. Williams' and W.T. Elam's tables.
c 17/10/2002 G. Rivas
      parameter (bohr = 0.529 177 249d0, ryd  = 13.605 698d0)
      parameter (hart = 2 * ryd)
                                                                                
      dimension exmu(1:100,1:29)
                                                                                
c edge energies for each element for z = 1, 98
c some values taken from W.T.Elam's table:
c Li L1, Be to C L1-3, N & O L2-3, F L1-3, Mg to Cl M1-3,
c Ti to Cu M4-5, Zn N2-3, Ga to Br N1-3, Rh to Ag N4-5,
c Sb to I O1-3, Ce N5, Pm M1 N1 N6-7 O1-3, Eu N6-7, Gd N4,
c Er N6, Tm N6, Au O4-5, Pb to At P1-3, Rn P2-3, Ac P1-3
c Pa P1-3, and all values up to from z=92 to z=98
      data (exmu( 1,i),i=1,29)  /13.6,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 2,i),i=1,29)  /24.6,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 3,i),i=1,29)  /54.7,5.3,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 4,i),i=1,29)  /111.5,8.0,3.0,3.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 5,i),i=1,29)  /188.0,12.6,4.7,4.7,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 6,i),i=1,29)  /284.2,18.0,7.2,7.2,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 7,i),i=1,29)  /409.9,37.3,17.5,17.5,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu( 8,i),i=1,29)  /543.1,41.6,18.2,18.2,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
                                                                                
c     To test a problem with sum rules for F absorber in LiF, I
c     have put the Flourine edge energies back to Feff default.
c     MPP 8/7/03. Set back 10/16/03 MPP.
      data (exmu( 9,i),i=1,29)  /696.7,45.0,19.9,19.9,
c      data (exmu( 9,i),i=1,29)  /-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(10,i),i=1,29)  /870.2,48.5,21.7,21.6,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(11,i),i=1,29)  /1070.8,63.5,30.65,30.81,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(12,i),i=1,29)  /1303.0,88.7,49.78,49.5,
     1                           2.0,1.0,1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(13,i),i=1,29)  /1559.6,117.8,72.95,72.55,
     1                           4.0,2.0,2.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(14,i),i=1,29)  /1839.0,149.7,99.82,99.42,
     1                           8.0,2.0,2.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(15,i),i=1,29)  /2145.5,189.0,136.0,135.0,
     1                           12.0,7.0,6.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(16,i),i=1,29)  /2472.0,230.9,163.6,162.5,
     1                           14.0,8.0,7.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(17,i),i=1,29)  /2822.4,270.0,202.0,200.0,
     1                           18.0,10.0,10.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(18,i),i=1,29)  /3205.9,326.3,250.6,248.4,
     1                           29.3,15.9,15.7,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(19,i),i=1,29)  /3608.4,378.6,297.3,294.6,
     1                           34.8,18.3,18.3,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(20,i),i=1,29)  /4038.5,438.4,349.7,346.2,
     1                           44.3,25.4,25.4,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(21,i),i=1,29)  /4492.0,498.0,403.6,398.7,
     1                           51.1,28.3,28.3,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(22,i),i=1,29)  /4966.0,560.9,460.2,453.8,
     1                           58.7,32.6,32.6,2.0,2.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(23,i),i=1,29)  /5465.0,626.7,519.8,512.1,
     1                           66.3,37.2,37.2,2.0,2.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(24,i),i=1,29)  /5989.0,696.0,583.8,574.1,
     1                           74.1,42.2,42.2,2.0,2.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(25,i),i=1,29)  /6539.0,769.1,649.9,638.7,
     1                           82.3,47.2,47.2,2.0,2.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(26,i),i=1,29)  /7112.0,844.6,719.9,706.8,
     1                           91.3,52.7,52.7,2.0,2.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(27,i),i=1,29)  /7709.0,925.1,793.2,778.1,
     1                           101.0,58.9,59.9,3.0,3.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(28,i),i=1,29)  /8333.0,1008.6,870.0,852.7,
     1                           110.8,68.0,66.2,4.0,4.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(29,i),i=1,29)  /8979.0,1096.7,952.3,932.7,
     1                           122.5,77.3,75.1,5.0,5.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(30,i),i=1,29)  /9659.0,1196.2,1044.9,1021.8,
     1                          139.8,91.4,88.6,10.2,10.1,
     1                          -1.0,1.0,1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(31,i),i=1,29)  /10367.0,1299.0,1143.2,1116.4,
     1                           159.5,103.5,100.0,18.7,18.7,
     1                           1.0,2.0,2.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(32,i),i=1,29)  /11103.0,1414.6,1248.1,1217.0,
     1                           180.1,124.9,120.8,29.8,29.2,
     1                           5.0,3.0,3.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(33,i),i=1,29)  /11867.0,1527.0,1359.1,1323.6,
     1                           204.7,146.2,141.2,41.7,41.7,
     1                           8.0,3.0,3.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(34,i),i=1,29)  /12658.0,1652.0,1474.3,1433.9,
     1                           229.6,166.5,160.7,55.5,54.6,
     1                           12.0,3.0,3.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(35,i),i=1,29)  /13474.0,1782.0,1596.0,1550.0,
     1                           257.0,189.0,182.0,70.0,69.0,
     1                           27.0,3.0,3.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(36,i),i=1,29)  /14326.0,1921.0,1730.9,1678.4,
     1                           292.8,222.2,214.4,95.0,93.8,
     1                           27.5,14.1,14.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(37,i),i=1,29)  /15200.0,2065.0,1864.0,1804.0,
     1                           326.7,248.7,239.1,113.0,112.0,
     1                           30.5,16.3,15.3,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(38,i),i=1,29)  /16105.0,2216.0,2007.0,1940.0,
     1                           358.7,280.3,270.0,136.0,134.2,
     1                           38.9,21.3,20.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(39,i),i=1,29)  /17038.0,2373.0,2156.0,2080.0,
     1                           392.0,310.6,298.8,157.7,155.8,
     1                           43.8,24.4,23.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(40,i),i=1,29)  /17998.0,2532.0,2307.0,2223.0,
     1                           430.3,343.5,329.8,181.1,178.8,
     1                           50.6,28.5,27.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(41,i),i=1,29)  /18986.0,2698.0,2465.0,2371.0,
     1                           466.6,376.1,360.6,205.0,202.3,
     1                           56.4,32.6,30.8,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(42,i),i=1,29)  /20000.0,2866.0,2625.0,2520.0,
     1                           506.3,411.6,394.0,231.1,227.9,
     1                           63.2,37.6,35.5,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(43,i),i=1,29)  /21044.0,3043.0,2793.0,2677.0,
     1                           544.0,447.6,417.7,257.6,253.9,
     1                           69.5,42.3,39.9,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(44,i),i=1,29)  /22117.0,3224.0,2967.0,2838.0,
     1                           586.1,483.5,461.4,284.2,280.0,
     1                           75.0,46.3,43.2,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(45,i),i=1,29)  /23220.0,3412.0,3146.0,3004.0,
     1                           628.1,521.3,496.5,311.9,307.2,
     1                           81.4,50.5,47.3,2.0,2.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(46,i),i=1,29)  /24350.0,3604.0,3330.0,3173.0,
     1                           671.6,559.9,532.3,340.5,335.2,
     1                           87.1,55.7,50.9,2.0,2.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(47,i),i=1,29)  /25514.0,3806.0,3524.0,3351.0,
     1                           719.0,603.8,573.0,374.0,368.3,
     1                           97.0,63.7,58.3,4.0,4.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(48,i),i=1,29)  /26711.0,4018.0,3727.0,3538.0,
     1                           772.0,652.6,618.4,411.9,405.2,
     1                           109.8,63.9,63.9,11.7,10.7,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(49,i),i=1,29)  /27940.0,4238.0,3938.0,3730.0,
     1                           827.2,703.2,665.3,451.4,443.9,
     1                           122.9,73.5,73.5,17.7,16.9,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(50,i),i=1,29)  /29200.0,4465.0,4156.0,3929.0,
     1                           884.7,756.5,714.6,493.2,484.9,
     1                           137.1,83.6,83.6,24.9,23.9,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(51,i),i=1,29)  /30491.0,4698.0,4380.0,4132.0,
     1                           946.0,812.7,766.4,537.5,528.2,
     1                           153.2,95.6,95.6,33.3,32.1,-1.0,-1.0,
     1                           7.0,2.0,2.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(52,i),i=1,29)  /31814.0,4939.0,4612.0,4341.0,
     1                           1006.0,870.8,820.0,583.4,573.0,
     1                           169.4,103.3,103.3,41.9,40.4,-1.0,-1.0,
     1                           12.0,2.0,2.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(53,i),i=1,29)  /33169.0,5188.0,4852.0,4557.0,
     1                           1072.0,931.0,875.0,630.8,619.3,
     1                           186.0,123.0,123.0,50.6,48.9,-1.0,-1.0,
     1                           14.0,2.0,2.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(54,i),i=1,29)  /34561.0,5453.0,5107.0,4786.0,
     1                           1148.7,1002.1,940.6,689.0,676.4,
     1                           213.2,146.7,145.5,69.5,67.5,-1.0,-1.0,
     1                           23.3,13.4,12.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(55,i),i=1,29)  /35985.0,5714.0,5359.0,5012.0,
     1                           1211.0,1071.0,1003.0,740.5,726.6,
     1                           232.3,172.4,161.3,79.8,77.5,-1.0,-1.0,
     1                           22.7,14.2,12.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(56,i),i=1,29)  /37441.0,5989.0,5624.0,5247.0,
     1                           1293.0,1137.0,1063.0,795.7,780.5,
     1                           253.5,192.0,178.6,92.6,89.9,-1.0,-1.0,
     1                           30.3,17.0,14.8,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(57,i),i=1,29)  /38925.0,6266.0,5891.0,5483.0,
     1                           1362.0,1209.0,1128.0,853.0,836.0,
     1                          274.7,205.8,196.0,105.3,102.5,-1.0,-1.0,
     1                           34.3,19.3,16.8,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(58,i),i=1,29)  /40443.0,6549.0,6164.0,5723.0,
     1                           1436.0,1274.0,1187.0,902.4,883.8,
     1                           291.0,223.2,206.5,109.0,109.0,0.1,0.1,
     1                           37.8,19.8,17.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(59,i),i=1,29)  /41991.0,6835.0,6440.0,5964.0,
     1                           1511.0,1337.0,1242.0,948.3,928.8,
     1                           304.5,236.3,217.6,115.1,115.1,2.0,2.0,
     1                           37.4,22.3,22.3,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(60,i),i=1,29)  /43569.0,7126.0,6722.0,6208.0,
     1                           1575.0,1403.0,1297.0,1003.3,980.4,
     1                           319.2,243.3,224.6,120.5,120.5,1.5,1.5,
     1                           37.5,21.1,21.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(61,i),i=1,29)  /45184.0,7428.0,7013.0,6459.0,
     1                           1650.0,1471.0,1357.0,1052.0,1027.0,
     1                           331.0,242.0,242.0,120.0,120.0,4.0,4.0,
     1                           38.0,22.0,22.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(62,i),i=1,29)  /46834.0,7737.0,7312.0,6716.0,
     1                           1723.0,1541.0,1420.0,1110.9,1083.4,
     1                           347.2,265.6,247.4,129.0,129.0,5.2,5.2,
     1                           37.4,21.3,21.3,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(63,i),i=1,29)  /48519.0,8052.0,7617.0,6977.0,
     1                           1800.0,1614.0,1481.0,1158.6,1127.5,
     1                           360.0,284.0,257.0,133.0,127.7,6.0,6.0,
     1                           32.0,22.0,22.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(64,i),i=1,29)  /50239.0,8376.0,7930.0,7243.0,
     1                           1881.0,1688.0,1544.0,1221.9,1189.6,
     1                           378.6,286.0,271.0,142.6,142.6,8.6,8.6,
     1                           36.0,28.0,21.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(65,i),i=1,29)  /51996.0,8708.0,8252.0,7514.0,
     1                           1968.0,1768.0,1611.0,1276.9,1241.1,
     1                           396.0,322.4,284.1,150.5,150.5,7.7,2.4,
     1                           45.6,28.7,22.6,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(66,i),i=1,29)  /53789.0,9046.0,8581.0,7790.0,
     1                           2047.0,1842.0,1676.0,1333.0,1292.6,
     1                           414.2,333.5,293.2,153.6,153.6,8.0,4.3,
     1                           49.9,26.3,26.3,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(67,i),i=1,29)  /55618.0,9394.0,8918.0,8071.0,
     1                           2128.0,1923.0,1741.0,1392.0,1351.0,
     1                           432.4,343.5,308.2,160.0,160.0,8.6,5.2,
     1                           49.3,30.8,24.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(68,i),i=1,29)  /57486.0,9751.0,9264.0,8358.0,
     1                           2207.0,2006.0,1812.0,1453.0,1409.0,
     1                           449.8,366.2,320.2,167.6,167.6,4.7,4.7,
     1                           50.6,31.4,24.7,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(69,i),i=1,29)  /59390.0,10116.0,9617.0,8648.0,
     1                           2307.0,2090.0,1885.0,1515.0,1468.0,
     1                           470.9,385.9,332.6,175.5,175.5,4.6,4.6,
     1                           54.7,31.8,25.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(70,i),i=1,29)  /61332.0,10486.0,9978.0,8944.0,
     1                           2398.0,2173.0,1950.0,1576.0,1528.0,
     1                           480.5,388.7,339.7,191.2,182.4,2.5,1.3,
     1                           52.0,30.3,24.1,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(71,i),i=1,29)  /63314.0,10870.0,10349.0,9244.0,
     1                           2491.0,2264.0,2024.0,1639.0,1589.0,
     1                           506.8,412.4,359.2,206.1,196.3,8.9,7.5,
     1                           57.3,33.6,26.7,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(72,i),i=1,29)  /65351.0,11271.0,10739.0,9561.0,
     1                           2601.0,2365.0,2108.0,1716.0,1662.0,
     1                          538.0,438.2,380.7,220.0,211.5,15.9,14.2,
     1                           64.2,38,29.9,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(73,i),i=1,29)  /67416.0,11682.0,11136.0,9881.0,
     1                           2708.0,2469.0,2194.0,1793.0,1735.0,
     1                          563.4,463.4,400.9,237.9,226.4,23.5,21.6,
     1                           69.7,42.2,32.7,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(74,i),i=1,29)  /69525.0,12100.0,11544.0,10207.0,
     1                           2820.0,2575.0,2281.0,1872.0,1809.0,
     1                          594.1,490.4,423.6,255.9,243.5,33.6,31.4,
     1                           75.6,45.3,36.8,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(75,i),i=1,29)  /71676.0,12527.0,11959.0,10535.0,
     1                           2932.0,2682.0,2367.0,1949.0,1883.0,
     1                          625.4,518.7,446.8,273.9,260.5,42.9,40.5,
     1                           83.0,45.6,34.6,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                
      data (exmu(76,i),i=1,29) /73871.0,12968.0,12385.0,10871.0,
     1                          3049.0,2792.0,2457.0,2031.0,1960.0,
     1                          658.2,549.1,470.7,293.1,278.5,53.4,50.7,
     1                          84.0,58.0,44.5,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0/
                                                                                
      data (exmu(77,i),i=1,29) /76111.0,13419.0,12824.0,11215.0,
     1                          3174.0,2909.0,2551.0,2116.0,2040.0,
     1                          691.1,577.8,495.8,311.9,296.3,63.8,60.8,
     1                          95.2,63.0,48.0,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0/
                                                                                
      data (exmu(78,i),i=1,29) /78395.0,13880.0,13273.0,11564.0,
     1                          3296.0,3027.0,2645.0,2202.0,2122.0,
     1                          725.4,609.1,519.4,331.6,314.6,74.5,71.2,
     1                          101.7,65.3,51.7,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0/
                                                                                
      data (exmu(79,i),i=1,29) /80725.0,14353.0,13734.0,11919.0,
     1                          3425.0,3148.0,2743.0,2291.0,2206.0,
     1                          762.1,642.7,546.3,353.2,335.1,87.6,84.0,
     1                          107.2,74.2,57.2,5.0,5.0,-1.0,-1.0,
     1                         -1.0,-1.0,-1.0,-1.0,-1.0,
     1                         -1.0/
                                                                                
      data (exmu(80,i),i=1,29)/83102.0,14839.0,14209.0,12284.0,
     1                         3562.0,3279.0,2847.0,2385.0,2295.0,
     1                         802.2,680.2,576.6,378.2,358.8,104.0,99.9,
     1                         127.0,83.1,64.5,9.6,7.8,-1.0,-1.0,
     1                        -1.0,-1.0,-1.0,-1.0,-1.0,
     1                        -1.0/
                                                                                
      data (exmu(81,i),i=1,29)/85530.0,15347.0,14698.0,12658.0,
     1                        3704.0,3416.0,2957.0,2485.0,2389.0,
     1                        846.2,720.5,609.5,405.7,385.0,122.2,117.8,
     1                        136.0,94.6,73.5,14.7,12.5,-1.0,-1.0,
     1                       -1.0,-1.0,-1.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(82,i),i=1,29)/88005.0,15861.0,15200.0,13035.0,
     1                        3851.0,3554.0,3066.0,2586.0,2484.0,
     1                        891.8,761.9,643.5,434.3,412.2,141.7,136.9,
     1                        147.0,106.4,83.3,20.7,18.1,-1.0,-1.0,
     1                        3.0,1.0,1.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(83,i),i=1,29)/90526.0,16388.0,15711.0,13419.0,
     1                        3999.0,3696.0,3177.0,2688.0,2580.0,
     1                        939.0,805.2,678.8,464.0,440.1,162.3,157.0,
     1                        159.3,119.0,92.6,26.9,23.8,-1.0,-1.0,
     1                        8.0,3.0,3.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(84,i),i=1,29)/93105.0,16939.0,16244.0,13814.0,
     1                        4149.0,3854.0,3302.0,2798.0,2683.0,
     1                        995.0,851.0,705.0,500.0,473.0,184.0,184.0,
     1                        177.0,132.0,104.0,31.0,31.0,-1.0,-1.0,
     1                        9.0,4.0,1.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(85,i),i=1,29)/95730.0,17493.0,16785.0,14214.0,
     1                       4317.0,4008.0,3426.0,2909.0,2787.0,
     1                       1042.0,886.0,740.0,533.0,507.0,210.0,210.0,
     1                       195.0,148.0,115.0,40.0,40.0,-1.0,-1.0,
     1                       13.0,6.0,1.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(86,i),i=1,29)/98404.0,18049.0,17337.0,14619.0,
     1                       4482.0,4159.0,3538.0,3022.0,2892.0,
     1                       1097.0,929.0,768.0,567.0,541.0,238.0,238.0,
     1                       214.0,164.0,127.0,48.0,48.0,-1.0,-1.0,
     1                       26.0,8.0,2.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(87,i),i=1,29)/101137.0,18639.0,17907.0,15031.0,
     1                       4652.0,4327.0,3663.0,3136.0,3000.0,
     1                       1153.0,980.0,810.0,603.0,577.0,268.0,268.0,
     1                       234.0,182.0,140.0,58.0,58.0,-1.0,-1.0,
     1                       34.0,15.0,15.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(88,i),i=1,29)/103922.0,19237.0,18484.0,15444.0,
     1                       4822.0,4490.0,3792.0,3248.0,3105.0,
     1                      1208.0,1058.0,879.0,636.0,603.0,299.0,299.0,
     1                       254.0,200.0,153.0,68.0,68.0,-1.0,-1.0,
     1                       44.0,19.0,19.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(89,i),i=1,29)/106755.0,19840.0,19083.0,15871.0,
     1                       5002.0,4656.0,3909.0,3370.0,3219.0,
     1                      1269.0,1080.0,890.0,675.0,639.0,319.0,319.0,
     1                       272.0,215.0,167.0,80.0,80.0,-1.0,-1.0,
     1                       37.0,24.0,15.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(90,i),i=1,29)/109651.0,20472.0,19693.0,16300.0,
     1                       5182.0,4830.0,4046.0,3491.0,3332.0,
     1                      1330.0,1168.0,966.4,712.1,675.2,342.4,333.1,
     1                       290.0,229.0,182.0,92.5,85.4,-1.0,-1.0,
     1                       41.4,24.5,16.6,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(91,i),i=1,29)/112601.0,21105.0,20314.0,16733.0,
     1                       5367.0,5001.0,4174.0,3611.0,3442.0,
     1                     1387.0,1224.0,1007.0,743.0,708.0,371.0,360.0,
     1                       310.0,232.0,232.0,94.0,94.0,-1.0,-1.0,
     1                       43.0,27.0,17.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(92,i),i=1,29)/115606.0,21757.0,20948.0,17166.0,
     1                       5548.0,5182.0,4303.0,3728.0,3552.0,
     1                     1439.0,1271.0,1043.0,778.3,736.2,388.2,377.4,
     1                       321.0,257.0,192.0,102.8,94.2,-1.0,-1.0,
     1                       43.9,26.8,16.8,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(93,i),i=1,29)/118669.0,22427.0,21600.0,17610.0,
     1                       5739.0,5366.0,4435.0,3849.0,3664.0,
     1                     1501.0,1328.0,1085.0,816.0,771.0,414.0,403.0,
     1                       338.0,274.0,206.0,109.0,101.0,-1.0,-1.0,
     1                       47.0,29.0,18.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(94,i),i=1,29)/121791.0,23104.0,22266.0,18057.0,
     1                       5933.0,5547.0,4563.0,3970.0,3775.0,
     1                     1559.0,1380.0,1123.0,846.0,798.0,436.0,424.0,
     1                       350.0,283.0,213.0,113.0,102.0,-1.0,-1.0,
     1                       46.0,29.0,16.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(95,i),i=1,29)/124982.0,23808.0,22952.0,18510.0,
     1                       6133.0,5739.0,4698.0,4096.0,3890.0,
     1                     1620.0,1438.0,1165.0,880.0,829.0,461.0,446.0,
     1                       365.0,298.0,219.0,116.0,106.0,-1.0,-1.0,
     1                       48.0,29.0,16.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(96,i),i=1,29)/128241.0,24526.0,23651.0,18970.0,
     1                       6337.0,5937.0,4838.0,4224.0,4009.0,
     1                     1684.0,1498.0,1207.0,916.0,862.0,484.0,470.0,
     1                       383.0,313.0,229.0,124.0,110.0,-1.0,-1.0,
     1                        50.0,30.0,16.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(97,i),i=1,29)/131556.0,25256.0,24371.0,19435.0,
     1                       6545.0,6138.0,4976.0,4353.0,4127.0,
     1                     1748.0,1558.0,1249.0,955.0,898.0,511.0,495.0,
     1                       399.0,326.0,237.0,130.0,117.0,-1.0,-1.0,
     1                       52.0,32.0,16.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(98,i),i=1,29)/134939.0,26010.0,25108.0,19907.0,
     1                       6761.0,6345.0,5116.0,4484.0,4247.0,
     1                     1813.0,1620.0,1292.0,991.0,930.0,538.0,520.0,
     1                       416.0,341.0,245.0,137.0,122.0,-1.0,-1.0,
     1                       54.0,33.0,17.0,-1.0,-1.0,
     1                      -1.0/
                                                                                
      data (exmu(99,i),i=1,29)/-1.0,-1.0,-1.0,-1.0,
     1                       -1.0,-1.0,-1.0,-1.0,-1.0,
     1                       -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                       -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                       -1.0,-1.0,-1.0,-1.0,-1.0,
     1                       -1.0/
                                                                                
      data (exmu(100,i),i=1,29) /-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0,-1.0,-1.0,-1.0,-1.0,
     1                          -1.0/
                                                                                

      if(exmu(iz,ihole).gt.0.) emu = exmu(iz,ihole) / hart

      return
      end
      SUBROUTINE RdGrid(em,ne,nGrid,iGridType,GridMin,GridMax,GridStep,
     &     nGridMax,nex)
!     Read data from grid.inp.
!     file should have lines with the following format:
!     
!     Grid_Type    GridMin    GridMax    GridStep
!     
!     Grid_Type can be any of the following (case insensitive):
!     egrid    - (regular in energy)
!     kgrid    - (regular in k)
!     expgrid  - (exponential in energy)
!     usergrid - (read a grid from the file)
!
!     Energy, and k are given relative to the edge.
!     For egrid and expgrid, GridMin, GridMax, and GridStep are
!     given in (eV).
!     For kgrid, units are inverse angstroms.
!     usergrid is a special case and is followed by one energy
!     point per line, i.e.
!            usergrid
!            -1.01
!            -0.55
!            10.01
!              .!              .
!              .
!
!     More than one grid may be specified, and grids can
!     overlap, for example:
!
!     egrid -10 10 0.1
!     kgrid  0  15 0.5
!
!     will make overlapping grids going from E = -10 eV to
!     k = 15 Angstrom**(-1). Up to 10 different grids can be
!     defined.
!     If the 'last' keyword is used in the GridMin field, i.e.
!        expgrid  last  100
!     the specified grid will start where the last grid ended.
!     This is usefull when defining non-overlapping k/e grids.
!     Comments lines have #,!,c, or * at the beginning.
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
!     Input:
!     nGridMax - max number of grids that can be defined.
!     nex      - max number of energy points
      INTEGER nGridMax, nex

!     Output:
!     nGrid     - number of grids defined in file
!     iGridType - Type of grid. (0 = user, 1 = energy, 2 = k, 3 = exponential)
!     GridMin   - Minimum value of grid.
!     GridMax   - Maximum value of grid.
!     GridStep  - Step size.
!     ne        - number of energy points
!     em(nex)        - energy grid
      INTEGER nGrid, iGridType(nGridMax), ne
      DOUBLE PRECISION GridMin(nGridMax), GridMax(nGridMax),
     &     GridStep(nGridMax)
      COMPLEX*16 em(nex)

!     Local Variables:
!     ios      - i/o error flag
!     iUGrid   - unit number for grid.inp
!     RealE    - real part of energy
!     ImagE    - imaginary part of energy
!     nWords   - number of words in the line
!     Words(4) - array of words
!     line     - string to hold line
!     ieMin    - index of minimum of user defined grid
!     ieMax    - index of max of user defined frid
      INTEGER ios, iUGrid, nWords, ieMin, ieMax
      DOUBLE PRECISION RealE, ImagE
      CHARACTER(20) Words(10)
      CHARACTER(100) line

!     Loop Variables:
      INTEGER i1, i2

!     Externals
      LOGICAL isnum
      EXTERNAL isnum

      iUGrid = 22
      OPEN(unit=iUGrid,file='grid.inp',status='old',iostat=ios)
      CALL CHOPEN(ios, 'grid.inp', 'xsph')
      
      DO nGrid = 1, nGridMax
!        Read comment lines
         CALL rdcmt(iUGrid,'#!*C')
!        Read data line into string variable "line" and change to
!        lowercase.
         READ(iUGrid,'(A)',END=5) line
c         CALL lower(line)
!        bwords breaks line into words which are then passed
!        back in Words array
         nWords = 4
         CALL untab(line)
         CALL bwords(line,nWords,Words)

!        Set iGridType
         IF(Words(1).eq.'usergrid') THEN
            iGridType(nGrid) = 0
         ELSEIF(Words(1).eq.'egrid') THEN
            iGridType(nGrid) = 1
c            IF(nwords.ne.4) CALL GridError('Error in grid.inp', line)
         ELSEIF(Words(1).eq.'kgrid') THEN
            iGridType(nGrid) = 2
         ELSEIF(Words(1).eq.'expgrid') THEN
            iGridType(nGrid) = 3
         END IF
         
         IF(iGridType(nGrid).ne.0) THEN
            IF(Words(2).eq.'last') THEN
               ! Set the grid minimum to the max of the last grid.
               IF(nGrid.gt.1) THEN
                  CALL SetGridMin(GridMin,GridMax,GridStep,iGridType,
     &                 nGrid)
               ELSE
                  GridMin(1) = 0.d0
               END IF
            ELSE
               READ(Words(2),*) GridMin(nGrid)
            END IF
            READ(Words(3),*) GridMax(nGrid)
            READ(Words(4),*) GridStep(nGrid)
         END IF

         IF(iGridType(nGrid).eq.0) THEN
!        User defined points: read from file.
            DO i2 = 1, nex
               ! Read comments
               CALL rdcmt(iUGrid,'#!*C')
               ! Read line
               READ(iUGrid,'(A)',END=5) line
               nwords = 2
               ! break line into words
               CALL untab(line)
               CALL bwords(line,nWords,Words)
               ! if first word is number, Real(em) = num
               IF(isnum(Words(1))) THEN
                  READ(Words(1),*) RealE
                  ! if second word exists and is a num, Im(em) = num
                  IF((nWords.ge.2).and.isnum(Words(2)))
     &                 READ(Words(2),*) ImagE                  
                  em(i2) = (RealE + coni*ImagE)
                  ne = ne + 1
               ! If first word is not a number, exit loop and read line again.   
               ELSE
                  ! Set GridMax and GridMin for reference
                  GridMin(nGrid) = DBLE(em(ne - i2 + 1))
                  GridMax(nGrid) = DBLE(em(ne))

                  BACKSPACE(iUGrid)
                  EXIT
               END IF
            END DO
         END IF
      END DO
 5    CONTINUE
      nGrid = nGrid - 1

      DO i1 = 1, nGrid
         IF(iGridType(i1).eq.2) THEN
!     k-Grid. Set units to bohr**(-1)
            GridMin(i1) = GridMin(i1)*bohr
            GridMax(i1) = GridMax(i1)*bohr
            GridStep(i1) = GridStep(i1)*bohr
         ELSE
!     e-grid. Set units to hartrees
            GridMin(i1) = GridMin(i1)/hart
            GridMax(i1) = GridMax(i1)/hart
            GridStep(i1) = GridStep(i1)/hart
         END IF
      END DO
      DO i1 = 1, ne
         em(i1) = em(i1)/hart
      END DO

      CLOSE(iUGrid)
      RETURN
      END

      SUBROUTINE SetGridMin(GridMin, GridMax, GridStep, iGridType,
     &     nGrid)
!     This sets the minimum of the current grid to the maximum of the last grid + GridStep
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
!     Input:
!     GridMin   - array that holds grid minima
!     GridMax   - array that holds grid maxima
!     GridStep  - array of steps
!     iGridType - array of grid types
!     nGrid     - current grid
      INTEGER nGrid
      INTEGER iGridType(nGrid)
      DOUBLE PRECISION GridMin(nGrid), GridMax(nGrid), GridStep(nGrid)

!     Output: GridMin(nGrid) (minimum of current grid.

      IF((iGridType(nGrid).ne.2).and.(iGridType(nGrid-1).ne.2).or.
     &    (iGridType(nGrid).eq.iGridType(nGrid-1))) THEN
!     If neither grid is a k grid, or if both are k-grid, just set the minimum to the previous
!     maximum.
         GridMin(nGrid) = GridMax(nGrid-1) + GridStep(nGrid)
      ELSEIF(iGridType(nGrid).eq.2) THEN
!     If current grid is k, kmin = sqrt(2*emax)
         GridMin(nGrid) =
     &        SQRT(2*GridMax(nGrid-1)/hart)/bohr + GridStep(nGrid)
      ELSE
!     If current grid is e, emin = k**2/2
         GridMin(nGrid) =
     &        (GridMax(nGrid-1)*bohr)**2/2*hart + GridStep(nGrid)
      END IF

      RETURN
      END

      SUBROUTINE GridError(message, line)
      CHARACTER(300) message, line
      
      CALL wlog(message)
      CALL wlog(line)
      STOP

      RETURN
      END
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      subroutine fmsie( iph0, nph, lipotx, ie, em, eref, ph, iz,
     1                 rfms, lfms, nat, iphat, rath, gtr)

c     full multiple scattering code for single energy point
c     written by a.ankudinov 06.1997 using earlier written subroutines
c     coded by b.ravel
c     modified by a.ankudinov 2001 for new matrix inversion algorithms
c     Feb. 2002, a.ankudinov: fixed logic for MPI calculations
c       lfms=0  - extended system calculataions (e.g. crystal)
c       lfms=1  - small system calculations (e.g. molecule)
c       lfms=2  - same as 1 for MPI run (forces call yprep)

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     input
      dimension iphat(natx), rath(3,natx)
      real rat(3,natx), rfms, rdirec, toler1, toler2
      real rpart,aipart
      integer nph
      dimension iz(0:nphx)
      complex*16 ph(lx+1, 0:nphx)

c     work space
      integer iph0
      complex*16 em, eref
      character*512 slog
      logical lcalc
      dimension lcalc(0:lx)
c     fms staff
      integer lipotx(0:nphx)
      complex gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphx)
      complex gtr(0:lx, 0:nphx)
      complex xphase(nspx, -lx:lx, 0:nphx), ck(nspx)
      complex*16 dck
      complex conis
      parameter (conis = (0,1))
      real  temper, thetax, sig2
      save

      if (rfms .le. 0.0) goto 900

c     set default (LU) inv method
      minv = 0
      rdirec = 2*rfms
      toler1 = 0.e0
      toler2 = 0.e0

      do 30 iat=1,nat
      do 30 j=1,3
   30 rat(j,iat) = real (rath(j,iat))

c     transform to single precision
      temper =0.0e0
      thetax =0.0e0
      sig2  = 0.0e0

c      it will be nice to call yprep once for all energy points,
c      fix later, and now call it every time
      if (ie.eq.1 .or. lfms.eq.0 .or. lfms.eq.2) 
     1  call yprep(iph0, nat, inclus, nph, iphat, rfms, rat,
     2     iz, rdirec )

      if (inclus.gt.1) then

cc     call fms for a cluster around central atom
       if (ie.eq.1) then
          write (slog,35) inclus, iph0
  35      format ('        Doing FMS for a cluster of ',i3,
     1    ' atoms around iph = ',i2)
          call wlog (slog)
       endif

       dck=sqrt(2*(em-eref))
       rpart  = dble(dck)
       aipart = real(dimag(dck))
       ck(1) = cmplx(rpart, aipart)
       do 1020 ipp = 0,nph
         do 1010 ill = -lipotx(ipp), lipotx(ipp)
           rpart  = dble( ph( 1+abs(ill), ipp))
           aipart = dimag(ph( 1+abs(ill), ipp)) 
           xphase(1, ill, ipp) = cmplx(rpart, aipart)
 1010    continue
 1020  continue
       iverb=0
       if (ie.eq.1) iverb = 1
       nsp = 1
       ispin = 0
       do 1011 ill = 0,lx
 1011  lcalc(ill) = .true.
       call fms(lfms, nsp, ispin, inclus, nph, ck, lipotx, xphase, ie,
     1  iverb, minv, rdirec, toler1, toler2, lcalc, gg)

c      make ck= i, since coni is c*16
       do 1030 ip=0,nph
         if (lfms.ne.0 .or. ip.eq.iph0) then
           do 1040 il=0,lipotx(ip)
             ix = il**2
             do 1050 im=1,2*il+1
               gtr(il, ip) = gtr(il, ip) + gg(ix+im,ix+im,ip)
 1050        continue
             gtr(il,ip)= gtr(il,ip)*
     1            exp(2*conis*xphase(1,il,ip))/(2*il+1)
 1040      continue
         endif
 1030  continue
      endif

 900  continue
      return
      end
      subroutine fms(lfms, nsp, ispin, inclus, npot, ck, lipotx, xphase,
     1   ik, iverb, minv, rdirec, toler1, toler2, lcalc, gg)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c--------------------------------------------------------------------
c  compute full multiple scattering within some cluster at some
c  energy 
c  This uses the LU decomposition package from LAPACK.  Driver
c  routines: cgetrf (decomposition), cgetrs (backsubstitution)
c  coded by b.ravel
c  modified by a.l.ankudinov to include spin and SO interactions
c  feb 2000
c
c  dim.h and xparam.h must be included in the calling routine
c
c  most of the information needed by this package is set into common
c  blocks the companion package xprep.  In that package, the lists of
c  atomic coordinates and potential indeces are organized so that the
c  first npot+1 entries are examples of each of the unique potentials.
c  Consequently, only the upper left hand corner of the FMS matrix
c  need be recomposed to get the set of submatrices necessary to
c  compute chi for each type of atom in the cluster.
c
c  See subroutine fmstot.f for an example of decoding the output of this
c  subroutine. The third index of gg refers to the unique potential with
c  element 0 being the absorbing atom.  
c  The first two indeces are related to the |lms> state by the
c  formula:
c       nsp=1, no spin indeces
c       lm  = ( l**2 + 1 ) + ( l + m )
c            thus {1..(lx+1)^2} ==>
c            {0,0 1,-1 1,0 1,1 2,-2 2,-1 2,0 2,1 2,2 ...
c                   lx,lx-1 lx,lx}
c       nsp=2, with spin indeces
c       lms  = 2*( l**2 + 1 ) + 2*( l + m ) + (s-1/2)
c            thus {1...2*(lx+1)^2} ==>
c            {0, 0,-1/2  0. 0,1/2
c             1,-1,-1/2  1,-1,1/2  1,0,-1/2  1,0,1/2  1,1,-1/2 1,1,1/2
c             2,-2,-1/2  2,-2,1/2  2,-1,-1/2 2,-1,1/2 ...    lx,lx,1/2}
c
c  The calling protocol for xpreppack and fmspack is;
c          include 'dim.h'
c          include 'xparam.h'
c          ...
c          call xprep(nat, inclus, npot, iphat, rmax, rat,
c     $            xnrm, izx, temper, thetad)
c          energy loop {
c             ...
c             call fms(nsp, inclus, npot, ck, lipotx, xphase,
c                      ik, iverb, gg)
c             ... }
c
c  fmspack contains the following routines:
c    fms.f:     main routine of fmspack
c    kets.f:    compute all state kets for current energy
c    xclmz.f:   compute hankle-like polynomials for current energy
c    xgllm.f:   compute z-axis propagators for current energy
c    cgetrf.f:  LU decomposition of matrix
c    cgetrs.f:  backsubstitution of LU decomposed matrix
c    lu_misc.f: various routines called by LU package
c
c---------------------------------------------------------------------
c  input
c    nsp:    1) no spin indeces 2) with spin indeces
c    inclus: number of atoms in cluster
c    npot:   number of unique potentials in cluster
c    ck:     complex momentum of current energy point
c    lipotx: (0:nphasx) max l for each unique potential
c    xphase: (0:lx, 0:nphasx) single complex array of partial wave
c            phase shifts for each unique potential
c    ik:     current energy grid index, used for run-time messages
c    iverb:  do nothing when iverb <= 0
c            1  => write a message about grid point and matrix size
c
c  passed in common from xprep package (xstruc.h)
c    xrat:   (3,nclusx) array of coordinates with first npot+1
c            elements each a unique potential
c    xphi:   (nclusx, nclusx) angles between z axis and vectors
c            connecting the atoms in the cluster
c    iphx:   (nclusx) potential index of each atom in the cluster
c    drix:   huge matrix containing all rotation matrix elements
c            needed for computation of free electron propagators
c    xnlm:   matrix of legendre polynomial normalization factors
c    xpsile: matrix containing wave functions for hybridization
c            calculation
c    sigsqr: (nclusx,nclusx) matrix of pair-wise mean square
c            displacements about interatomic distances.  Currently only
c            calculated by the correlated debye model.
c
c  output
c    gg:  (nsp*lx**2, nsp*lx**2, 0:nphasx) submatrix spanning the entire
c          angular momentum basis for each unique potential

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c====================================================================
c  This common block contains the structural information about the
c  cluster to be used for the full multiple scattering calculation
c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/
c********************************************************************
c**** save Clebsch-Gordon coefficients: <LS|J>
      dimension t3jp(0:lx, -lx:lx, 2), t3jm(0:lx, -lx:lx, 2)
      common /t3j/ t3jp, t3jm
      save   /t3j/

c********************************************************************
      parameter (pi = 3.14159 26535 89793 23846 26433e0)
      parameter (bohr = 0.529 177 249e0)
      parameter (one = 1, zero = 0)
      complex coni
      parameter (coni = (0,1))
      complex   term, prefac, gllmz, ck(nspx)
      complex   clm(lx+2, 2*lx+3), xclm(0:lx, 0:lx, nclusx, nclusx,nspx)
      complex   xrho( nclusx, nclusx, nspx)
      integer   lipotx(0:nphasx)

c********************************************************************
c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate
      save   /stkets/
      complex   xphase(nspx, -lx:lx, 0:nphasx)
      complex   tmatrx(nspx, istatx)
c     big work matrices
      complex   g0(istatx,istatx), g0t(istatx,istatx)
      logical lcalc
      dimension lcalc(0:lx)
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)

      integer i0(0:nphx)
      character*3  cerr, dec
      character*13 trans
      character*75 messg

 400  format(i4)

      do 10 i=0,nphx
        if (lipotx(i).le.0)  lipotx(i) = lx
        if (lipotx(i).gt.lx) lipotx(i) = lx
        i0(i) = -1
 10   continue
c     initialize gg to zero
      do 20 i = 0, nphasx
        do 18 j = 1, nspx*(lx+1)**2
          do 16 k = 1, nspx*(lx+1)**2
            gg( k, j, i) = cmplx( zero, zero)
 16       continue
 18     continue
 20   continue

      if (lfms.eq.0) then
        ipi = iphx(1)
        ipf = iphx(1)
      else
        ipi = 0
        ipf = npot
      endif
c --- get basis kets; output array 'lrstat' passed through common
      call getkts(nsp, inclus, npot, iphx, lipotx, i0)

c --- sanity check for i0(ip)
      do 30 ip = ipi, ipf
        if (i0(ip) .lt. 0) then
          call wlog (' Cannot find all representative atoms')
          call wlog (' Increase FMS radius and rerun.')
          call par_stop(' In subroutine FMS')
        endif
  30  continue

c --- runtime message if requested
      if (iverb.gt.0 .and. minv.eq.0) then
         dec = 'LUD'
         write(messg, 4010)this_process,dec, ik, istate
 4010    format('  ',i3,'   FMS matrix (', a, ') at point ', i3,
     $               ', number of state kets =', i4)
         call wlog(messg)
      endif

c --- get all c_lm(z) values for this energy, i,j sum over all atom
c     pairs xrho and xclm are symmetric in ij
c+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
c  nota bene, in the code for setting the clmz, the indexing starts
c  at 1 rather than 0.  To my mind, that is confusing, so here I
c  reindex when I copy from clm to xclm.  See the note about this in
c  subroutine xclmz
c+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
      lplus1 = lx+1
      mplus1 = lx+1
      do 140  i=1,inclus
        do 130 j=1,i

c ------- get and store rho for this pair of atoms   bohr units on
c         r and ck
          r   = zero
          do 100 ix=1,3
            r = r + (xrat(ix,i) - xrat(ix,j))**2
 100      continue
          r   = sqrt(r)

          do 125 isp = 1,nsp
             xrho(i,j,isp) = ck(isp) * r
             xrho(j,i,isp) = xrho(i,j,isp)

c ------- store the c_lm(z) for all the rhos at this energy
c            xclm(i,j) = xclm(j,i) by symmetry
             if (i.ne.j) call xclmz(lplus1,mplus1,xrho(i,j,isp),clm)
             do 120 ll = 0,lx
               do 110 mm = 0,lx
                 if (i.eq.j) then
                     xclm(mm,ll,j,i,isp) = cmplx(zero,zero)
                 else
                     xclm(mm,ll,j,i,isp) = clm(ll+1,mm+1)
                     xclm(mm,ll,i,j,isp) = clm(ll+1,mm+1)
                 endif
 110           continue
 120         continue
 125      continue

 130    continue
 140  continue

c --- fill the G0 and T matrices for this energy
      rdir2 = rdirec**2
      do 220 ist1=1,istate
        iat1 = lrstat(1, ist1)
        l1   = lrstat(2, ist1)
        m1   = lrstat(3, ist1)
        isp1 = lrstat(4, ist1)

        do 210 ist2=1,istate
          iat2 = lrstat(1, ist2)
          l2   = lrstat(2, ist2)
          m2   = lrstat(3, ist2)
          isp2 = lrstat(4, ist2)

          rr = (xrat(1,iat1)-xrat(1,iat2))**2 +
     1    (xrat(2,iat1)-xrat(2,iat2))**2 +(xrat(3,iat1)-xrat(3,iat2))**2

c                               equation 9 in Rehr, Albers
c                               <LR| G |L'R'>

          if (iat1.eq.iat2) then
c             same atom: G=0, calculate T-matrix 
              g0(ist1,ist2)     = cmplx(zero,zero)
c             notice that T is tri-diagonal, due to conservation of
c             total momentum.(will be broken by nonspherical potential)
c             --- potential index for this atom
              iph = iphx(iat1)
            if (nsp.eq.1.and.ispin.eq.0) then
              if (ist1.eq.ist2) tmatrx(1, ist1) =
     $                    ( exp(2*coni*xphase(isp1,l1,iph)) - one )
     $                    / (2*coni) 
            else
              if (ist1.eq.ist2) then
c                set spin index for t3jm and t3jp
                 is = isp1
                 if (nsp.eq.1) then
c                  special case
                   is = 1
                   if (ispin.gt.0) is = 2
                 endif

c                diagonal matrix element
                 tmatrx(1, ist1) =
     $                    ( exp(2*coni*xphase(isp1,l1,iph)) - one )
     $                    / (2*coni) * t3jm (l1, m1, is)**2  + 
     $                    ( exp(2*coni*xphase(isp1,-l1,iph)) - one )
     $                    / (2*coni) * t3jp (l1, m1, is)**2 
              elseif (nsp.eq.2.and.l1.eq.l2.and.m1+isp1.eq.m2+isp2) then
c                same orb. mom. and total momentum projections conserved
c                calculate off-diagonal T-matrix element
c                tmatrx(2, ist1) = here only if nspx equal to 2
                 tmatrx(nsp, ist1) =
     $             ( exp(2*coni*xphase(isp1, l1,iph)) - one +
     $               exp(2*coni*xphase(isp2, l1,iph)) - one ) / (4*coni) 
     1             * t3jm (l1, m1, isp1) * t3jm (l1, m2, isp2)  + 
     $             ( exp(2*coni*xphase(isp1,-l1,iph)) - one +
     $               exp(2*coni*xphase(isp2,-l1,iph)) - one ) / (4*coni) 
     1             * t3jp (l1, m1, isp1) * t3jp (l1, m2, isp2)
              endif
            endif
          elseif (isp1.eq.isp2 .and. rr.le.rdir2) then
c           different atoms, same spin: T=0, calculate G
            g0(ist1,ist2) = cmplx(zero,zero)
            do 200 mu=-l1,l1
c             --- third arg in drix: 0==>beta, 1==>-beta
              muabs = abs(mu)
              call xgllm(muabs, ist1, ist2, lrstat,
     1                   xclm(0,0,1,1,isp1), gllmz )
              g0(ist1,ist2) = g0(ist1,ist2) +
     2             drix(mu,m1,l1,1,iat2,iat1) *  gllmz *
     3             drix(m2,mu,l2,0,iat2,iat1)
 200        continue
            prefac = exp(coni*xrho(iat1,iat2,isp1)) /
     $                  xrho(iat1,iat2,isp1)
c           use correlated debye model, sigsqr is in AA^2
            prefac = prefac * exp(-1 * sigsqr(iat1,iat2) *
     $                  ck(isp1)**2 / bohr**2)
            g0(ist1,ist2) = prefac * g0(ist1,ist2)
          else
c           different atoms, different spins:T=G=0
            g0(ist1,ist2) = cmplx(zero,zero)
          endif

c -----   end of loops over states
 210    continue
 220  continue

      if (minv.eq.0) then
         call gglu ( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg)
      elseif (minv.eq.1) then
         dec = 'VdV'
         call ggbi ( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1              toler1, toler2, lcalc, msord)
      elseif (minv.eq.2) then
         dec = 'LLU'
         call ggrm ( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1              toler1, toler2, lcalc, msord)
      elseif (minv.eq.3) then
         dec = 'GMS'
         call gggm ( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1              toler1, toler2, lcalc, msord)
      else
         dec = 'TF'
         call ggtf ( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1              toler1, toler2, lcalc, msord)
      endif
      if (minv.ne.0) then
         write(messg, 410)this_process,dec, ik, istate, msord
 410     format('  ',i3,'. Iterative FMS (', a, ') at point ', i3,
     $               '; matrix size =', i4,'; MS order =',i5)
         call wlog(messg)
      endif

      return
      end
c--------------------------------------------------------------------
      subroutine getkts(nsp, nat, npot, iphx, lipotx, i0)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c--------------------------------------------------------------------
c  construct state kets |iat,l,m> at this energy
c--------------------------------------------------------------------
c  input
c    nat:    number of atoms in cluster
c    npot:   number of unique potentials
c    iphx:   (nclusx) potential index of each atom in the cluster
c    lipotx: (nphasx) maximum angular momentum to consider for each
c            ipot
c  output
c   (istate: number of states  ---  passed in kets.h)
c    i0:     index shift for each potential representative
c   (lrstat: (4, istatx) state kets |iat,l,m> --- passed in kets.h)
c--------------------------------------------------------------------
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c********************************************************************
c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate
      save   /stkets/
      integer   lipotx(0:nphasx), iphx(nclusx), i0(0:nphx)

      istate = 0
      do 120 iat=1,nat
        ip = iphx(iat)
c       i0(ip) - index for the ip-representative atom
c       need for simple find of states for ip-representative.
        if (i0(ip).lt.0) i0(ip) = istate
        lim = min(lx, lipotx(ip))
        do 110 l=0,lim
          do 100 m = -l, l
          do 100 isp = 1, nsp
            istate = istate + 1
            if (istate.gt.istatx) then
                call wlog('Exceeded maximum number of LR states.'//
     $                      '  Stopping')
                call par_stop('GETKTS-1')
            endif
            lrstat(1,istate) = iat
            lrstat(2,istate) = l
            lrstat(3,istate) = m
            lrstat(4,istate) = isp
 100      continue
 110    continue
 120  continue

      return
c end subroutine kets
      end
c    ----------------------------------------------------------------
      subroutine xclmz(lmaxp1,mmaxp1,rho,clm)
      implicit real(a-h,o-z)

c     calculates energy dependent factors needed in subroutine gllm
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  input:
c    lmaxp1, mmaxp1:  largest angular momentum under consideration + 1
c    rho:  distance between atoms * complex momentum at this energy
c          point
c  output:
c    clm(lx+1,lx+1):  Hankle-like polynomials from RA

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      parameter (one = 1, zero = 0)
      complex coni
      parameter (coni = (0,1))
      parameter (ltotb=lx+1,mtotb=ltotb,ntotb=ltotb,mntot=mtotb+ntotb)
      complex z, cmm, clm(ltotb+1,mntot+1), rho

      cmm  = cmplx(one, zero)
      z    = (-coni)/rho

      clm(1,1) = cmplx(one,zero)
      clm(2,1) = clm(1,1) - z

      lmax = lmaxp1-1
      do 20 il=2,lmax
        clm(il+1,1) = clm(il-1,1) - (z * (2*il-1) * clm(il,1))
 20   continue
c+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
c  nota bene:  the 2l-1 factor above is correct, even though in Rehr,
c  Albers equation 4 appears with a 2l+1.  The reason has to do with
c  the indexing.  in RA the subscripts on the c's start at 0.  In this
c  piece of code, the subscripts start at 1.  If you sub l-1 for
c      l, 2l+1 --> 2l-1
c+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+


      mmxp1 = min(lmaxp1, mmaxp1)
      do 40 im=2,mmxp1
        m    = im-1
        imp1 = im+1
        cmm  = (-cmm) * (2*m-1) * z
        clm(im,im)   = cmm
        clm(imp1,im) = cmm * (2*m+1) * (1-im*z)
        do 30 il=imp1,lmax
          clm(il+1,im) = clm(il-1,im) - (2*il-1) * z *
     $                               ( clm(il,im)+clm(il,m) )
c           l = il-1
c           clm(il+1,im) = clm(l,im) - (2*l+1) * z *
c      $                               ( clm(il,im)+clm(il,m) )
 30     continue
 40   continue

      return
c  end subroutine xclmz
      end
      subroutine xgllm(mu, ist1, ist2, lrstat, xclm, gllmz)
c--------------------------------------------------------------------
c  this calculates equations 11,12 from Rehr, Albers PRB v.41,#12,
c  p.8139,  the output is the G term in equation 9 from that paper
c
c  input:
c    mu:         abs val of magnetic state in sum in eqn 11 RA, mu>=0
c    ist1, ist2: state indices of mat. elem., first index of lrstat
c    lrstat:     (4,istatx,nkmin:nex) array of LR states
c    xclm:       (0:lx,0:lx,nclusx,nclusx) array of c_lm(z) for
c                present energy value
c  output:
c    gllmz:      g_ll'^|m|(z), for present state & energy, eqn 11 RA
c--------------------------------------------------------------------
c  this requires that N_lm normalization factors and c_lm(z)
c  polynomials have already been calculated.
c--------------------------------------------------------------------
      implicit real(a-h,o-z)
      implicit integer (i-n)

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/

c  end of xstruc.h
c********************************************************************

      parameter (zero=0.e0)
      integer    lrstat(4, istatx)
      complex xclm(0:lx, 0:lx, nclusx, nclusx), sum, gllmz
      complex gam, gamtl

      iat1     = lrstat(1, ist1)
      l1       = lrstat(2, ist1)
      iat2     = lrstat(1, ist2)
      l2       = lrstat(2, ist2)
      numax    = min(l1, l2-mu)

      sum      = cmplx(zero, zero)
      do 100 nu=0,numax
        mn    = mu+nu

c       bug for xnlm with nspx=2
        gamtl = (2*l1+1) * xclm(nu, l1, iat2, iat1) / xnlm(mu, l1)
        gam   = (-1)**mu * xclm(mn, l2, iat2, iat1) * xnlm(mu, l2)

        sum   = sum + gamtl * gam
 100  continue

      gllmz = sum

      return
c  end subroutine gllm
      end

c====================================================================
      subroutine gglu( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c  output
c    gg:  (nsp*lx**2, nsp*lx**2, 0:nphasx) submatrix spanning the entire
c          angular momentum basis for each unique potential

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      integer  i0 (0:nphx),  lipotx(0:nphx)

      parameter (one = 1, zero = 0)
      integer   ipiv(istatx)

c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate

      complex   tmatrx(nspx, istatx)
c     big work matrices
      complex   g0( istatx, istatx), g0t( istatx, istatx)
      complex   g0s( istatx, nspx*(lx+1)**2)
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)

      character*3  cerr
      character*13 trans

 400  format(i4)


c -------------------- LU gg
c     multiply T and G0 matrices together, construct g0t = 1 - G0*T
c     notice that the signs below for g0t ARE correct since 1 is the
c     unit matrix
c     since t is tri-diagonal, this product can be computed in n^2 time
c     also fill up some work matrices for use in eigenvalue and
c     determinant calculations and elsewhere
      do 320 icol = 1,istate
        do 310 irow = 1,istate
c         T diagonal contribution
          g0t(irow, icol) = - g0(irow, icol) * tmatrx(1, icol)
c         T off-diagonal contribution
          l1   = lrstat(2,icol)
          m1   = lrstat(3,icol)
          isp1 = lrstat(4,icol)
          m2 = m1+isp1
          if (nsp.eq.2 .and. m2.gt.-l1+1 .and. m2.lt.l1+2) then
             ist2 = icol + (-1)**isp1
             g0t(irow, icol) = g0t(irow, icol)
     1                   - g0(irow, ist2) * tmatrx(nsp, icol)
          endif
 310    continue

        g0t(icol, icol) = g0t(icol, icol) + one

 320  continue

c --- invert matrix by LU decomposition
c     call cgetrf from lapack.  this performs an LU decomposition on
c     the matrix g0t = 1 - g0*T
      call cgetrf( istate, istate, g0t, istatx, ipiv, info )
      if (info.lt.0) then
          call wlog('    *** Error in cgetrf when computing G')
          write(cerr,400)abs(info)
          call wlog('        Argument #'//cerr//
     $                ' had an illegal value.')
      elseif (info.gt.0) then
          call wlog('    *** Error in cgetrf when computing G')
          write(cerr,400)info
          call wlog('        g0t('//cerr// ','//cerr//
     $                ') is exactly 0 -- '//
     $                'this matrix cannot be decomposed.')
      endif

c     now we want g_c = (g0t)^-1 * g0.  Rather than calculating
c     the inverse of g0t from the LU decomposition, we can compute
c     g0t^-1 * g0 directly by backsubstituting the columns of G0.
c     See sect. 2.3 in Numerical Recipes or LAPACK Users' Guide
c     sect. 2.3

c     third arg in number of output columns, istate for full
c     matrix, ipart(ik) for just the parts of the matrix needed
c     to contruct fine structure + DOS functions

      do 620 ip=ipi, ipf
        ipart = nsp*(lipotx(ip)+1)**2
        do 590 is1 = 1, istate
        do 590 is2 = 1, ipart
          g0s(is1,is2) = g0(is1, is2 + i0(ip))
  590   continue

        trans = 'NotTransposed'
        call cgetrs(trans, istate, ipart, g0t, istatx,
     $                ipiv, g0s, istatx, info)
        if (info.lt.0) then
            call wlog('    *** Error in cgetrf')
            write(cerr,400) abs(info)
            call wlog('        Argument #'//cerr//
     $              ' had an invalid value.')
        endif

c **** at this point g0s contains the full MS ****

c  pack FMS matrix into an nsp*(lx+1)^2 x nsp*(lx+1)^2 matrix for each
c  ipot

        do 600 is2=1,ipart
        do 600 is1=1,ipart
          gg( is1, is2, ip) = g0s( is1+i0(ip), is2)
 600    continue
 620  continue

      return
      end
      subroutine ggbi( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1                 toler1, toler2, lcalc, msord)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c  output
c    gg:  (nsp*lx**2, nsp*lx**2, 0:nphasx) submatrix spanning the entire
c          angular momentum basis for each unique potential
c     BiCGStab algorithm: Saad, Iterative methods for ..., p. 220 (1996)

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      integer  i0 (0:nphx),  lipotx(0:nphx)

      parameter (one = 1, zero = 0)
      complex coni
      parameter (coni = (0,1))

c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate

      complex   tmatrx(nspx, istatx)
c     big work matrices
      complex   g0( istatx, istatx), g0t( istatx, istatx)
      logical lcalc
      dimension lcalc(0:lx)

c     Lanczos method variables
      complex xvec( istatx), yvec(istatx), avec(istatx), asve(istatx)
      complex rvec(istatx), pvec(istatx), svec( istatx)
      complex aa, dd, aw, wa, ww
      complex del, delp, omega, chi, psi
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)

c      notice that in gglu we invert (1-Gt), but here (1-tG).
c     multiply T and G0 matrices together, construct g0t = 1 - T*G0
c     notice that the signs below for g0t ARE correct since 1 is the
c     unit matrix
c     since t is tri-diagonal, this product can be computed in n^2 time
c     also fill up some work matrices for use in eigenvalue and
c     determinant calculations and elsewhere
c     cycle over dimensions of matrix g0t
      do 10 icol = 1,istatx
      do 10 irow = 1,istatx
 10   g0t(irow,icol) = 0

      do 30 icol = 1,istate
        do 20 irow = 1,istate
c         T diagonal contribution T(irow, irow)
          if ( abs( g0(irow, icol)) .gt. toler2 )
     1    g0t(irow,icol)=g0t(irow,icol) - tmatrx(1,irow) * g0(irow,icol) 

c         T off-diagonal contribution T(ist2, irow) in tmatr(2,irow)
c         T off-diagonal contribution T(irow, ist2) in tmatr(2,ist2)
          l1   = lrstat(2,irow)
          m1   = lrstat(3,irow)
          isp1 = lrstat(4,irow)
          m2 = m1+isp1
          if (nsp.eq.2 .and. m2.gt.-l1+1 .and. m2.lt.l1+2) then
c            spin-flip contribution
             ist2 = irow + (-1)**isp1
             if ( abs( g0(ist2, icol)) .gt. toler2)
     1       g0t(irow, icol) = g0t(irow, icol)
     2                   - tmatrx(nsp, ist2) * g0(ist2, icol) 
          endif
 20     continue

        g0t(icol, icol) = g0t(icol, icol) + one
 30   continue

      do 920 ip=ipi, ipf
        ipart = nsp*(lipotx(ip)+1)**2
        do 910 is1 = 1, ipart
          is2 = is1+i0(ip)
          l1   = lrstat(2,is2)
          if (.not.lcalc(l1)) goto 910

c         start first tier with xvec=0
          istart = -1
          msord = 0
          do 40 is = 1, istate
          avec(is) = 0
  40      xvec(is) = 0

c         RESTART here if necessary
  50      continue
          istart = istart+1

          if (istart.gt.0) call matvec( istatx,istate,g0t,xvec,avec,1)
          do 90 is = 1,istate
 90       rvec(is) = - avec(is)
c         rvec = bvec - g0t*xvec , in our case bvec(is) = delta_{is,is2}
          rvec(is2) = rvec(is2) + 1
cc          Check convergence criteria: |r_n+1| < tol
            ipass = 1
            do 92 is = 1, istate
              if ( abs(real(rvec(is))).gt.toler1) goto 93
              if ( abs(aimag(rvec(is))).gt.toler1) goto 93
 92         continue
            ipass = 0
 93         continue
            if (ipass.eq.0) goto 700

          do 95 is = 1, istate
 95       pvec(is) = rvec(is)
          call matvec( istatx,istate,g0t,pvec,avec,1)
          msord = msord + 1

c         choose yvec that del and delp close to one
          call cdot( istatx, istate, avec, avec, aa)
          call cdot( istatx, istate, rvec, avec, wa)
          aw = real(wa) - coni* aimag(wa)
          call cdot( istatx, istate, rvec, rvec, ww)
          dd = aa*ww - aw*wa
          if (abs(dd/aa/ww) .lt.1.e-8) then
            do 96 is = 1,istate
  96        yvec(is) = rvec(is) / ww
          else
            ww = ( ww - aw ) / dd
            aa = ( wa - aa) / dd
            do 97 is = 1,istate
  97        yvec(is) = rvec(is) * aa + avec(is) * ww
          endif
          call cdot( istatx, istate, yvec, rvec, del)

c         it seems ran out of precision for nit>150
          nitx = 30
          do 500 nit = 0, nitx
            call cdot( istatx, istate, yvec, avec, delp)
            omega = del / delp

            do 120 is = 1, istate
 120        svec(is) = rvec(is) - omega * avec(is)
cc          Check convergence criteria: |s_n+1| < tol
            ipass = 1
            do 122 is = 1, istate
              if ( abs(real(svec(is))).gt.toler1) goto 123
              if ( abs(aimag(svec(is))).gt.toler1) goto 123
 122        continue
            ipass = 0
 123        continue
            if (ipass.eq.0)  then
              do 124 is = 1, istate
 124          xvec(is) = xvec(is) + omega*pvec(is)
              goto 700
            endif

            call matvec( istatx,istate,g0t,svec,asve,1)
            msord = msord + 1
            call cdot( istatx, istate, asve, asve, aa)
            call cdot( istatx, istate, asve, svec, wa)
            chi = wa / aa
            do 125 is = 1, istate
 125        xvec(is) = xvec(is) + omega*pvec(is) + chi*svec(is)

            do 130 is = 1, istate
 130        rvec(is) = svec(is) - chi* asve(is)

cc          Check convergence criteria: |r_n+1| < tol
            ipass = 1
            do 370 is = 1, istate
              if ( abs(real(rvec(is))).gt.toler1) goto 380
              if ( abs(aimag(rvec(is))).gt.toler1) goto 380
 370        continue
            ipass = 0
 380        continue
            if (ipass.eq.0) goto 700

c           prepare for next iteration
            call cdot( istatx, istate, yvec, rvec, del)
            psi = del / (delp * chi)

            do 135 is = 1, istate
 135        pvec(is) = rvec(is) + psi * (pvec(is)-chi*avec(is))
            call matvec( istatx,istate,g0t,pvec,avec,1)
            msord = msord + 1

 500      continue
c         restart since ran out of iterations
          goto 50

c         exit if tolerance has been achieved
 700      continue
c         print*, ' BI iterations:', nit + istart*nitx
c         end of BI iterations

c         at this point xvec = (1-tG)**-1 * bvec  with chosen tolerance
c         pack FMS matrix into an nsp*(lx+1)^2 x nsp*(lx+1)^2 matrix 
c         for each ipot
          do 800 is2=1,ipart
            gg( is2, is1, ip) = zero
            do 790 is = 1,istate
              gg( is2, is1, ip) = gg( is2, is1, ip) +
     1        g0( is2+i0(ip), is) * xvec(is)
 790        continue
 800      continue

 910    continue
 920  continue

      return
      end
      subroutine ggrm( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1                 toler1, toler2, lcalc, msord)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c  output
c    gg:  (nsp*lx**2, nsp*lx**2, 0:nphasx) submatrix spanning the entire
c          angular momentum basis for each unique potential

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      integer  i0 (0:nphx),  lipotx(0:nphx)

      parameter (one = 1, zero = 0)
      complex coni
      parameter (coni = (0,1))

c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate

      complex   tmatrx(nspx, istatx)
c     big work matrices
      complex   g0( istatx, istatx), g0t( istatx, istatx)
      logical lcalc
      dimension lcalc(0:lx)

      complex xvec( istatx), xket( istatx), xbra( istatx)
      complex xketp(istatx), xbrap(istatx)
      complex zvec(istatx), rvec(istatx), svec(istatx)
      complex tket(istatx), tbra(istatx)
      double precision  dum1, dum2
      complex alphac, betac, aa, bb, yy, aac, bbc, gamma
      real alpha, beta
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)

c      notice that in gglu we invert (1-Gt), but here (1-tG).
c     multiply T and G0 matrices together, construct g0t = 1 - T*G0
c     notice that the signs below for g0t ARE correct since 1 is the
c     unit matrix
c     since t is tri-diagonal, this product can be computed in n^2 time
c     also fill up some work matrices for use in eigenvalue and
c     determinant calculations and elsewhere
c     cycle over dimensions of matrix g0t
      do 10 icol = 1,istatx
      do 10 irow = 1,istatx
 10   g0t(irow,icol) = 0

      do 30 icol = 1,istate
        do 20 irow = 1,istate
c         T diagonal contribution T(irow, irow)
          if ( abs( g0(irow, icol)) .gt. toler2 )
     1    g0t(irow,icol)=g0t(irow,icol) - tmatrx(1,irow) * g0(irow,icol) 

c         T off-diagonal contribution T(ist2, irow) in tmatr(2,irow)
c         T off-diagonal contribution T(irow, ist2) in tmatr(2,ist2)
          l1   = lrstat(2,irow)
          m1   = lrstat(3,irow)
          isp1 = lrstat(4,irow)
          m2 = m1+isp1
          if (nsp.eq.2 .and. m2.gt.-l1+1 .and. m2.lt.l1+2) then
c            spin-flip contribution
             ist2 = irow + (-1)**isp1
             if ( abs( g0(ist2, icol)) .gt. toler2)
     1       g0t(irow, icol) = g0t(irow, icol)
     2                   - tmatrx(nsp, ist2) * g0(ist2, icol) 
          endif
 20     continue

        g0t(icol, icol) = g0t(icol, icol) + one
 30   continue

      do 920 ip=ipi, ipf
        ipart = nsp*(lipotx(ip)+1)**2
        do 910 is1 = 1, ipart
          is2 = is1+i0(ip)
          l1   = lrstat(2,is2)
          if (.not.lcalc(l1)) goto 910

c         start first tier with xvec=0
          istart = -1
          msord=0
          do 40 is = 1, istate
          rvec(is) = 0
  40      xvec(is) = 0

c         RESTART here if necessary
  50      continue
          istart = istart+1

          if (istart.gt.0) call matvec( istatx,istate,g0t,xvec,rvec,1)
c         rvec = g0t*xvec - bvec, in our case bvec(is) = delta_{is,is2}
          rvec(is2) = rvec(is2) - 1
          do 90 is = 1,istate
 90       xket(is) = - rvec(is)
          call cdot( istatx, istate, xket, xket, bb)
          if (abs(bb).eq.0) goto 700

          xfnorm = 1.e0 / real(dble(bb))
          do 91 is = 1, istate
 91       xbra(is) = xket(is) * xfnorm
c         |t> = A |n> ; |n> - xket, |n-1> - xketp
          call matvec ( istatx, istate, g0t, xket, tket, 1)
          msord = msord + 1
          call cdot( istatx, istate, xbra, tket, aa)
          aac = real(aa) - coni*aimag(aa)
          bb = 0
          bbc= 0
          betac = aa
          yy = 1
c         initialize vectors
          do 110 is = 1,istate
            xketp(is) = 0
            xbrap(is) = 0
            zvec(is) = xket(is)
            xvec(is) = xvec(is) + zvec(is)/betac
 110      continue

          do 120 is = 1, istate
 120      svec(is) = tket(is)
          do 130 is = 1, istate
 130      rvec(is) = rvec(is) + svec(is) / betac

c         it seems ran out of precision for nit>150
          nitx = 100
          do 300 nit = 1, nitx
c           use recursion method to calculate a_n+1, b_n, |n+1>, <n+1|
            do 140 is = 1, istate
 140        tket(is) = tket(is) - aa*xket(is) - bb*xketp(is)
            call matvec ( istatx, istate, g0t, xbra, tbra, 2)
            do 150 is = 1, istate
 150        tbra(is) = tbra(is) - aac*xbra(is) - bbc*xbrap(is)
            call cdot( istatx, istate, tbra, tket, bb)
            if (abs(bb).eq.0) goto 700

            bb = sqrt (bb)
            bbc = real(bb) - coni*aimag(bb)
            do 160 is = 1, istate
              xketp(is) = xket(is)
              xbrap(is) = xbra(is)
 160        continue
            do 170 is = 1, istate
              xket(is) = tket(is) / bb
              xbra(is) = tbra(is) / bbc
 170        continue
            call matvec ( istatx, istate, g0t, xket, tket, 1)
            msord = msord + 1
            call cdot( istatx, istate, xbra, tket, aa)
            aac = real(aa) - coni*aimag(aa)
            
c           update iterative solution xvec, 
c           and residual rvec = g0t*xvec - |1>
            alphac = bb / betac
            do 210 is = 1, istate
 210        zvec(is) = xket(is) - alphac * zvec(is)
            do 220 is = 1, istate
 220        svec(is) = tket(is) - alphac * svec(is)

            betac = aa - alphac*bb
            yy = - alphac * yy
            gamma = yy / betac
            do 230 is = 1, istate
 230        xvec(is) = xvec(is) + gamma * zvec(is)
            do 240 is = 1, istate
 240        rvec(is) = rvec(is) + gamma * svec(is)

cc          Check convergence criteria: | rvec | < tol
c           call vecvec( istatx, istate, rvec, rvec, dum2)
c           if (dum2.le.tol) goto 700
cc          Check convergence criteria: | rvec | < tol
            ipass = 1
            do 250 is = 1, istate
              if ( abs(real(rvec(is))).gt.toler1) goto 260
              if ( abs(aimag(rvec(is))).gt.toler1) goto 260
 250        continue
            ipass = 0
 260        continue
            if (ipass.eq.0) goto 700

 300      continue
c         restart since ran out of iterations
          goto 50

c         exit if tolerance has been achieved
 700      continue
c         end of RM iterations

c         at this point xvec = (1-tG)**-1 * bvec  with chosen tolerance
c         pack FMS matrix into an nsp*(lx+1)^2 x nsp*(lx+1)^2 matrix 
c         for each ipot
          do 800 is2=1,ipart
            gg( is2, is1, ip) = zero
            do 790 is = 1,istate
              gg( is2, is1, ip) = gg( is2, is1, ip) +
     1        g0( is2+i0(ip), is) * xvec(is)
 790        continue
 800      continue

 910    continue
 920  continue

      return
      end

      subroutine cdot ( istatx, istate, abra, aket, cc)
c     dot product of two vectors
c     notice that we keep bra  vector as it's complex conjugate
c     thus need to conjugate abra here
      implicit real (a-h,o-z)
      implicit integer (i-n)
      complex coni
      parameter (coni = (0,1))
      complex abra, aket, cc, aa
      dimension abra(istatx), aket(istatx)

      cc = 0
      do 10 is = 1,istate
        aa = real(abra(is)) - coni*aimag(abra(is))
        cc = cc + aa * aket(is)
 10   continue
      return
      end

      subroutine vecvec ( istatx, istate, avec, bvec, cc)
c     dot product of two vectors
      implicit real (a-h,o-z)
      implicit integer (i-n)
      complex avec, bvec
      double precision cc, aa, bb
      dimension avec(istatx), bvec(istatx)

      cc = 0
      do 10 is = 1,istate
        aa = dble(real(avec(is))) * dble(real(bvec(is)))
        bb = dble(aimag(avec(is))) * dble(aimag(bvec(is)))
        cc = cc + aa + bb
 10   continue
      return
      end

      subroutine matvec (istatx, istate, amat, bvec, cvec, itrans)
c     itrans = 1  cvec = amat * bvec
c     itrans = 2  cvec = amat^+ * bvec
c     itrans = 3  cvec = amat^T * bvec
      implicit real (a-h,o-z)
      implicit integer (i-n)
      complex coni, aa
      parameter (coni = (0,1))
      complex amat, bvec, cvec
      dimension amat(istatx, istatx), bvec(istatx), cvec(istatx)

c     initialize cvec
      do 10 is = 1,istatx
 10   cvec(is) = 0

c     cycle over dimensions of amat
      do 20 icol = 1,istate
      do 20 irow = 1,istate
        if (itrans.eq.1) then
          cvec(irow) = cvec(irow) + amat(irow, icol) * bvec(icol)
        elseif(itrans.eq.2) then
          aa = real(amat(irow, icol)) - coni*aimag(amat(irow, icol))
          cvec(icol) = cvec(icol) + aa * bvec(irow)
        else
          cvec(icol) = cvec(icol) + amat(irow, icol) * bvec(irow)
        endif
 20   continue

      return
      end
      subroutine gggm( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1                 toler1, toler2, lcalc, msord)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c  output
c    gg:  (nsp*lx**2, nsp*lx**2, 0:nphasx) submatrix spanning the entire
c          angular momentum basis for each unique potential
c     Lanczos algorithm: Graves-Morris,Salam, Num.Algor.21,p.213(1999)

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      integer  i0 (0:nphx),  lipotx(0:nphx)

      parameter (one = 1, zero = 0)
      complex coni
      parameter (coni = (0,1))

c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate

      complex   tmatrx(nspx, istatx)
c     big work matrices
      complex   g0( istatx, istatx), g0t( istatx, istatx)
      logical lcalc
      dimension lcalc(0:lx)

c     Lanczos method variables
      complex xvec( istatx), wvec(istatx), x0(istatx), x1(istatx)
      complex avec(istatx), bvec(istatx)
      complex r0(istatx), r1(istatx), t0(istatx), t1(istatx)
      complex aa, dd, aw, wa, ww, e0, e1, alpha, beta, theta, q0, q1
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)

c      notice that in gglu we invert (1-Gt), but here (1-tG).
c     multiply T and G0 matrices together, construct g0t = 1 - T*G0
c     notice that the signs below for g0t ARE correct since 1 is the
c     unit matrix
c     since t is tri-diagonal, this product can be computed in n^2 time
c     also fill up some work matrices for use in eigenvalue and
c     determinant calculations and elsewhere
c     cycle over dimensions of matrix g0t
      do 10 icol = 1,istatx
      do 10 irow = 1,istatx
 10   g0t(irow,icol) = 0

      do 30 icol = 1,istate
        do 20 irow = 1,istate
c         T diagonal contribution T(irow, irow)
          if ( abs( g0(irow, icol)) .gt. toler2 )
     1    g0t(irow,icol)=g0t(irow,icol) + tmatrx(1,irow) * g0(irow,icol) 

c         T off-diagonal contribution T(ist2, irow) in tmatr(2,irow)
c         T off-diagonal contribution T(irow, ist2) in tmatr(2,ist2)
          l1   = lrstat(2,irow)
          m1   = lrstat(3,irow)
          isp1 = lrstat(4,irow)
          m2 = m1+isp1
          if (nsp.eq.2 .and. m2.gt.-l1+1 .and. m2.lt.l1+2) then
c            spin-flip contribution
             ist2 = irow + (-1)**isp1
             if ( abs( g0(ist2, icol)) .gt. toler2)
     1       g0t(irow, icol) = g0t(irow, icol)
     2                   + tmatrx(nsp, ist2) * g0(ist2, icol) 
          endif
 20     continue

c       g0t(icol, icol) = g0t(icol, icol) + one
 30   continue

      do 920 ip=ipi, ipf
        ipart = nsp*(lipotx(ip)+1)**2
        do 910 is1 = 1, ipart
          is2 = is1+i0(ip)
          l1   = lrstat(2,is2)
          if (.not.lcalc(l1)) goto 910

c         start first tier with xvec=0
          istart = -1
          msord = 0
          do 40 is = 1, istate
          bvec(is) = 0
  40      xvec(is) = 0
c         rvec = bvec - A*xvec , in our case bvec(is) = delta_{is,is2}
          bvec(is2) = 1

c         RESTART here if necessary
  50      continue
          istart = istart+1

          if (istart.gt.0) then
            do 60 is = 1, istate
  60        xvec(is) = xvec(is) + x0(is) / q0
            call matvec( istatx,istate,g0t,xvec,avec,1)
            do 70 is = 1, istate
  70        bvec(is) = avec(is) - xvec(is)
            bvec(is2) = bvec(is2) + 1
          endif
          do 80 is = 1,istate
 80       r0(is) = bvec(is)
          do 90 is = 1,istate
 90       x0(is) = 0
          do 95 is = 1, istate
 95       x1(is) = bvec(is)
          call matvec( istatx,istate,g0t,bvec,r1,1)
          msord = msord + 1

c         choose wvec that del and delp close to one
          call cdot( istatx, istate, r0, r0, ww)
          call cdot( istatx, istate, r1, r1, aa)
          call cdot( istatx, istate, r0, r1, wa)
          aw = real(wa) - coni* aimag(wa)
          dd = aa*ww - aw*wa
          if (abs(dd/aa/ww) .lt.1.e-8) then
            do 96 is = 1,istate
  96        wvec(is) = r0(is) / ww
          else
            ww = ( ww - aw ) / dd
            aa = ( wa - aa) / dd
            do 97 is = 1,istate
  97        wvec(is) = r0(is) * aa + r1(is) * ww
          endif
c         update dot products to avoid round off errors
          call cdot( istatx, istate, wvec, r0, e0)
          call cdot( istatx, istate, wvec, r1, e1)
          q0 = 1
          q1 = 1

c         it seems ran out of precision for nit>150
          nitx = 10
          do 500 nit = 1, nitx
            tol = toler1 * abs(q1) /10
cc          Check convergence criteria: |r1| < tol / 10
cc          so mostly code will not exit here
            ipass = 1
            do 98 is = 1, istate
              if ( abs(real(r1(is))).gt.tol) goto 99
              if ( abs(aimag(r1(is))).gt.tol) goto 99
  98        continue
            ipass = 0
  99        continue
            if (ipass.eq.0) then
              do 100 is = 1, istate
 100          xvec(is) = xvec(is) + x1(is) / q1
              goto 700
            endif

            alpha = e1 / e0
            do 130 is = 1, istate
 130        t0(is) = r1(is) - alpha* r0(is)
            call matvec( istatx,istate,g0t,t0,t1,1)
            msord = msord + 1

            call cdot( istatx, istate, t0, t1, wa)
            call cdot( istatx, istate, t0, t0, ww)
            call cdot( istatx, istate, t1, t1, aa)
            aw = real(wa) - coni* aimag(wa)
            theta = (wa - aa) / (ww - aw)

            do 145 is = 1, istate
 145        r0(is) = t1(is) - theta * t0(is)
            dd = 1- theta
            do 150 is = 1, istate
 150        x0(is) = t0(is) + dd * (x1(is) - alpha*x0(is))
            q0 = dd * (q1 - alpha*q0)
            tol = toler1 * abs(q0)

cc          Check convergence criteria: |r0| < tol
            ipass = 1
            do 370 is = 1, istate
              if ( abs(real(r0(is))).gt.tol) goto 380
              if ( abs(aimag(r0(is))).gt.tol) goto 380
 370        continue
            ipass = 0
 380        continue
            if (ipass.eq.0) then 
              do 390 is = 1, istate
 390          xvec(is) = xvec(is) + x0(is) / q0
              goto 700
            endif

c           prepare for next iteration
            call cdot( istatx, istate, wvec, r0, e0)
            beta = e0 / e1
            do 255 is = 1, istate
 255        t0(is) = r0(is) - beta * r1(is)
            call matvec( istatx,istate,g0t,t0,avec,1)
            msord = msord + 1
            dd = beta * theta
            do 260 is = 1, istate
 260        r1(is) = avec(is) + dd * r1(is)
            call cdot( istatx, istate, wvec, r1, e1)

            dd = beta * (1-theta)
            do 270 is = 1, istate
 270        x1(is) = x0(is) - dd * x1(is) + t0(is)
            q1 = q0 - (1-theta) * beta * q1
 500      continue
c         restart since ran out of iterations
          goto 50

c         exit if tolerance has been achieved
 700      continue
c         end of GM iterations

c         at this point xvec = (1-tG)**-1 * bvec  with chosen tolerance
c         pack FMS matrix into an nsp*(lx+1)^2 x nsp*(lx+1)^2 matrix 
c         for each ipot
          do 800 is2=1,ipart
            gg( is2, is1, ip) = zero
            do 790 is = 1,istate
              gg( is2, is1, ip) = gg( is2, is1, ip) +
     1        g0( is2+i0(ip), is) * xvec(is)
 790        continue
 800      continue

 910    continue
 920  continue

      return
      end
      subroutine ggtf( nsp, i0, ipi, ipf, lipotx, g0, tmatrx, g0t, gg,
     1                 toler1, toler2, lcalc, msord)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c  output
c    gg:  (nsp*lx**2, nsp*lx**2, 0:nphasx) submatrix spanning the entire
c          angular momentum basis for each unique potential
c     TFQMR: Saad, Iterative Methods for Sparse Matrices, p.225 (1996).

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      integer  i0 (0:nphx),  lipotx(0:nphx)

      parameter (one = 1, zero = 0)
      complex coni
      parameter (coni = (0,1))

c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate

      complex   tmatrx(nspx, istatx)
c     big work matrices
      complex   g0( istatx, istatx), g0t( istatx, istatx)
      logical lcalc
      dimension lcalc(0:lx)

      complex xvec(istatx), uvec(istatx), avec(istatx), wvec(istatx)
      complex dvec(istatx), rvec(istatx), vvec(istatx)
      complex alpha, beta, aa, rho, eta
      real tau, nu, cm, err
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)

c      notice that in gglu we invert (1-Gt), but here (1-tG).
c     multiply T and G0 matrices together, construct g0t = 1 - T*G0
c     notice that the signs below for g0t ARE correct since 1 is the
c     unit matrix
c     since t is tri-diagonal, this product can be computed in n^2 time
c     also fill up some work matrices for use in eigenvalue and
c     determinant calculations and elsewhere
c     cycle over dimensions of matrix g0t
      do 10 icol = 1,istatx
      do 10 irow = 1,istatx
 10   g0t(irow,icol) = 0

      do 30 icol = 1,istate
        do 20 irow = 1,istate
c         T diagonal contribution T(irow, irow)
          if ( abs( g0(irow, icol)) .gt. toler2 )
     1    g0t(irow,icol)=g0t(irow,icol) - tmatrx(1,irow) * g0(irow,icol) 

c         T off-diagonal contribution T(ist2, irow) in tmatr(2,irow)
c         T off-diagonal contribution T(irow, ist2) in tmatr(2,ist2)
          l1   = lrstat(2,irow)
          m1   = lrstat(3,irow)
          isp1 = lrstat(4,irow)
          m2 = m1+isp1
          if (nsp.eq.2 .and. m2.gt.-l1+1 .and. m2.lt.l1+2) then
c            spin-flip contribution
             ist2 = irow + (-1)**isp1
             if ( abs( g0(ist2, icol)) .gt. toler2)
     1       g0t(irow, icol) = g0t(irow, icol)
     2                   - tmatrx(nsp, ist2) * g0(ist2, icol) 
          endif
 20     continue

        g0t(icol, icol) = g0t(icol, icol) + one
 30   continue

      do 920 ip=ipi, ipf
        ipart = nsp*(lipotx(ip)+1)**2
        do 910 is1 = 1, ipart
          is2 = is1+i0(ip)
          l1   = lrstat(2,is2)
          if (.not.lcalc(l1)) goto 910

c         start first tier with xvec=0
          istart = -1
          msord = 0
          do 40 is = 1, istate
          rvec(is) = 0
          avec(is) = 0
  40      xvec(is) = 0

c         RESTART here if necessary
  50      continue
          istart = istart+1

          if (istart.gt.0) call matvec( istatx,istate,g0t,xvec,avec,1)
          do 90 is = 1,istate
 90       uvec(is) = - avec(is)
c         uvec = bvec - g0t*xvec , in our case bvec(is) = delta_{is,is2}
          uvec(is2) = uvec(is2) + 1
          call matvec( istatx,istate,g0t,uvec,avec,1)
          msord = msord + 1
          do 95 is = 1, istate
 95       wvec(is) = uvec(is)
          do 96 is = 1, istate
 96       vvec(is) = avec(is)
          do 97 is = 1, istate
 97       dvec(is) = 0
          call cdot( istatx, istate, uvec, uvec, aa)
          tau = sqrt(real(aa))
          nu = 0
          eta = 0
c         choose rvec = uvec /aa so that dot products are about 1
          do 98 is = 1, istate
 98       rvec(is) = uvec(is) / aa
          rho = 1

c         it seems ran out of precision for nit>150
          nitx = 20
          do 300 nit = 0, nitx
            if (mod(nit,2).eq.0) then
              call cdot( istatx, istate, rvec, vvec, aa)
              alpha = rho / aa
            else
              call matvec( istatx,istate,g0t,uvec,avec,1)
              msord = msord + 1
            endif

            do 115 is = 1, istate
 115        wvec(is) = wvec(is) - alpha * avec(is)

            aa = nu**2 * eta / alpha
            do 120 is = 1, istate
 120        dvec(is) = uvec(is) + aa * dvec(is)

            call cdot( istatx, istate, wvec, wvec, aa)
            nu = sqrt(real(aa)) / tau
            cm = 1 / sqrt(1+nu**2)
            tau = tau * nu * cm
            eta = cm**2 * alpha
            do 140 is = 1, istate
 140        xvec(is) = xvec(is) + eta * dvec(is)

cc          Check convergence criteria: | rvec | < tol
            err = (1.e0 + nit) / istate
            err = tau * sqrt(err) * 10
            if ( abs(err).lt.toler1) goto 700

            if (mod(nit,2) .ne.0) then
              aa = rho
              call cdot( istatx, istate, rvec, wvec, rho)
              beta = rho / aa
              do 210 is = 1, istate
 210          uvec(is) = wvec(is) + beta * uvec(is)

              do 215 is = 1, istate
 215          vvec(is) = beta * ( avec(is) + beta * vvec(is))
              call matvec( istatx,istate,g0t,uvec,avec,1)
              msord = msord + 1
              do 220 is = 1, istate
 220          vvec(is) = avec(is) + vvec(is)
            else
              do 230 is = 1, istate
 230          uvec(is) = uvec(is) - alpha * vvec(is)
            endif
 300      continue
c         restart since ran out of iterations
          goto 50

c         exit if tolerance has been achieved
 700      continue
c         end of TFQMR iterations

c         at this point xvec = (1-tG)**-1 * bvec  with chosen tolerance
c         pack FMS matrix into an nsp*(lx+1)^2 x nsp*(lx+1)^2 matrix 
c         for each ipot
          do 800 is2=1,ipart
            gg( is2, is1, ip) = zero
            do 790 is = 1,istate
              gg( is2, is1, ip) = gg( is2, is1, ip) +
     1        g0( is2+i0(ip), is) * xvec(is)
 790        continue
 800      continue

 910    continue
 920  continue

      return
      end
      subroutine atheap(nat, rat, iphat, ra)

c--------------------------------------------------------------
c  copyright 1993 university of washington         bruce ravel
c  modified by alexei ankudinov in march 1999
c--------------------------------------------------------------
      implicit real (a-h,o-z)
      implicit integer (i-n)
c      implicit double precision (a-h,o-z)
c-------------------------------------------------------------------
c  heapsort adapted from numerical recipes.  sort atoms by distance.
c  all the pesky little do loops are for transferring rows
c  of temp into toss.
c-------------------------------------------------------------------
c  alexei ankudinov: needed to avoid unnecessary permutations when atoms
c  are at the same distance from the central atom, in order to comply 
c  feff document: the sample atom should be the nearest to absorber or
c  first in the list among equidistant
c  Add small contribution 10**-8 * number to the sorting variable ra
c  in order to achieve this.
c-------------------------------------------------------------------
c  natx:   dimension parameter from calling program
c-------------------------------------------------------------------
      dimension rat(3, nat), toss(3), iphat(nat)
      double precision ra(nat), dum 

      if (nat.lt.2) return

      l=0
      do 10 i=1,nat
         ra(i) = dble( rat(1,i)**2 + rat(2,i)**2 + rat(3,i)**2 ) +
     1           i*1.d-8
c        small addition at to prefer the old ordering
         if (l.eq.0 .and.i.gt.1) then
             if (ra(i).lt.ra(i-1)) l=1
         endif
  10  continue
c     check if array is already in order
      if (l.eq.0) return

      l  = nat/2+1
      ir = nat
 110  continue
         if (l.gt.1) then
            l = l-1
            do 120 index=1,3
               toss(index)=rat(index,l)
 120        continue
            itoss = iphat(l)
            dum = ra(l)
         else
            do 130 index=1,3
               toss(index) = rat(index,ir)
 130        continue
            itoss = iphat(ir)
            dum = ra(ir)
            do 140 index=1,3
               rat(index,ir) = rat(index,1)
 140        continue
            iphat(ir) = iphat(1)
            ra(ir) = ra(1)
            ir=ir-1
            if (ir.eq.1) then
               do 150 index=1,3
                  rat(index,1)=toss(index)
 150           continue
               iphat(1) = itoss
               ra(1) = dum
c              sort is finished
               goto 300
            endif
         endif
         i=l
         j=l+l

 160     if (j.le.ir) then
            if (j.lt.ir) then
               if ( ra(j) .lt. ra(j+1) ) then
                  j  = j + 1
               endif
            endif

            if ( dum .lt. ra(j) ) then
               do 170 index=1,3
                  rat(index,i) = rat(index,j)
 170           continue
               iphat(i) = iphat(j)
               ra(i) = ra(j)
               i=j
               j=j+j
            else
               j=ir+1
            endif
            goto 160
         endif

         do 180 index=1,3
            rat(index,i) = toss(index)
 180     continue
         iphat(i) = itoss
         ra(i) = dum

      goto 110
 300  continue

      return
c end subroutine atheap
      end
      subroutine getang(nclusx, rat, i, j, theta, phi)

c------------------------------------------------------------------
c  determine theta and phi polar angles of the vector between two
c  atom positions
c
c  inputs
c    rat:   (3,nclusx) x,y,z of all atoms in cluster
c    i, j:  indices of atoms at ends of vector Ri-Rj
c
c  outputs
c    theta: polar angle theta of vector Ri-Rj
c    phi:   polar angle phi of vector Ri-Rj
c------------------------------------------------------------------

      implicit real (a-h,o-z)
      implicit integer (i-n)

c       include 'dim.h'
c       include 'xparam.h'
      dimension rat(3,nclusx)
      parameter(tiny=1.e-7, zero=0.e0, pi=3.141592654)

      x = rat(1,i) - rat(1,j)
      y = rat(2,i) - rat(2,j)
      z = rat(3,i) - rat(3,j)
      r = sqrt(x**2 + y**2 + z**2)

c  this fails to calculate phi correctly for, as an example,
c  x=0.5e-7 and y=2e-7.  However, those numbers are below the
c  precision of the numbers stored in potph.bin.

      phi = zero
      theta  = zero
      if (i.ne.j) then
c           phi = atan2(y,x)
c        all of these conditionals will do the work for a machine that
c        cannot correctly handle a zero value for the second argument
c        of atan2
          if (abs(x).lt.tiny) then
              if (abs(y).lt.tiny) then
                  phi = zero
              elseif (y.gt.tiny) then
                  phi = pi/2
              else
                  phi = -pi/2
              endif
          else
              phi = atan2(y,x)
          endif
          if (r.gt.tiny) then
            if (z.le.-r) then
             theta = pi
            elseif ( z.lt.r) then
             theta = acos(z/r)
            endif
          endif
      endif

      return
c  end subroutine getang
      end


c====================================================================
      subroutine rotxan (lxp1, mxp1, betax, i, j, k)
      implicit real (a-h,o-z)

c     input:  lxp1, mxp1: lmax+1 & mmax+1, largest L states in matrix
c             betax is the rotation angle
c             i and j are the indeces of the atoms, thus denote
c                 which pair of atoms this is the rotation matrix for
c             k=0 for forward rotation, k=1 for backward rotation
c     output: drix(L,k,j,i) in common /rotx/
c+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
c     adapted by BR from rot3i, version for genfmt by SIZ
c        new data structure for rotation matrices to accomodate
c        xanes calculation
c+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
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     lxx 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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c       include 'xstruc.h'
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c#mn{
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/
c#mn}

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/

c  end of xstruc.h
c********************************************************************
      parameter (one = 1, zero = 0)
c      needed for commented out diagnostic file
c      logical open
      parameter(lxx=24)
      parameter (pi = 3.14159 26535 89793 23846 26433e0)
      complex coni, dum 
      parameter (coni = (0,1))

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 (lxx+1, 2*lxx+1, 2*lxx+1)

c#mn{
c  check whether a rotation matrix for this {beta(ileg),lxp1,mxp1} has
c  been calculated and saved.  If so, just use the saved value
       do 90 isav = 1, jsav
          if (betsav(isav).eq.jbmagk) go to 95
          if ((lxp1.eq.ldsav(isav)).and.(mxp1.eq.mdsav(isav)).and.
     $         (abs(betax-betsav(isav)).le.roteps) ) then
cc             print*, 'using drisav for ', isav, betax, lxp1, mxp1
             do 85 il = 0, lx
             do 85 m1 = -il, il
             do 85 m2 = -il, il
               drix(m2,m1,il,k,j,i)=cmplx(drisav(m2,m1,il,isav),zero)
 85          continue
             go to 770
          end if
 90    continue
 95    continue
c#mn}


c     initialize dri0
      do 150 in = 1, 2*lxx+1
        do 150 im = 1, 2*lxx+1
          do 150 il = 1, lxx+1
            dri0(il,im,in) = zero
 150  continue

      nm  = mxp1
      ndm = lxp1+nm-1
      xc  = cos(betax/2)
      xs  = sin(betax/2)
      s   = sin(betax)
      dri0(1,1,1) =  1
      dri0(2,1,1) =  xc**2
      dri0(2,1,2) =  s/sqrt(2*one)
      dri0(2,1,3) =  xs**2
      dri0(2,2,1) = -dri0(2,1,2)
      dri0(2,2,2) =  cos(betax)
      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 230  l = 3, lxp1
        ln = 2*l - 1
        lm = 2*l - 3
        if (ln .gt. ndm)  ln = ndm
        if (lm .gt. ndm)  lm = ndm
        do 220  n = 1, ln
          do 210  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))
     $                  dri0(l,m,n) = (-1)**(n-m) * dri0(l,n,m)
 210      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
 220    continue
 230  continue


c     initialize drix
      do 310 il = 0, lx
      do 310 m1 = -lx, lx
      do 310 m2 = -lx, lx
        drix(m2,m1,il,k,j,i) = cmplx(zero,zero)
        drix(m2,m1,il,k,i,i) = cmplx(zero,zero)
 310  continue

c     Copy result into drix(...,k,j,i) in /rotx/
      do 390  il = 1, lxp1
        mmx = min (il-1, mxp1-1)
        do 380  m1 = -mmx, mmx
        do 380  m2 = -mmx, mmx
          drix(m2, m1, il-1, k, j, i)=cmplx(dri0(il,m1+il,m2+il),zero)
 380    continue
 390  continue
c#mn{
c      save dri if there's room
       if (jsav.lt.jsavx) then
          jsav = jsav + 1
cc          print*, 'saving dri to ',  jsav, betax, lxp1, mxp1
          betsav(jsav) = betax
          ldsav(jsav)  = lxp1
          mdsav(jsav)  = mxp1
          do 720 il = 0, lx
          do 720 m1 = -il, il
          do 720 m2 = -il, il
            drisav(m2,m1,il,jsav) = real(drix(m2,m1,il,k,j,i))
 720      continue
       else
cc          print*, 'not saving dri to ',  betax, lxp1, mxp1
       end if
 770   continue
c#mn}

c-----test sum rule on d
c       if (idbg(1).eq.1) then
c           inquire(file='rotmat.dat', opened=open)
c           if (.not.open) then
c               iun = nxtunt(25)
c               open (iun,file='rotmat.dat',status='unknown')
c           endif
c           write(iun,*)'  '
c           write(iun,*)'atom #s : ',i,j
c           write(iun,*)  ' il, im, sum, beta'
c           write(iun,*) ' (drix(il,im,in,k,j,i),in = -il,il)'
c           do 880 il = 0,lxp1-1
c             do 870 im = -il,il
c               sum = 0
c               do 850 in = -il,il
c                 term = drix(in,im,il,k,j,i)
c                 sum = sum+term**2
c  850           continue
c               write(iun,860) il,im,sum,betax
c               write(iun,862) (drix(in,im,il,k,j,i),in = -il,il)
c  860          format(2i3,1x,f16.12,1x,f8.4)
c  862          format(5f14.6)
c  870         continue
c  880       continue
c c          close(iun)
c       endif
c-----end test------------------------

        do 920 il = 0, lx
        do 920 m1 = -il, il
          dum = coni * m1 * (xphi(i,j)-pi)
          if (k.eq.1) dum = -dum
          dum = exp( dum )
          do 910 m2 = -il, il
            if (k.eq.1) then
              drix(m2,m1,il,k,j,i) = drix(m2,m1,il,k,j,i) * dum
            else
              drix(m1,m2,il,k,j,i) = drix(m1,m2,il,k,j,i) * dum
            endif
 910       continue
 920     continue

      return
c  end subroutine rotxan
      end
c====================================================================
c#mn{
       subroutine rotint
       implicit real (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c        include 'xstruc.h'
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c#mn{
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/
c#mn}

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/

c  end of xstruc.h
c********************************************************************
c initialize /rotsav/
       jsav = 0
       do 100 js = 1, jsavx
          betsav(js) = jbmagk
          ldsav(js)  = 0
          mdsav(js)  = 0
          do 90 il  = 0, lx
             do 80 m1 = -lx, lx
                do 70 m2 = -lx, lx
                   drisav(m2,m1,il,js) = 0
 70             continue
 80          continue
 90       continue
 100   continue
       return
c#mn}
       end
      subroutine sortat(iph0, nat, npot, iphat, iphx, rat, xrat)

      implicit real (a-h,o-z)
      implicit integer (i-n)
c--------------------------------------------------------------------
c  this subroutine sorts the atoms in xrat such that the first npot
c  entries are each a representative atom of a unique potential.  This
c  will mean that the upper left corner of the full MS matrix will
c  contain all of the information needed to compute the fine structure
c  and all of the electron densities.
c  NOTA BENE:  the atoms *must* have already been sorted by radial
c    distance!
c--------------------------------------------------------------------
c  input:
c    iph0:    potential index for central atom in LDOS (added by ala)
c                (iph0=0 for absorbing atom as the central atom)
c     nat:    number of atoms in cluster
c    npot:    number of unique potentials in cluster
c    iphat:   (nclusx) potential index of each atom in cluster as read
c             from geometry file
c    rat:     (3, nclusx) coordinates of each atom in cluster as read
c             from geometry file
c  output:
c    iphx:    (nclusx) potential index of each atom in cluster sorted
c             so that the first npot+1 entries are examples of each
c             ipot
c    xrat:    (3, nclusx) coordinates of each atom in cluster sorted
c             so that the first npot+1 entries are examples of each
c             ipot
c--------------------------------------------------------------------

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
      dimension rat(3,natxx), xrat(3,nclusx)
      integer   iphat(natxx), iphx(nclusx), ipoint
      dimension ipoint(0:nphasx)
      integer iph0, ip, ilast

      do 10 i=0,nphasx
        ipoint(i) = 0
 10   continue
      do 30 ic=1,nat
        iphx(ic) = iphat(ic)
        do 20 ix=1,3
          xrat(ix,ic) = rat(ix,ic)
 20     continue
 30   continue

c     (iph0=0 for absorbing atom as the central atom)
      if (iphx(1).ne.iph0) then
          call wlog('* * * ERROR in sortat * * *')
          call wlog('            The first atom in xrat is not '//
     $                'the central atom.')
          call wlog('            Complain to Bruce immediately!')
          call par_stop('SORTAT-1')
      endif

c       if (idbg(4).eq.1) print*,'SORTAT: nat,npot: ',nat,npot
c       if (idbg(4).eq.1) print*,'SORTAT: xcen,ycen,zcen: ',
c      $            xcen,ycen,zcen

c --- find the example of each unique potential that is closest to the
c     central atom.  This will presumably be well within the cluster
c     that was used to compute the overlapped potentials
      ipoint(iph0) = 1
      do 150 ip=0,npot
        if (ip .ne. iph0) then
          do 130 iat=2,nat
            if (iphx(iat).eq.ip .and. ipoint(ip).eq.0) then
                ipoint(ip) = iat
c                print*,'>>>>> ip, ipoint(ip)', ip, ipoint(ip)
            endif
 130      continue
        endif
 150  continue

c --- now swap the first few atoms with the atoms found above
      do 200 ip=0,npot

c ----- some potentials might not be in the xanes cluster
        if (ipoint(ip).eq.0) goto 200
c ----- don't swap two potentials if examples live in the first npot
c       entries
        if (ipoint(ip).le.ip+1) goto 200

        xx  = xrat(1,1+ip)
        yy  = xrat(2,1+ip)
        zz  = xrat(3,1+ip)
        iph = iphx(1+ip)

        xrat(1,1+ip) = xrat(1,ipoint(ip))
        xrat(2,1+ip) = xrat(2,ipoint(ip))
        xrat(3,1+ip) = xrat(3,ipoint(ip))
        iphx(1+ip)  = iphx(ipoint(ip))

        xrat(1,ipoint(ip)) = xx
        xrat(2,ipoint(ip)) = yy
        xrat(3,ipoint(ip)) = zz
        iphx(ipoint(ip))  = iph

c       added by ala
c       check that substituted atom was not some ip example
c          ???BR Jan 16 1998???
        do 190 ipp = ip+1, npot
          if (ipoint(ipp).eq.ip+1) ipoint(ipp) = ipoint(ip)
  190   continue
c       set the correct pointer to ip example
        ipoint(ip) = ip+1

 200  continue

c     added by ala
c     Notice that fms will take the last atom of given type ip
c     from first npot atoms in the list as an example for ip.
c     Make more permutaions if necesary.
      ilast = -1
      nmin = min (npot+1, nat)
      do 210 ip = 0, npot
        if (ipoint(ip).ne.0) then
          do 205 iat = 1,nmin
  205     if (iphx(iat).eq.ip) ilast = iat

          if (ilast.ne.ipoint(ip)) then
            xx  = xrat(1,ilast)
            yy  = xrat(2,ilast)
            zz  = xrat(3,ilast)

            xrat(1,ilast)= xrat(1,ipoint(ip))
            xrat(2,ilast)= xrat(2,ipoint(ip))
            xrat(3,ilast)= xrat(3,ipoint(ip))

            xrat(1,ipoint(ip)) = xx
            xrat(2,ipoint(ip)) = yy
            xrat(3,ipoint(ip)) = zz
c           now ipoint(ip) = ilast, but don't need ipoint anymore
          endif
        endif
  210 continue

c       if (idbg(4).eq.1) then
c           do 220 i=1,npot+1
c             print *,i,xrat(1,i),xrat(2,i),xrat(3,i),iphx(i)
c  220      continue
c       endif
      return
c  end subroutine sortat
      end
      subroutine xanlm(lmaxp1,mmaxp1)

c------------------------------------------------------------------
c  calculate and store all of the legendre polynomial normalization
c  factors needed in the problem
c     xnlm= sqrt ((2l+1)(l-m)!/(l+m)!)
c  see, for instance, Arfken section 12.6.  Note that this lacks the
c  factor of sqrt(4*pi)
c
c  inputs:
c     lmaxp1, nmaxp1:  maximun l and m considered in the problem +1
c                      i.e. lmaxp1 = l_max+1
c
c  outputs:
c     all normalization factors passed in common /xnlm/
c------------------------------------------------------------------

      implicit real(a-h,o-z)
c       parameter(ltot=6,mtot=3)

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c       include 'xstruc.h'
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/

c  end of xstruc.h
c********************************************************************

      common/afctr/afac,flzero,flg(0:50)
c      common/afctr/afac,flzero,flg(0:210)
c      common/afctr/afac,flzero,flg(0:110) vax change

      call xfctst
      do 50 il=1,lmaxp1
        mmxp1 = min(mmaxp1,il)
        do 40 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(m,l) = cnlm

 40     continue
 50   continue
      return
c  end subroutine xlm
      end


      subroutine xfctst
c  same as feff's factst, but with a different name
      implicit real (a-h,o-z)
c     program for s3j and s6j symbols obtained from
c     steve younger of n.b.s.   modified by j.b.mann
c--------------------------------------------------------------------
c     a set to 1/64 to prevent overflow on vax
c     range on  flg set to 0:210, rather than flg(210)
c--------------------------------------------------------------------
cBR   This allows calculation of a large factorial (~100) without
cBR   overflow problems -- factor in a power of a small number then
cBR   factor it out
c--------------------------------------------------------------------
      common /afctr/ a, flzero, flg(0:50)
c      common /afctr/ a, flzero, flg(0:210)
      a=0.03125
c     a=0.015625
      flzero = 1.0
      flg(0) = 1.0
      flg(1) = a
      do 10 i=2,50
        flg(i) = flg(i-1) * i * a
 10   continue
      return
      end



c====================================================================
      subroutine yprep(iph0, nat, inclus, npot, iphat, rmax, rat,
     $            izx, rdirec)
c    yprep is the same as xprep for negative idwopt
c    simlifies calls in SCF and LDOS where DW factors should not enter

      implicit real (a-h,o-z)
      implicit integer (i-n)

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparam.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclusx*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparam.h}
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/
c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/

c  end of xstruc.h
c********************************************************************
      parameter(zero=0.e0)
      parameter (bohr = 0.529 177 249e0)
      integer   iphat(natxx), iphat2(natxx), izx(0:nphasx), izpair(0:2)
      dimension rat(3,natxx), rat2(3,natxx)
      double precision ra(natxx)
      character*78 line
c     sigms is written in double precision.  these are the variables
c     that it uses
      double precision dtemp, dthet, drs, dsigsq, pair(3,0:2)
      double precision sig2mx, sig2x(0:nphx,0:nphx)
c     iwarn - needed to wrtite waqrning just one time
      integer iwarn
      save iwarn
      data  iwarn /0/

c  initialize geometrical arrays
      do 30 i=1,nclusx
        do 10 j=1,nclusx
          xphi(j,i) = zero
 10     continue
        do 20 j=1,3
          xrat(j,i) = zero
 20     continue
        iphx(i) = 0
 30   continue
      inclus = 0

c --- find the central atom, ipot=iph0 (iph0=0 for the absorbing atom)
      icen = 0
      do 40 i=1,nat
        iphat2(i) = iphat(i)
        if (iphat(i).eq.iph0) then
            if (icen.eq.0) then
                icen = i
            elseif (iph0.eq.0) then
                call wlog('* * * ERROR!  More than one atom '//
     $                      'in the extended cluster have ipot=0')
                call wlog('      You may only have one central atom.')
                call wlog('      Stopping in xprep.')
                call par_stop('YPREP-1')
            endif
        endif
 40   continue
c --- make sure central atom is at (0,0,0)
      do 45 i=1,nat
        rat2(1,i) = rat(1,i)-rat(1,icen)
        rat2(2,i) = rat(2,i)-rat(2,icen)
        rat2(3,i) = rat(3,i)-rat(3,icen)
 45   continue

c --- sort the atoms from extended cluster by distance from central
c     atom.
      call atheap(nat, rat2, iphat2, ra)

c --- define cluster from extended cluster by as those closer than
c     rmax to central atom
      inclus=0
      rmax2 = rmax**2
      do 50 i=1,nat
        rr = (rat2(1,i)**2 + rat2(2,i)**2 + rat2(3,i)**2)
        if (rr.gt.rmax2) then
            inclus = i-1
            goto 60
        endif
 50   continue
 60   continue
      if (inclus.eq.0) inclus=nat

c --- sanity check size of cluster
      if (inclus.gt.nclusx) then
        if (iwarn.eq.0) then
          call wlog('* * * WARNING preparing cluster for '//
     $                'FMS calculation.')
          write(line,400) inclus
 400      format('      You specified a cluster of ', i3,
     $                ' atoms for the FMS calculation.')
          call wlog(line)
          write(line,410)nclusx
          call wlog(line)
 410      format('      This exceeds the hard wired limit of ', i3,
     $                ' atoms.')
          write(line,420)nclusx
          call wlog(line)
 420      format('      The cluster size was reset to ', i3,
     $                ' and the calculation will continue.')
          iwarn = 1
        endif
        inclus = nclusx
      endif

c --- make the first few entries in xrat represent each of the
c     unique potentials, sorting around the chosen center
c     (iph0=0 for the absorbing atom)
c     call sortat(iph0, inclus, npot, iphat2, iphx, rat2, xrat)
      do 430 iat = 1, inclus
          iphx(iat) = iphat2(iat)
          xrat(1,iat) = real (rat2(1,iat))
          xrat(2,iat) = real (rat2(2,iat))
          xrat(3,iat) = real (rat2(3,iat))
 430  continue


c --- Calculate and store rotation matrix elements and phi angles
c     the k loop calculates the forward then the backward rotation
c     for an atom pair (ij). k = 0-->forward, 1-->backward
      call rotint
      lplus1 = lx+1
      mplus1 = lx+1
      do 150  i=1,inclus
        do 140 j=1,inclus
          rr = (xrat(1,i)-xrat(1,j))**2 + (xrat(2,i)-xrat(2,j))**2
     1       + (xrat(3,i)-xrat(3,j))**2
c         if (rr.gt.rdirec**2) goto 140

          call getang(nclusx, xrat, i, j, xbeta, xphi(i,j))
          if (i.eq.j) goto 140
          do 130 k=0,1
            if (k.eq.1) xbeta = (-1) * xbeta
            call rotxan(lplus1, mplus1, xbeta, i, j, k)
 130      continue
 140    continue
 150  continue

c --- calculate spherical harmonic normalization factors
      call xanlm(lplus1,mplus1)

      do 200 iat2=1,nclusx
      do 200 iat1=1,nclusx
        sigsqr(iat1,iat2) = zero
 200  continue

      return
      end
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c

c     sub-program exchange
!     program  ffmod4
      subroutine ffmod4

c     makes paths list using cluster geometry and phase shifts
c     written by a.ankudinov 2000 using earlier subroutines
c     written by s.zabinsky
c     modified by a.ankudinov 2001 for new I/O structure

c     INPUT FILES
c       global.dat, geom.dat - global infomation file is read here 
c       mod4.inp - specific information for present module
c       phase.bin - output of XSPH module is read using subroutine 
c                  'rdxsph' inside subroutine 'prcrit'.
c                   needed  data: (list of variables)
c                  (ne, ne1, npot, ik0, em, eref2, potlbl, ph4)
c     OUTPUT FILE
c       paths.dat - list of filtered paths

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

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

      
      dimension lmaxph(0:nphx), rat(3,natx), iphat(natx), ibounc(natx)
      double precision evec(3), xivec(3)
      character*6  potlbl(0:nphx)
        integer  mpath, ms, nncrit, nlegxx, ipr4
        real critpw, pcritk, pcrith,  rmax, rfms2

      integer eels !KJ added 5/06
      character*30 fname

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:nphx,necrit), ckspc(necrit)
      real fbeta(-nbeta:nbeta,0:nphx,nex), cksp(nex)
      real xlamc(necrit), xlam(nex)

      call par_begin
      if (worker) go to 400
      
c     open the log file, unit 11.  See subroutine wlog.
      open (unit=11, file='log4.dat', status='unknown', iostat=ios)
      call chopen (ios, 'log4.dat', 'feff')

c     INPUT: read geom.dat, global.dat, mod4.inp
      call repath (ms, mpath, ipr4,  pcritk, pcrith, nncrit, rmax,
     1             nlegxx, rfms2, critpw,
c                  geom.dat
     2             nat, rat, iphat, ibounc,
c                  global.dat
     3             ipol, ispin, evec, xivec ,eels) !KJ added eels 5/06
       if (nspx.gt.1) ispin = abs(ispin)

      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 (ipr4 .ge. 3 .and. ipr4.ne.5)  then
            do 260  iph = 0, 1
               do 250  ie = 1, nncrit
                  write(fname,200)  ie, iph
  200             format ('fbeta', i1, 'p', i1, '.dat')
                  open (unit=1, file=fname, status='unknown')
                  write(1,210)  iph, ie, ckspc(ie)
  210             format ('# iph, 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,iph,ie)/ckspc(ie),
     2                  fbetac(ibeta,iph,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, critpw,
     1               nncrit, rmax, nlegxx, rfms2,
     2               nat, rat, iphat, ibounc) 
         call wlog(' Eliminating path degeneracies...')
         call pathsd (ckspc, fbetac, xlamc, ne, ik0, cksp, 
     1                fbeta, xlam, critpw, ipr4, nncrit, potlbl,
     1            ipol, ispin, evec, xivec,eels) !KJ added eels 5/06
         call wlog(' Done with module 4: pathfinder.')
      endif
      close (unit=11)

  400 call par_barrier
      call par_end

c     sub-program exchange
!     stop
      return

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

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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      logical lheap, lkeep
      dimension ipat(npatx)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:nphx,necrit), ckspc(necrit)
      dimension xlamc(necrit), iclus(0:natx)

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.
         goto 999
      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.

c     If path is entirely inside a cluster do not keep it
  999 nclus=0
      do 700 i=1,npat
  700 nclus=nclus+iclus(ipat(i))
      if (nclus.eq.0) lkeep = .false.

      return
      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 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)  call par_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)  call par_stop('nmax .gt. 8 in upack')

      n = mod (iout(1), ifac1)
      if (n .gt. nmax)  call par_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 mcrith (npat, ipat, ri, indbet,
     1                   ipot, nncrit, fbetac, ckspc, xheap)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension ipat(npatx)
      dimension ri(npatx+1), indbet(npatx+1)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:nphx,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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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:nphx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

cc    xcalcx is max xcalc encountered so far.  Set to -1 to reset it --
cc    otherwise it gets passed in and out as mcritk gets called.
c     calculation of xcalcx changed by ala. It is calculated only
c     a first call, i.e. for the NN SS path, and is not recalculated

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 (xcalcx.le.0)  xcalcx = xcalc
      xout = 100 * xcalc / xcalcx
      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

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,
     1                   ipol, ispin, evec, xivec,ica)   !KJ added ica 5/06

c     make path parameters,  xp, yp,zp for each atom for a given
c     path. The allowed symmetry operations are restricted by
c     polarization type ipol (evec, xivec) and spin type (ispin)
c     of calculations
c      ipol=0 - polarization average 
c      ipol=1 - linear (admixture of 2 linear for elpty.ne.0)
c      ipol=2 - circular dichroism
c      ispin=0 - spin-independent system V_up=V_dn=V_av
c      |ispin|=1 - V_up .ne. V_dn, sum over up and down calculations
c      ispin= 2 - V_up portion of |ispin|=1 
c      ispin=-2 - V_dn portion of |ispin|=1 
c    all possible cases fall into 7 categories of allowed symmetries
c    Spin-independent calculations 
c     1) IF ipol=0 
c        any path rotation, reflection and reversal are allowed
c     2) ELSEIF ispin=0 ipol=1  xivec.eq.0 (dipole transitions only)
c        any rotation around evec, reflections in planes normal
c        and parallel to evec, path reversal
c     3) ELSEIF ispin=0 ipol=1   xivec.ne.0
c        reflections in 2 planes (xivec, evec) and (xivec, B field)
c        reflection in (evec, B field) probably does not conserve
c        E1-E2 cross term (currently used; check and fix later)
c     4) ELSEIF ispin=0 ipol=2  
c        rotations around xivec, path reversal (? -check for XNCD)
c    Spin systems (only ispin.ne.0, ipol.ne.0 below)
c     5) ELSEIF  xivec(1)=xivec(2)=0 .and. ( ipol.eq.2 .or. 
c                 ( ipol.eq.1 .and.xivec(3)=evec(1)=evec(2)=0 ) )
c        rotations around spin axis
c     6) ELSEIF ipol=1 xivec(1)=xivec(2)=evec(3)=0 (XMLD)
c        only 180 degrees rotation around spin axis
c     7) ELSE   ipol=1,2 .and. (xivec(1).ne.0 or xivec(2).ne.0 )
c        NO symmetry operations
c    Disclaimer: the symmetry rules for might be
c    too restrictive and were checked for ipol=2 calculations (case=5)
c    One can always check the symmetry rules by comparing with case=7.

c    To exploit above symmetry, every path is recorded in a new frame of
c    reference, constructed for the calculations specified.

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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      double precision evec(3), xivec(3)
      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)
      logical lkvec, lkz, lez
      integer ica !KJ new input parameter. overrides icase if positive.

      parameter (eps4 = 1.0E-4)

c     the atoms in this path are passed via the ipat and rat arrays


      if (ica.gt.0.and.ica.lt.8) then !KJ added this and next 2 lines
!KJ Purpose : for eels calculations, we want a result for many k and q.
!KJ This means we cannot use the symmetry operations.
         icase=ica
      else
      
c        determine which case we are dealing with (see above comments)
c        default is icase =7 - no symmetry at all (safe for untested cases)
c        logical lkvec answers whether xivec is a vector
         lkvec = .false.
         if (xivec(1)**2+xivec(2)**2+xivec(3)**2.gt.eps4) lkvec = .true.
c        logical lkz answers whether xivec is a vector along z at most
         lkz = .true.
         if (xivec(1)**2+xivec(2)**2.gt.eps4) lkz = .false.
c        logical lez answers whether evec is a vector along z at most
         lez = .true.
         if (evec(1)**2+evec(2)**2.gt.eps4) lez = .false.

         icase = 7
         if (ipol.eq.0) then
           icase = 1
         elseif (ispin.eq.0) then
           if (ipol.eq.1 .and. (.not.lkvec)) icase = 2
           if (ipol.eq.1 .and. lkvec) icase = 3
           if (ipol.eq.2) icase=4
         else
           if (ipol.eq.2 .and. lkz) icase = 5
           if (ipol.eq.1 .and. .not.lkvec  .and. lez) icase = 5
           if (ipol.eq.1 .and. lkz .and. evec(3)**2.lt.eps4) icase = 6
         endif

 
       endif  !KJ my block. 5/06


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
         yvec(i) = 0
         zvec(i) = 0
   40 continue

      if (icase.eq.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
      elseif (icase.eq.2 .or. icase.eq.3) then
c        z-axis in direction of polarization
         do 120 i = 1, 3
           zvec(i) = evec(i)
  120    continue
      else 
c        keep z-axis
         zvec(3) = 1.d0
      endif

      do 160 j = 1,npat
      do 160 i = 1, 3
        zp1(j) = zp1(j) + zvec(i)*ri(i,j)
  160 continue
c     if no symmetries, don't waste time
      if (icase.eq.7) then
         xvec(1) = 1.d0
         yvec(2) = 1.d0
         goto 390
      endif

      if (icase.eq.1 .or. icase.ge.4) goto 240
c     use z-->-z symmetry 
      num = 1
  200 continue
      if (abs(zp1(num)) .gt. eps4) then
         if (zp1(num) .lt. 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     z--> -z symmetry has been used
  240 continue

c     use rotations around z and reflections containing z
      num = 1
  300 continue
      ro2 = 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 (icase.eq.1.or.icase.eq.2.or.icase.eq.4.or.icase.eq.5) then
c           any rotation around z is allowed
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
         elseif (icase.eq.3) then
c           if elliptical polarization then
c           choose x-axis along incident beam
            do 350 i =1, 3
               xvec(i) = xivec(i)
  350       continue
         else
c           icase.eq.6 choose x-axis so that x-coord is positive
            xvec(1) = 1.d0
            if (ri(1,num).lt.0) xvec(1) = -1.d0
         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 (icase.eq.3) then
c        check that first nonzero  x-coordinate is positive,
c        no need to check it in other cases.
         num = 1
  500    continue
         if (abs(xp1(num)) .ge. eps4) then
            if (xp1(num) .lt. 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

      if (icase.ge.4) goto 590
      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) 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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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)
c#mn
       external sdist

      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, 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension ipat(npatx)
      dimension ipot(0:natx)
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:nphx,necrit), ckspc(necrit)
      dimension fbeta(-nbeta:nbeta,0:nphx,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 repath ( ms, mpath, ipr4, pcritk, pcrith, nncrit, rmax,
     1             nlegxx, rfms2, critpw,
     2             nat, rat, iphat, ibounc,
     3             ipol, ispin, evec, xivec ,eels)  !KJ added eels 5/06

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

cc    geom.dat
        integer  nat, iatph(0:nphx), iphat(natx), ibounc(natx)
        double precision  rat(3,natx)
cc    global.dat 
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    mod4.inp
        integer  mpath, ms, nncrit, nlegxx, ipr4
        real critpw, pcritk, pcrith,  rmax, rfms2
	
	integer eels !KJ added 5/06


c     Local stuff
      character*512 slog
      character*80 head(nheadx)
      dimension lhead(nheadx)

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)


c     Read  geom.dat file
      open (file='geom.dat', unit=3, status='old',iostat=ios)
c       read header from geom.dat
        nhead = nheadx
        call rdhead (3, nhead, head, lhead)
        nat = 0
        nph = 0
        do 40 iph = 0, nphx
  40    iatph(iph) = 0
  50    continue
         nat = nat+1
         if (nat .gt. natx)  then
           write(slog,55) ' nat, natx ', nat, natx
           call wlog(slog)
  55       format(a, 2i10)
           stop 'Bad input'
         endif
         read(3,*,end=60) idum,(rat(j,nat),j=1,3),iphat(nat),ibounc(nat)
         if (iphat(nat).gt.nph) nph = iphat(nat)
         if ( iatph(iphat(nat)).eq.0) iatph(iphat(nat)) = nat
        goto 50
  60    continue
        nat = nat-1
      close(3)

cc    global.inp
      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c       configuration average data
        read  (3, 10) slog
        read  (3, 65) nabs, iphabs, rclabs
  65    format ( 2i8, f13.5)
c       global polarization data
        read  (3,10)   slog
        read  (3, 70)  ipol, ispin, le2, elpty, angks
  70    format ( 3i5, 2f12.4)
        read  (3, 10) slog
        do 80 i = 1,3
          read  (3,30) evec(i), xivec(i), spvec(i)
  80    continue
        read  (3, 10) slog
        do 90 i = -1, 1
          read (3,30) a1, b1, a2, b2, a3, b3
          ptz(-1,i)= cmplx(a1,b1)
          ptz(0,i) = cmplx(a2,b2)
          ptz(1,i) = cmplx(a3,b3)
  90    continue
      close(3)
c     read mod4.inp
      open (file='mod4.inp', unit=3, status='old',iostat=ios)
        read (3,10)  slog
        read (3,20)  mpath, ms, nncrit, nlegxx, ipr4
        read (3,10)  slog
        read (3,30)  critpw, pcritk, pcrith,  rmax, rfms2
      close(3)
      
c  !KJ Next section added to read EELS variables       5-06
c     read eels.inp
      eels=0
      open(file='eels.inp',unit=3,status='old',err=900)
        read(3,*,err=900,end=900) 
	read(3,20,err=900,end=900) eels
      close(3)
      goto 901
900   continue
      eels=0
901   continue
c  !KJ end my changes 
      

      return
      end
      subroutine paths (ckspc, fbetac, xlamc, pcritk, pcrith, critpw,
     1                  nncrit, rmax, nlegxx, rfms,
     2                  nat, ratdp, iphat, ibounc)

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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:nphx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

c     This common in pathsd, mpprm
      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)
      double precision ratdp(3,natx)
      integer  iphat(natx), ibounc(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 = 6000 000)
c     r also used in making m matrix, must have nx >= natx+1
      integer   index(nx), npx, np, n, ip, i, iat0, idum
c     parameter (npx = 100 000)
      parameter (npx = 100000000)
      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     to remmember atoms outside rfms
      dimension iclus(0:natx) 

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

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

      character*80  title

c     Returned from criterion checker, false if path fails criterion
      logical keep
      character*512 slog

      external sdist

c     transform to single precision for pathfinder
c     also count in pathfinder starts with 0, not with 1
      do 15 iat = 1, nat
        j = iat-1
        do 10 i = 1, 3
          rat(i, j) = real (ratdp(i,iat))
 10     continue
        ipot(j) = iphat(iat)
        i1b(j) = ibounc(iat)
 15   continue
      nat = nat - 1

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
c     ratx is distance to most distant atom, used to check rmax
      ratx = 0
      iat0 = -1
      i1b(0) = 0

c     find index for the central atom
      do 20 iat = 0, nat
         if (ipot(iat).eq.0 .and. iat0.lt.0) iat0=iat
   20 continue

c     iclus = 0 for atoms inside rfms cluster, 1 for atoms outside
      do 21 iat = 0,nat
        rtmp = sdist(rat(1,iat),rat(1,iat0))
        if (rtmp.gt.rfms) iclus(iat)=1
        iclus(iat)=0
        if (rtmp.gt.rfms) iclus(iat)=1
   21 continue

      if (iat0.ne. 0) then
c       permute atoms 0 and iat0
c       do not need to permute i1b, since all of them are 1 in
c       this case, except i1b(0) = 0, which we want to keep.
        do 25 j=1,3
          temp = rat(j,0)
          rat(j,0) = rat(j,iat0)
          rat(j,iat0) = temp
   25   continue
        idum = ipot(0)
        ipot(0) = ipot(iat0)
        ipot(iat0) = idum
        idum = iclus(0)
        iclus(0) = iclus(iat0)
        iclus(iat0) = idum
      endif

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) 
     .  call par_stop('At least one 1st bounce atoms required.')

      if (rmax .ge. big)  call par_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, critpw
   32 format('PATH  Rmax=', f6.3, ',  Keep_limit=', f5.2,
     1       ', Heap_limit', f5.2,'  Pwcrit=', f5.2, '%')

      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     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, ipot,
     2    r(n), keep, keep1(ip), xcalcx, iclus)

      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
c     temporary fix for zero title lines: fix later
      nhead = 1
      write(3) nhead
      write(3) 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,
     2                  ipot, r(1), keep, keep1(ip), xcalcx, iclus)
         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,
     2                  ipot, rtmp, keep, kp1tmp, xcalcx, iclus)
            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, ')')

c     restore the value of rmax
      rmax = rmax/2

      end
      subroutine pathsd (ckspc, fbetac, xlamc, ne, ik0, cksp, 
     1                fbeta, xlam, critpw, ipr2,  nncrit, potlbl,
     1            ipol, ispin, evec, xivec,eels)  !KJ added eels 5/06

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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 = 600 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)

      integer eels !KJ 5/06 - just passed on to timrep
      character*80 head(nheadx)
      character*6  potlbl(0:nphx)
      double precision xivec(3), evec(3)

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:nphx,necrit), ckspc(necrit)
      real fbeta(-nbeta:nbeta,0:nphx,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)
   40 continue
c     Header lines above include carriage control
      read(3)  nat
c     rat and ipot could be permuted by paths.f
      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
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
            ii = istrln(head(ihead))
            write(1,58)  head(ihead)(1:ii)
   58       format(a)
   60    continue
c        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
              ii = istrln(head(ihead))
            write(4,58)  head(ihead)(1:ii)
   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)
               call par_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),
     1            ipol, ispin, evec, xivec,eels)  !KJ added eels 5/06

  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,
     1            ipol, ispin, evec, xivec,eels) !KJ added eels 5/06

         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,
     1            ipol, ispin, evec, xivec,eels) !KJ added eels 5/06
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
               call par_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                ipot,
     1                xport, xheap, xheapr, xkeep, xcalcx)

         if (xportx*ndegx .le. 0)  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
c 600 format (1x, i5, f12.6, i7, ' igs, rcurr, nupr')
c     write(80,601)  ngs, rcurr/2, nupr, nuprtt
c 601 format (1x, i8, f12.6, 2i9)

      if (.not. last) goto 100

  999 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).')
      call par_stop('User must verify very large run.')
      endif
      return
c 999 stop 'no input'
      end
      subroutine phash (npat, ipat, rx, ry, rz, dhash)
c     hashes a path into double precision real dhash

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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
      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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      character*6  potlbl
      dimension  potlbl(0:nphx)

c     staff originally kept in common blocks of pdata.h
      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
      dimension ph( nex, ltot+1, 0:nphx), eref(nex), em(nex),
     1 lmax(nex,0:nphx), iz(0:nphx)

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

c     Local variables
      complex*16 cfbeta, tl, cktmp
      dimension dcosb(-nbeta:nbeta)
      dimension pl(ltot+1)
      dimension iecrit(necrit)
      parameter (eps = 1.0e-16)
      complex*16 rkk(nex,8,nspx), eref2(nex,nspx)
      complex*16 ph4(nex, -ltot:ltot, nspx, 0:nphx)

c     Need stuff from phase.bin
c     Read phase calculation input, data returned via commons
      call rdxsph (ne, ne1, ne3, npot, ihole,
     1    rnrmav, xmu, edge, ik0, em, eref2, iz, potlbl, ph4, rkk,
     2    lmax, lmaxp1  )
 
      do 10 ie = 1, ne
  10  eref(ie) = eref2(ie,1)
      do 20 iph = 0, npot
      do 20 ie = 1, ne
      do 20 il = 0, lmax(ie, iph)
  20  ph(ie,il+1, iph) = ph4(ie, -il, 1, iph)

      neout = ne1
      ik0out = ik0
      do 40  i = 0, nphx
         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
         cktmp = sqrt (2*(em(ie) - eref(ie)))
         cksp(ie) = dble (cktmp) / bohr
c        xlam code lifted from genfmt
         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) call par_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 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
      subroutine timrep (npat, ipat, rx, ry, rz, dhash,
     1            ipol, ispin, evec, xivec,eels)   !KJ added eels 5/06

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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      double precision evec(3), xivec(3)
      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)
      integer eels,icase  !KJ added 5/06

      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

!KJ next block : prepare new calling argument for mpprmp
      if(eels.eq.1) then
         icase=7
      else
         icase=-1
      endif
!KJ end new block. 5/06


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,
     1            ipol, ispin, evec, xivec,icase)   !KJ added icase 5/06
      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,
     1            ipol, ispin, evec, xivec,icase)  !KJ added icase 5/06
      call phash (npat, ipat0, rx0, ry0, rz0, dhash0)

c     turn off path reversal in special cases (make dhash0>dhash)
      if (ispin.ne.0 .and. ipol.ne.0) dhash0 = dhash+1

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
c///////////////////////////////////////////////////////////////////////
c Distribution:  GENFMT 2.0
c Copyright (c) [2002] University of Washington
c 
c This software was prepared in part with US Government Funding under
c DOE contract DE-FG03-97ER45623.

c Redistribution and use of this Distribution in source and binary
c formats, with or without modification is permitted, provided the 
c following conditions are met:
c 
c Redistributions must retain the above notices and the following list
c of conditions and disclaimer;
c 
c Modified formats carry the marking
c     "Based on or developed using Distribution: GENFMT 2.0
c      GENFMT 2.0 Copyright (c) [2002] University of Washington"
c 
c Recipient acknowledges the right of the University of Washington to
c prepare uses of this Distribution and its modifications that may be
c substantially similar or functionally equivalent to
c Recipient-prepared modifications.
c
c Recipient and anyone obtaining access to the Distribution through
c recipient's actions accept all risk associated with possession and
c use of the Distribution.
c
c THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
c WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
c MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
c IN NO EVENT SHALL THE UNIVERSITY OF WASHINGTON OR CONTRIBUTORS TO THE
c DISTRIBUTION BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
c EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
c PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
c REVENUE; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
c LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
c NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
c SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c     sub-program exchange
!     program ffmod5
      subroutine ffmod5

c     scattering F-matrix multiplication for each MS path
c     written by a.ankudinov 2000, using subroutines
c     which were written earlier by j.rehr and others
c     modified by a.ankudinov 2001 for new I/O structure

c     INPUT: phase.bin, paths.dat, mod5.inp and global.dat
c     OUTPUT: feff.bin and list.dat files
      implicit double precision (a-h, o-z)

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
      double precision evec(3), xivec(3)
      complex*16 ptz(-1:1, -1:1)
      integer  mfeff, ipr5, iorder
      logical  wnstar
      double precision critcw, angks, elpty
      integer elnes,ipstep,ipmin,ipmax  !KJ added these variables 1-06


      call par_begin
      if (worker) go to 400

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

c                 read  mod5.inp 
      call regenf(mfeff, ipr5, critcw, iorder, wnstar,
c                 and global.dat
     1            ipol, ispin, le2, angks, elpty, evec, xivec, ptz,
     2            elnes,ipmin,ipmax,ipstep)   !KJ added this line    1-06     
      if (nspx.gt.1) ispin = abs(ispin)

      if (mfeff .eq. 1)  then
         call wlog(' Calculating EXAFS parameters...')
         call genfmt (ipr5, critcw, iorder, wnstar,
     1                ipol, ispin, le2, angks, elpty, evec, xivec, ptz,
     2            elnes,ipmin,ipmax,ipstep)   !KJ added this line    1-06     
         call wlog(' Done with module 5: F_eff.')
      endif
      close (unit=11)

 400  call par_barrier
      call par_end

c     sub-program exchange
!     stop
      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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={nlm.h
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c= nlm.h}
c={lambda.h
c     common /lambda/  
c    4   mlam(lamtot), 	!mu for each lambda
c    5   nlam(lamtot),	!nu for each lambda
c    1   lamx, 		!max lambda in problem
c    2   laml0x, 	!max lambda for vectors involving absorbing atom
c    3   mmaxp1, nmax 	!max mu in problem + 1, max nu in problem
      common /lambda/ mlam(lamtot), nlam(lamtot), lamx, laml0x,
     1                mmaxp1, nmax
c= lambda.h}
c={clmz.h
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c= clmz.h}
c={fmatrx.h
      complex*16 fmati
      common /fmatrx/ fmati(lamtot,lamtot,legtot)
c= fmatrx.h}
c={rotmat.h
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c= rotmat.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}

      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
         ll = il - 1
c        do j-average t-matrix
         tl = (exp(2*coni*ph(ie,-ll,ipot(ilegp))) - 1) / (2*coni)
         tltl = (exp(2*coni*ph(ie,ll,ipot(ilegp))) - 1) / (2*coni)
         tltl = tl * (ll+1) + tltl * ll
         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 genfmt (ipr3, critcw, iorder, wnstar,
     1                ipol, ispin, le2, angks, elpty, evec, xivec, ptz,
     2            elnes,ipmin,ipmax,ipstep)   !KJ added this line  1-06     
      implicit double precision (a-h, o-z)

c  altered by matt newville (jan 1999): 
c  format of feff.bin changed to packed-ascii, and all writes changed.
c  altered by alex ankudinov(feb 2000); disabled use of paths in LDOS.
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/vers.h
      character*12 vfeff
c                       123456789012  
      parameter (vfeff='Feff 8.50')
c= ../HEADERS/vers.h}
c={clmz.h
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c= clmz.h}
c={fmatrx.h
      complex*16 fmati
      common /fmatrx/ fmati(lamtot,lamtot,legtot)
c= fmatrx.h}
c={lambda.h
c     common /lambda/  
c    4   mlam(lamtot), 	!mu for each lambda
c    5   nlam(lamtot),	!nu for each lambda
c    1   lamx, 		!max lambda in problem
c    2   laml0x, 	!max lambda for vectors involving absorbing atom
c    3   mmaxp1, nmax 	!max mu in problem + 1, max nu in problem
      common /lambda/ mlam(lamtot), nlam(lamtot), lamx, laml0x,
     1                mmaxp1, nmax
c= lambda.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}
c={nlm.h
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c= nlm.h}
c={rotmat.h
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c= rotmat.h}
      integer elnes,ipmin,ipmax,ipstep  !KJ added variables 1-06      
      dimension evec(3), xivec(3)
      complex*16 ptz
      dimension ptz(-1:1, -1:1), lind(8)

      complex*16  rho(legtot), pmati(lamtot,lamtot,2)
      complex*16  pllp, ptrac, srho, prho, cfac
      complex*16  cchi(nex)
      complex*16  rkk(nex,8)
      complex*16  rkk2(nex,8,nspx)
      complex*16  eref2(nex,nspx), ph4, bmati
      dimension   ph4(nex,-ltot:ltot, nspx, 0:nphx)
      dimension   bmati(-mtot:mtot, 8, -mtot:mtot, 8)
      dimension   xk(nex), ckmag(nex)
      complex*16  ck(nex), ckp
      dimension   ffmag(nex)
      dimension   eps1(3), eps2(3), vec1(3), vec2(3)

      character*128 string
      character*512 slog
      logical done, wnstar
      
      integer ip !KJ local index that I added 1-06
      character*10 f1,f2 !KJ variable for opening feff.bin files - filename
      

c      padlib staff
       double precision phff(nex), amff(nex),  xkr(nex)
       integer  mpadx
       parameter (mpadx = 8)
       character*75 wfmt, atsym*2
       external atsym, cwig3j, istrln

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)
       external getxk, xstar
       
c     Read phase calculation input, data returned via commons
       call rdxsph (ne, ne1, ne3, npot, ihole, rnrmav, xmu, edge, ik0,
     1              em, eref2, iz, potlbl, ph4, rkk2, lmax, lmaxp1)
       call setkap (ihole, kinit, linit)
       ilinit = linit + 1

c
c      need to sum over spin-up and -down for |ispin|=1 (fix later)
       nsp = 1
       if (ispin.eq.1) nsp = nspx

       if (nsp.eq.1) then
c        for ispin=2 the variables already written into is=1 positions
         is = 1
         do 10 ie = 1, ne
  10     eref(ie) = eref2(ie,is)
         do 20 iph = 0, npot
         do 20 ie = 1, ne
         do 20 il = -lmax(ie, iph), lmax(ie, iph)
  20     ph(ie,il, iph) = ph4(ie, il, is, iph)
       else
c        average over two spin direction
         do 12 ie = 1, ne
  12     eref(ie) = (eref2(ie,1) + eref2(ie,nsp)) /2
!KJ  12     eref(ie) = (eref2(ie,1) + eref2(ie,2)) /2
         do 22 iph = 0, npot
         do 22 ie = 1, ne
         do 22 il = -lmax(ie, iph), lmax(ie, iph)
  22     ph(ie,il, iph) =(ph4(ie, il, 1,iph) + ph4(ie, il, nsp,iph)) /2
!KJ  22     ph(ie,il, iph) =(ph4(ie, il, 1,iph) + ph4(ie, il, 2,iph)) /2
       endif

c!KJ added loop over ip for ELNES calculations.  1-06
      do ip=ipmin,ipmax,ipstep
	    if (elnes.eq.1) call iniptz(ptz,ip,2)  !KJ Only change ptz for ELNES !!
            !KJ the call to iniptz changes the polarization matrix ptz
c           !KJ choose different filename for each spectrum.
            if(ip.eq.1) then
	      f1(1:10)='feff.bin  '
	      f2(1:10)='list.dat  '
	    elseif(ip.eq.10) then
	      f1(1:10)='feff10.bin'
	      f2(1:10)='list10.dat'
	    elseif(ip.gt.1.and.ip.lt.10) then
	      f1(1:5)='feff0'
	      f1(6:6)= char(48+ip)
	      f1(7:10)='.bin'
	      f2(1:5)='list0'
	      f2(6:6)= char(48+ip)
	      f2(7:10)='.dat'
	    else
	      stop 'crazy ip in ff2xmu'
	    endif
          !KJ the rest of this loop follows the old (non-elnes) scheme
       write(*,*) 'doing ip = ',ip



c     Open path input file (unit in) and read text .  Use unit 1.
       ntext  = 5
       open (unit=1, file='paths.dat', status='old', iostat=ios)
       call chopen (ios, 'paths.dat', 'genfmt')
       call rdhead (1, ntext , text, ltext)
       if (ntext  .le. 0)  then
          text (1) = ' '
       endif
c
c     Save indices of paths for use by ff2chi
c     Save indices of paths for use by ff2chi
       open (unit=2, file=f2, status='unknown', iostat=ios) !KJ changed 'list.dat' to f2
       call chopen (ios, f2, 'genfmt') !KJ id.  1-06
c     Put phase header on top of list.dat
       call wthead (2, ntext , text )
       write(2, 125)
 125   format (1x, 71('-'))
       write(2, 135)
 135   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,'(1x,a,f8.4)' ) ' polarization', evec
          write(4,'(1x,a)' ) ' 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, 155) critcw
 155   format ('    Curved wave chi amplitude ratio', f7.2, '%')
       call wlog(slog)
       if (ipr3 .le. 0)  then
         write(slog,165) crit0
         call wlog(slog)
       endif
 165   format ('    Discard feff.dat for paths with cw ratio <',
     1         f7.2, '%')
       write(slog,195)
 195   format ('    path  cw ratio     deg    nleg  reff')
       call wlog(slog)

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
c!KJ replaced by next lines      open (unit=3, file='feff.bin', status='unknown', iostat=ios)
c!KJ idem      call chopen (ios, 'feff.bin', 'genfmt')
      open (unit=3, file=f1, status='unknown', iostat=ios) !KJ f1  1-06
      call chopen (ios, f1 , 'genfmt') !KJ introduced f1
c     put label line in feff.bin so other programs know it really
c     is a feff.bin file
       string = '#_feff.bin v03: ' // vfeff
       jstr   = istrln(string)
       write(3, '(a)')  string(1:jstr)

c     save stuff that is the same for all paths
c     header, ck, central atom phase shifts
       write(3, '(a2,6(1x,i4))') '#_',
     $      npot, ne, mpadx

c     Misc stuff from phase.bin and genfmt call
 345   format(a2,3(1x,i7), 3(1x,g14.7))
       write(3, 345) '#&', ihole, iorder, ilinit, rnrmav, xmu, edge
       do 380 i = 0, npot
          if (potlbl(i).eq.' ') potlbl(i)  = atsym(iz(i))
          if (potlbl(i).eq.' ') potlbl(i)  = 'null'
 380   continue 
 395   format('(',i3,'(1x,a6),',i3,'(1x,i3))')
       write(wfmt, 395) npot+1, npot+1
       write(string,wfmt) (potlbl(i),i=0,npot) , (iz(i),i=0,npot)
       jstr = istrln(string)
       write(3, '(a2,a)') '#@',string(:jstr)

c     Central atom phase shifts
      ll = linit+1
      if (kinit.lt.0) ll = -ll
      call wrpadx(3,mpadx, ph(1,ll, 0),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 850  ie = 1, ne
c        real momentum (k)
         xk(ie) = getxk (dble(em(ie)) - edge)
c        complex momentum (p)
         ck(ie) = sqrt (2*(em(ie) - eref(ie)))
         ckmag(ie) = abs(ck(ie))
         xkr(ie) = real(xk(ie))
 850   continue
       call wrpadx(3,mpadx, ck,ne)
       call wrpadd(3,mpadx, xkr,ne)
         
c     While not done, read path, find feff.
       npath  = 0
       ntotal = 0
       nused  = 0
       xportx = -1
 1000  continue

c        Read current path
         call rdpath (1, done, ipol)
         icalc = iorder
         if (.not.done)  then
            npath = npath + 1
            ntotal = ntotal + 1
            if (wnstar)  then
c              should be ipol=1
               do 1150 ic =1,3
                  vec1(ic) = rat(ic,1) - rat(ic,0)
                  vec2(ic) = rat(ic,nleg-1) - rat(ic,0)
                  eps1(ic) = evec(ic)
 1150          continue
               if (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, elpty)
               write(4,'(1x,i6,f10.3)')  npath, xxstar
            endif
            
c        Need reff
         reff = 0
         do 1200  i = 1, nleg
            reff = reff + ri(i)
 1200    continue 
         reff = reff/2

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

c        Calculate and store rotation matrix elements
         do 1300  isc = 1, nleg
            call rot3i (lmaxp1, mmaxp1, isc)
 1300    continue
         if (ipol.gt.0)  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 

c        Start cycle over spin
         do ie = 1, ne
           cchi(ie) = 0
         enddo
         do is = 1, nsp
           if (nsp.eq.1) then
             call mmtr(bmati, ipol, ispin, le2, angks, ptz, lind)
           else
             call mmtr(bmati, ipol, is, le2, angks, ptz, lind)
           endif
           do 110 ie = 1, ne
 110       eref(ie) = eref2(ie,is)
           do 120 iph = 0, npot
           do 120 ie = 1, ne
           do 120 il = -lmax(ie, iph), lmax(ie, iph)
 120       ph(ie,il, iph) = ph4(ie, il, is, iph)
           do 130 ie = 1, ne
           do 130 kdif = 1, 8
 130       rkk(ie,kdif) = rkk2(ie,kdif,is)
           do 140 ie = 1, ne
 140       ck(ie) = sqrt (2* (em(ie) - eref(ie)))
c
c        Big energy loop
         do 5000  ie = 1, ne
c           complex rho
            do 2010  ileg = 1, nleg
               rho(ileg) = ck(ie) * ri(ileg)
 2010       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) = cchi(ie) + 0
               write(slog,2055)  ie, ck(ie)
 2055          format (' genfmt: ck=0.  ie, ck(ie)', i5, 1p, 2e14.5)
               call wlog(slog)
               goto 4990
            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
c           zero clmi arrays
            do 2100  ileg = 1, legtot
               do 2100 im = 1, mtot+ntot+1
                  do 2100  il = 1, ltot+1
                     clmi(il,im,ileg) = 0
 2100       continue
            mnmxp1 = mmaxp1 + nmax
            do 2150  ileg = 1, nleg
               isc0 = ileg-1
               if (isc0.eq.0) isc0=nleg
               isc1 = ileg
               lxp1 = max (lmax(ie,ipot(isc0))+1, lmax(ie,ipot(isc1))+1)
               mnp1 = min (lxp1, mnmxp1)
               call sclmz (rho, lxp1, mnp1, ileg)
 2150       continue

c           Calculate and store scattering matrices fmati.
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 2200  ilegp = 2, nsc-1
               ileg = ilegp + 1
               call fmtrxi (lamx, lamx, ie, ileg, ilegp)
 2200       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 calculate the trace over lambda_N, working from
c           right to left.
c           Use only 2 pmati arrays, alternating indp (index p)
c           1 and 2.

c           to start f(2,1) -> pmat(1)
            indp = 1
            do 2250 lmp = 1, laml0x
            do 2250 lm = 1, lamx
               pmati(lm,lmp,indp)= fmati(lm,lmp,1)
 2250       continue

c           f(N,N-1) * ... * f(3,2) * [f(2,1)]
c           Term in [] is pmat(1)
            do 2900 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 2850  lmp = 1, laml0x
               do 2850  lm = 1, lamx
                  pllp=0
                  do 2800 lmi = 1, lamx
                     pllp = pllp +
     1                    fmati(lm,lmi,isc)*pmati(lmi,lmp,indp0)
 2800             continue
 2850             pmati(lm,lmp,indp) = pllp
 2900       continue

c           srho=sum pr(i), prho = prod pr(i)
            srho=0
            prho=1
            do 3200  ileg = 1, nleg
               srho = srho + rho(ileg)
               prho = prho * rho(ileg)
 3200       continue

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, lind)

c           Final trace over matrix
            ptrac=0
            do 4400  lm = 1, laml0x
            do 4400  lmp = 1, laml0x
               ptrac = ptrac + fmati(lm,lmp,nleg) * pmati(lmp,lm,indp)
 4400       continue

c           Calculate xafs
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)
            if (nsp.eq.2 .and. is.eq.1) cfac = -cfac
            cchi(ie) = cchi(ie) + ptrac * cfac
c       write(7,5) xk(ie), -12*dimag(cchi(ie)*exp(coni*2*xk(ie)*reff))
c  5         format (3f13.5)

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

 5000    continue
c        end of energy loop
         enddo
c        end of loop over spins


c        Make importance factor, deg*(integral (|chi|*d|p|))
c        make ffmag (|chi|)
c        xport   importance factor
         do 6810  ie = 1, ne1
            if (nsp.eq.2) then
              eref(ie) = (eref2(ie,1) + eref2(ie,nsp)) /2
!KJ              eref(ie) = (eref2(ie,1) + eref2(ie,2)) /2
              ck(ie) = sqrt (2* (em(ie) - eref(ie)))
            endif
            ckp = ck(ie)
            xlam0 = dimag(ck(ie)) - dimag(ckp)
            ffmag(ie) = abs( cchi(ie) * exp(2*reff*xlam0) )
 6810    continue

c        integrate from edge (ik0) to ne
         nemax = ne1 - ik0 + 1
         call trap (ckmag(ik0), ffmag(ik0), nemax, xport)
         xport = abs(deg*xport)
         if (xportx.le.0)  xportx = xport
         crit = 100 * xport / xportx
c       use line below to disable importance factor (e.g. for dichroism)
c        crit = crit0+1

c        Write path data to feff.bin if we need it.
         if (ipr3 .ge. 1  .or.  crit .ge. crit0)  then
c           write path info
 7225       format('(i6,1x,i3,1x,f7.3,1x,f11.7,1x,e15.4,',i3,'(1x,i2))') !KJ  1-06
c 7225       format('(i6,1x,i3,1x,f7.3,1x,f11.7,1x,f9.4,',i3,'(1x,i2))') !KJ original code
            write(wfmt, 7225) nleg
            write(string,wfmt) ipath, nleg, deg, reff*bohr,
     $           crit, (ipot(i),i=1, nleg)
            jstr = istrln(string)
            write(3,'(a2,a)') '##',string(:jstr)
            call wrpadd(3,mpadx, rat(1,1),3*nleg)
            call wrpadd(3,mpadx, beta,nleg)
            call wrpadd(3,mpadx, eta,nleg)
            call wrpadd(3,mpadx, ri,nleg)
            phffo = 0
            do 7700  ie = 1, ne
               phff(ie) = 0
               if (abs(cchi(ie)) .ge. eps) then
                  phff(ie) = atan2 (dimag(cchi(ie)),
     $                 dble(cchi(ie)))
               end if

c  remove 2 pi jumps in phase
               if (ie.gt.1) call pijump (phff(ie), phffo)
               phffo    = phff(ie)
               amff(ie) = dble(abs(cchi(ie)))
 7700       continue
            call wrpadd(3,mpadx, amff,ne)
            call wrpadd(3,mpadx, phff,ne)
   
c           Put feff.dat and stuff into list.dat
c           zero is debye-waller factor column
            write(2,8215) ipath, zero, crit, deg, nleg, reff*bohr
c 8215       format(1x, i8, f12.5, 2f10.3, i6, f9.4) !KJ original code
 8215       format(1x, i8, f12.5, e15.4, f10.3, i6, f9.4) !KJ  1-06
 
c           Tell user about the path we just did
            write(slog, 8225) ipath, crit, deg, nleg, reff*bohr
c 8225       format (3x, i4, 2f10.3, i6, f9.4) !KJ original code
8225       format (3x, i4, e15.4, f10.3, i6, f9.4) !KJ    1-06
            call wlog(slog)
            nused = nused+1
         else
c           path unimportant, tell user
            write(slog, 8235) ipath, crit, deg, nleg, reff*bohr
 8235       format (3x, i4, 2f10.3, i6, f9.4, ' neglected')
            call wlog(slog)
         endif
c  goto next path
         goto 1000
c  done with loop over paths
       end if
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,'(1x,i4,a,i4,a)') nused,' paths kept, ',
     $     ntotal,' examined.'
       call wlog(slog)
       
       
       enddo  !KJ end of new loop over ptz tensor "do ip = ..."
              
       return
       end
      subroutine mmtr( bmati, ipol, ispin, le2, angks, ptz, lind)
c     calculates the part of matrix M which does not depend on energy
c     point.( see Rehr and Albers paper)
c     for path expansion always neglect spin-flip processes
c     to simplify calculations; (bmati does not have spin indices)

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

c     all commons are inputs
c     Inputs from common:
c        kinit: quantum number kappa for initial orbital
c        rotation matrix for ilegp
c        path data, eta(ilegp) and ipot(ilegp)
c        mtot,l0
c        polarization data : ipol, ispin, ptz
c     Output:  bmati(...) 

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={rotmat.h
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c= rotmat.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}
      complex*16 ptz
      dimension ptz(-1:1, -1:1)

      complex*16 bmati, bmat
      dimension bmati(-mtot:mtot, 1:8, -mtot:mtot, 1:8)
      dimension bmat(-lx:lx,0:1,8, -lx:lx,0:1,8)
      dimension kind(8), lind(8)
      logical ltrace

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

      ltrace = .false.
      call bcoef (kinit, ipol, ptz, le2, ltrace, ispin, angks,
     1            kind, lind, bmat)
      is = 0
      if (ispin.eq.1) is = nspx - 1

c     ilinit = initial orb. momentum + 1. 
      lxx = min(mtot,ilinit)

c     set indices for bmati (no indentation)
      do 60 mu1 = -lxx,lxx
      mu1d = mu1+mtot+1
      do 50 mu2 = -lxx,lxx
      mu2d = mu2+mtot+1
      if (ipol.ne.0) then
        do 40 k1 = 1,8
        do 40 k2=  1,8
          l1 = lind(k1) + 1
          l2 = lind(k2) + 1
          do 35 m1 = -lind(k1), lind(k1)
          do 35 m2 = -lind(k2), lind(k2)
            m1d = m1 + mtot+1
            m2d = m2 + mtot+1
            bmati(mu1,k1, mu2,k2) =bmati(mu1,k1, mu2,k2) +
     1      bmat(m1,is,k1,m2,is,k2)*exp(-coni*(eta(nsc+2)*m2+eta(0)*m1))
     1        * dri(l1,mu1d,m1d,nsc+2) * dri(l2,m2d,mu2d,nleg)
c           dri(nsc+2)  is angle between z and leg1
c           dri(nsc+1)  is angle between last leg and z
c           eta(0)      is gamma between eps and rho1,
c           eta(nsc+2)  is alpha between last leg and eps
   35     continue
   40   continue
      else
c       ipol=0 and bmat is diagonal in k1,k2 and LS L'S'
c       and 2 rotation matrices can be combined to 1
        do 140 k1 = 1,8
          l1 = lind(k1) + 1
          if (l1.gt.0) then
            m1 = 0
            m1d = m1 + mtot+1
            bmati(mu1,k1, mu2,k1) =bmati(mu1,k1, mu2,k1) +
     1        bmat(m1,is,k1,m1,is,k1) * dri( l1, mu1d, mu2d, nsc+1)
c           dri(nsc+1)  is angle between last leg and first leg
          endif
  140   continue
      endif
   50 continue
   60 continue

      return
      end
      subroutine mmtrxi ( rkk, lam1x, bmati, ie, ileg, ilegp, lind)
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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={nlm.h
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c= nlm.h}
c={lambda.h
c     common /lambda/  
c    4   mlam(lamtot), 	!mu for each lambda
c    5   nlam(lamtot),	!nu for each lambda
c    1   lamx, 		!max lambda in problem
c    2   laml0x, 	!max lambda for vectors involving absorbing atom
c    3   mmaxp1, nmax 	!max mu in problem + 1, max nu in problem
      common /lambda/ mlam(lamtot), nlam(lamtot), lamx, laml0x,
     1                mmaxp1, nmax
c= lambda.h}
c={clmz.h
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c= clmz.h}
c={fmatrx.h
      complex*16 fmati
      common /fmatrx/ fmati(lamtot,lamtot,legtot)
c= fmatrx.h}
c={rotmat.h
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c= rotmat.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}

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

c     calculate factors gam and gamtl
 
c     set limits for orbital momentum
      lmn = ltot
      lmx = 0
      do 10 k1 = 1,8
        if (lind(k1).gt.lmx) lmx = lind(k1)
        if (lind(k1).lt.lmn .and. lind(k1).ge.0) lmn = lind(k1)
  10  continue
      iln = lmn + 1
      ilx = lmx + 1
 
      do 30  il = iln, ilx
         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
            fmati(lam1,lam2,ilegp) = 0.0d0

            do 40 k1 = 1, 8
            do 40 k2 = 1, 8
               l1 = lind(k1) + 1
               l2 = lind(k2) + 1
               if (l1.gt.0.and.l2.gt.0 .and. iam1.le.l1.and.iam2.le.l2) 
     1           fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp) +
     2           bmati(m1,k1, m2,k2) * rkk(ie,k1) * rkk(ie,k2) *
     3           gam( l1, iam1, in1) * gamtl( l2, iam2, in2)
   40       continue
            fmati(lam1,lam2,ilegp) = fmati(lam1,lam2,ilegp) *
     1      exp(-coni*eta(ileg)*m1)
   50    continue
   60 continue

      return
      end
      subroutine rdpath (in, done, ipol)
      implicit double precision (a-h, o-z)
      logical done

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}

      complex*16  alph, gamm
      dimension  alpha(0:legtot), gamma(legtot)
      character*512 slog
c#mn
       external dist

      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 (ipol.gt.0) 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 (ipol.gt.0) 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 (ipol.gt.0) 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 (ipol.gt.0) 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')
      call par_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 regenf (mfeff, ipr5, critcw, iorder, wnstar,
     1            ipol, ispin, le2, angks, elpty, evec, xivec, ptz,
     2            elnes,ipmin,ipmax,ipstep)   !KJ added this line   1-06     

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      
      integer elnes,ipmin,ipmax,ipstep  !KJ added these variables 1-06      

cc    global.dat 
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    mod5.inp
        integer  mfeff, ipr5, iorder
        logical  wnstar
        double precision critcw

c     Local stuff
      character*512 slog

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)

cc    read global.inp
      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c       configuration average data
        read  (3, 10) slog
        read  (3, 45) nabs, iphabs, rclabs
  45    format ( 2i8, f13.5)
c       global polarization data
        read  (3,10)   slog
        read  (3, 50)  ipol, ispin, le2, elpty, angks
  50    format ( 3i5, 2f12.4)
        read  (3, 10) slog
        do 60 i = 1,3
          read  (3,30) evec(i), xivec(i), spvec(i)
  60    continue
        read  (3, 10) slog
        do 70 i = -1, 1
          read (3,30) a1, b1, a2, b2, a3, b3
          ptz(-1,i)= cmplx(a1,b1)
          ptz(0,i) = cmplx(a2,b2)
          ptz(1,i) = cmplx(a3,b3)
  70    continue
      close(3)
c     read mod5.inp
      open (file='mod5.inp', unit=3, status='old',iostat=ios)
        read (3,10)  slog
        read (3,180)  mfeff, ipr5, iorder, critcw, wnstar
  180   format ( 2i4, i8, f13.5, L5)
      close(3)


c  !KJ Next section added to read ELNES variables     1-06  
c     read eels.inp
      elnes=0
      open(file='eels.inp',unit=3,status='old',err=900)
        read(3,*,err=900,end=900) 
	read(3,20,err=900,end=900) elnes
        read(3,*,err=900,end=900)
        read(3,*,err=900,end=900)
	read(3,*,err=900,end=900)
	read(3,20,err=900,end=900) ipmin,ipstep,ipmax
      close(3)
      goto 901
900   continue
      elnes=0
901   continue
      if(elnes.eq.0) then
        ipstep=1
	ipmax=1
	ipmin=1
      endif
               
c  !KJ end my changes

      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={rotmat.h
      save /rotmat/
      common /rotmat/ dri(ltot+1,2*mtot+1,2*mtot+1,legtot+1)
c= rotmat.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}
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 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={clmz.h
      save /clmz/
      complex*16 clmi
      common /clmz/ clmi(ltot+1,mtot+ntot+1,legtot)
c= clmz.h}

      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
      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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={lambda.h
c     common /lambda/  
c    4   mlam(lamtot), 	!mu for each lambda
c    5   nlam(lamtot),	!nu for each lambda
c    1   lamx, 		!max lambda in problem
c    2   laml0x, 	!max lambda for vectors involving absorbing atom
c    3   mmaxp1, nmax 	!max mu in problem + 1, max nu in problem
      common /lambda/ mlam(lamtot), nlam(lamtot), lamx, laml0x,
     1                mmaxp1, nmax
c= lambda.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}
      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)
         call par_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) call par_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)
         call par_stop('setlam')
      endif

      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={nlm.h
      save /nlm/
      common /nlm/ xnlm(ltot+1,mtot+1)
c= nlm.h}

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.

      flg(0) = 1
      flg(1) = afac

      do 10  i = 2, 210
   10 flg(i) = flg(i-1) * i * afac

      return
      end
      double precision function xstar (eps1,eps2, vec1,vec2, ndeg,elpty)
      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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={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 arrays 
      character*80 text 
      character*6  potlbl
c     text from paths.dat, potential labels
      common /str/ text (5), potlbl(0:nphx)

      complex*16 ph, eref, em
      double precision rnrmav, xmu, edge
c     common /pdata/ ph(nex,-ltot:ltot,0:nphx), !complex phase shifts ipot=0
c    1 eref(nex),		!complex energy reference
c    1 rat(3,0:legtot+1),	!position of each atom, code units(bohr)
c    1 em(nex),		!energy mesh
c    1 ri(legtot), beta(legtot+1), eta(0:legtot+1), !r, beta, eta for each leg
c    1 deg, rnrmav, xmu, edge,	!(output only)
c    1 lmax(nex,0:nphx),	!max l with non-zero phase for each energy
c    1 ipot(0:legtot),	!potential for each atom in path
c    1 iz(0:nphx),	!atomic number (output only)
c    1 ltext (5),	!length of each string
c    1 nsc, nleg,	!nscatters, nlegs (nleg = nsc+1)
c    1 npot, ne,	!number of potentials, energy points
c    1 ik0,		!index of energy grid corresponding to k=0 (edge)
c    1 ipath, ihole, 	!index of current path  and hole (output only)
c    1 kinit, linit, ilinit,  ! initial state kappa and ang. mom.
c    1 lmaxp1,	!largest lmax in problem + 1
c    1 ntext 	!number of text  lines

      common /pdata/ ph(nex,-ltot:ltot,0:nphx), eref(nex), em(nex),
     1 rat(3,0:legtot+1),  
     1 ri(legtot), beta(legtot+1), eta(0:legtot+1),
     1 deg, rnrmav, xmu, edge, lmax(nex,0:nphx), ipot(0:legtot),
     1 iz(0:nphx), ltext (5),
     1 nsc, nleg, npot, ne, ik0, ipath, ihole, 
     1 kinit, linit, ilinit,
     1 lmaxp1, ntext 
c= pdata.h}
      dimension eps1(3), eps2(3), vec1(3), vec2(3)

      lfin = ilinit
      x = xxcos(vec1, vec2)
      iav = 1
      y = xxcos(eps1,vec1)
      z = xxcos(eps1,vec2)
      xtemp = ystar(lfin, x, y, z, iav)
      if (elpty .ne. 0.0) then
        y = xxcos(eps2,vec1)
        z = xxcos(eps2,vec2)
        xtemp = xtemp + elpty**2 * ystar(lfin, x, y, z, iav)
      endif
      xstar = ndeg * xtemp /(1+elpty**2)

      return
      end

      double precision function xxcos (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
      xxcos = 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
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c     sub-program exchange
!     program ffmod6
      subroutine ffmod6 (iabs)

c     final calculations for various spectroscopies
c     (EXAFS, XANES, FPRIME, DANES, XES)
c     written by a.ankudinov 2000
c     modified by a.ankudinov 2001 for new I/O structure

c     INPUT: mod6.inp global.dat xsect.bin fms.bin list.dat and feff.bin
c     OUTPUT: xmu.dat (chi.dat for EXAFS)

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

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
      integer elnes,ipmin,ipmax,ipstep  !KJ my variables 1-06 
      integer absolu !KJ 3-06     


      call par_begin
      if (worker) go to 400

c     sub-program exchange
!     iabs = 1
      

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

c     read  input files
      call reff2x(mchi, ispec, ipr6, idwopt, critcw, s02, sig2g,
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 3-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line 1-06     

      if (mchi .eq. 1)  then
         call wlog(' Calculating chi...')
         if (ispec.gt.0 .and. ispec.lt.3) then 
c           using FMS+Paths method
            call ff2xmu (ispec, ipr6, idwopt, critcw, s02, sig2g, 
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 3-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line  1-06     
         elseif (ispec.eq.3 .or. ispec.eq.4) then 
c           using FMS+Paths method
            call ff2afs ( ipr6, idwopt, critcw, s02, sig2g, 
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 4-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line 4-06     
         else
c           using MS Paths expansion
            call ff2chi (ispec, ipr6, idwopt, critcw, s02, sig2g, 
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 3-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line 1-06     
         endif
         call wlog(' Done with module 6: DW + final sum over paths.')
      endif
      close (unit=11)

  400 call par_barrier
      call par_end
      
c     sub-program exchange
!     stop  
      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
         call par_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 feffdt(ntotal,iplst,nptot,ntext,text,ne,npot,
     $      ihole, iorder, l0, rnrmav, xmu, edge, potlbl,
     $      iz,phc,ck,xk,index,
     $      nleg,deg,nepts,reff,crit,ipot,rat,achi,phchi)
c
c     writes feffnnnn.dat files and files.dat 
c     for compatibility with the old feff
c
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/vers.h
      character*12 vfeff
c                       123456789012  
      parameter (vfeff='Feff 8.50')
c= ../HEADERS/vers.h}
      parameter (eps4 = 1.0e-4)
      parameter (eps = 1.0e-16)

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

c     Stuff from feff.bin, note that floating point numbers are
c     single precision
cc      character*78 string
      real rnrmav, xmu, edge
cc      dimension ltext(nheadx)
      character*80 text(nheadx)
      character*6  potlbl(0:nphx)
      dimension iz(0:nphx)
c     central atom phase shift at l0
      complex phc(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)
cc      real beta(legtot,npx)
cc      real eta(legtot,npx)
cc      real ri(legtot,npx)
      real achi(nex,npx), phchi(nex,npx)
       integer istrln
       complex*16 cchi, cfms
       external istrln

       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
      do 20  itext = 1, ntext
         ltxt = istrln(text(itext))
c        text(itext) does not have carriage control
         call wlog (' ' // text(itext)(1:ltxt))
   20 continue

      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
         ltxt = istrln( text(itext))
         write(2,160)  text(itext)(1:ltxt)
  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
            ltxt = istrln(text(itext))
            write(3,160)  text(itext)(1:ltxt)
  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*hart
  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 ff2afs (ipr4, idwopt, critcw, s02, sig2g,
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 4-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line  4-06
c     calculate anomalous scattering amplitude for a given edge
c     Writes down main output: chi.dat and xmu.dat
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (eps4 = 1.0e-4)
      integer ipmin,ipmax,ipstep,elnes !KJ my variables  4-06    
      integer absolu !KJ 4-06  


c     header from list.dat
      dimension lhead(nheadx)
      character*80  head(nheadx)
      complex*16 gtr(nex),gtrful(ipmin:ipmax,nex) !KJ added gtrful 4-06

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

      complex*16 cchi(nex), ckp
c     to keep Im part of cchi 11.18.97 ala
      dimension rchtot(nex), xkp(nex)
      complex*16 chia(nex)

      logical dwcorr
      character*512 slog
      character*2 coment
      parameter (coment='# ')

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.
      real rnrmav, xmu, edge
      character*80 title(nheadx), titfms
      character*6  potlbl(0:nphx)
      dimension iz(0:nphx)
c     central atom phase shift at l0
      complex phc(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), beta(legtot,npx), eta(legtot,npx)
      real ri(legtot,npx)
      real achi(nex,npx), phchi(nex,npx)

c     stuff from xsect.bin
      complex*16 emxs(nex), xsec(nex)
      dimension omega(nex), xkxs(nex), xsnorm(nex), fpp(nex)
      
c !KJ locals  1-06
      integer iip,nip
      logical cross 
      character*9 f1,f2
      character*10 f0,f3
      complex*16 gtrtemp(nex*(1+ipmax-ipmin))
      complex*16 kxsec(nex)     
c !KJ end my variables




c     get gtr - result of FMS
      do 112 ie =1,nex
      gtr(ie)= 0
      do 112 iip =ipmin,ipmax  !KJ I added this variable ip 1-06
  112 gtrful(iip,ie) = 0
      ntfms = 0
      nip=ipmax-ipmin+1 !KJ 1-06
      
      open (unit=1, file='fms.bin', status='old', iostat=ios)
      if (ios.le.0) then
         ntfms = 1
         read(1, 113) titfms
  113    format(a)
         read(1, 115) ne, ne1, ne3, nph, npadx
  115    format(5(1x,i3))
         call rdpadx(1, npadx, gtrtemp, ne*nip)  !KJ I added *nip, changed gtr to gtrtemp  1-06
      endif
      close (unit=1)
!KJ Next lines my addition to read several spectra at once. 1-06
	i=1
	do iip=ipmin,ipmax
	do j=1,ne
        gtrful(iip,j)=gtrtemp(i+j-1)
	enddo
	  i=i+ne
	enddo
!KJ Now we don't need gtrtemp anymore.  End my changes



c !KJ loop over iip added to process several spectra at once  4-06
c !KJ reading of feff.bin and list.dat moved inside the loop (used to be before reading
c !KJ xsect.bin      
      do iip=ipmin,ipmax,ipstep
        cross=(.not.(iip.eq.1.or.iip.eq.10.or.iip.eq.5.or.iip.eq.9))
      
c !KJ choose different filename for each spectrum.
        if(iip.eq.1) then
	  f1(1:9)='chi.dat  '
	  f2(1:9)='xmu.dat  '
	  f0(1:10)='feff.bin  '
	  f3(1:10)='list.dat  ' 	  
	elseif(iip.eq.10) then
	  f1(1:9)='chi10.dat'
	  f2(1:9)='xmu10.dat'
	  f0(1:10)='feff10.bin'
	  f3(1:10)='list10.dat'	  
	elseif(iip.gt.1.and.iip.lt.10) then
	  f1(1:4)='chi0'
	  f1(5:5)= char(48+iip)
	  f1(6:9)='.dat'
	  f2(1:4)='xmu0'
	  f2(5:5)= char(48+iip)
	  f2(6:9)='.dat'
	  f0(1:5)='feff0'
	  f0(6:6)= char(48+iip)
	  f0(7:10)='.bin'	
	  f3(1:5)='list0'
	  f3(6:6)= char(48+iip)
	  f3(7:10)='.dat'
	else
	  stop 'crazy iip in ff2xmu'
	endif
	do i=1,nex
	gtr(i)=gtrful(iip,i)
	enddo
!KJ


c     open list.dat and read list of paths we want
      open (unit=1, file= f3, status='old', iostat=ios)!KJ changed 'list.dat' to f3 1-06
      ntotal = 0
      if (ios.le.0) then
        call chopen (ios, f3, 'ff2afs')  !KJ id.
        nhead = nheadx
        call rdhead (1, nhead, head, lhead)
c       skip a label line
        read(1,*)
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
      endif
      close (unit=1)


c     lines below allow to skip FMS module for DANES 
c     after XANES calculations
      open (unit=1, file='phase.bin', status='old', iostat=ios)
      if (ios.le.0) then
        read(1,*) ne3, ne3, ne3, ne3
      endif
      close (unit=1)

       call rdfbin (f0, nphx, nex, npx, legtot,   !KJ changed 'feff.bin' to f0  4-06
     $     nptot, ne, npot, ihole, iorder, ilinit, 
     $     rnrmav, xmu, edge, potlbl, iz, phc, ck, xk,
     $     index, nleg, deg, reff,
     $     crit, ipot, rat, beta, eta, ri, achi, phchi)

c     read xsect.bin file
      call  rdxbin (s02p, erelax, wp, edgep, s02, gamach, ne1, ik0,
     2  emxs, omega, xkxs, xsnorm, xsec, nxsec, mbconv, title, ntitle)
cc !!KJ these comments copied from ff2chi and not necessarily relevant  4-06.
c !KJ I have put rdxbin inside the loop since omega is 'recycled' below,
c !KJ which is a problem if the loop executes more than once.
c !KJ Simply reading the file again and again is the lazy solution,
c !KJ but it avoids confusing changes to the code (eg., new variables).



c     make combined title
      if (ntfms.eq.1) then
        ntitle = ntitle + 1
        title(ntitle) = titfms
      endif
      do 120 ihead = 1, nhead
  120 title(ntitle+ihead) = head(ihead)
      ntitle = ntitle + nhead

c     write feffnnnn.dat
      if (ipr4.eq.3) then
         call feffdt(ntotal,ip,nptot,ntitle,title,ne,npot,
     $        ihole, iorder, ilinit, rnrmav, xmu, edge, potlbl,
     $        iz,phc,ck,xk,index,
     $        nleg,deg,nepts,reff,crit,ipot,rat,achi,phchi)
       end if

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) then
         do 180  ie = 1, ne
            ckp = sqrt (ck(ie)**2 + 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     k'**2 = k**2 + vr. If there is no real correction
c     (vrcorr = 0), these two grids will be the same.
c           k' is value for output,  k is  value used for
c           interpolations with original grid.

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

c     ik0 is index at fermi level
      do 250  i = 1, ne
         temp = xk(i)*abs(xk(i)) + 2*vrcorr
         if (temp.ge. 0) then
           xkp(i) = sqrt(temp)
         else
           xkp(i) = - sqrt(-temp)
         endif
  250 continue
     

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

c     Open chi.dat and xmu.dat (output) and start headers
      if (iabs.eq.nabs) then
         open (unit=3, file=f1, status='unknown', iostat=ios) !KJ changed chi.dat to f1
         call chopen (ios, f1, 'ff2afs') !KJ id.  4-06
         open (unit=8, file=f2, status='unknown', iostat=ios) !KJ changed xmu.dat to f2
         call chopen (ios, f2, 'ff2afs') !KJ id.

c        write miscellaneous staff into headers  !KJ corrected typo
         call wrhead (8, ntitle, title, dwcorr, s02,
     1     tk, thetad, sig2g, alphat, vrcorr, vicorr, critcw)

c        also write information on the screen
         if (alphat .gt. zero)  then
            write(slog,322) alphat
  322       format ('    1st and 3rd cumulants, alphat = ', 1pe20.4)
            call wlog(slog)
         endif
         if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
            write(slog,343) vrcorr*hart, vicorr*hart
  343       format ('    Energy zero shift, vr, vi ', 1p, 2e14.5)
            call wlog(slog)
         endif

         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
  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)
      endif


c     make chi and sum it
      do 400  i = 1, nex
         cchi(i) = 0
  400 continue
      do 402  ik = 1, ne
         cchi(ik)= s02 * gtr(ik)
  402 continue
c     add correction due to vicorr
      if (vicorr.gt.eps4) then
         call conv(omega,cchi,ne1,vicorr)
c        call conv(omega,xsec,ne1,vicorr)
      endif


c     add Debye-Waller factors
      ispec = 3
      call dwadd (ntotal, nptot, idwopt, ip, index, crit, critcw, sig2g,
     1  sig2u, dwcorr, rnrmav, nleg, deg, reff, iz, ipot, rat,tk,thetad,
     2  alphat, thetae, mbconv, s02, ne1, ck, achi, phchi, ne, xk, xkp,
     3  xkp, cchi, iabs, nabs, ispec, ipr4, ntitle,
     4  title, vrcorr, vicorr,  nused)

c     read or initialize chia - result of configuration average
      if (iabs.eq.1) then
         do 635 ie =1, nex
            chia(ie) = 0
  635    continue
      else
         open (unit=1, file='chia.bin', status='old',
     1   access='sequential', form='unformatted', iostat=ios)
         do 640 ie = 1,ne
  640    read(1) chia(ie)
         close (unit=1, status='delete')
      endif

      if(iabs.eq.1) then
c        compare grids in xsect.bin and feff.bin
         do 680 i = 1, nxsec
           del = xk(i)**2 - xkxs(i)**2
           if (abs(del) .gt.  10*eps4)  then
             call wlog(' Emesh in feff.bin and xsect.bin different.')
c            stop 
           endif
  680    continue
      endif

c     add contribution from an absorber iabs 
c     present scheme assumes that xsec is the same for all iabs.
      do 701 ik = 1, ne
         chia(ik)   = chia(ik)   + cchi(ik)/ nabs
  701 continue
      if (iabs.lt.nabs) then
c        save chia in chia.bin for averaging
         open (unit=1, file='chia.bin', status='unknown',
     1   access='sequential', form='unformatted', iostat=ios)
         do 760 ie=1,ne
  760    write(1) chia(ie)
         close(unit=1)
      endif

      if (iabs.eq.nabs) then
c        The loop over absorbers is finished. Write out the results.
         write(8,600) coment, nused, ntotal
  600    format (a2,1x, i4, '/', i4, ' paths used')
  610    format (a2,1x, 71('-'))

         do 702 ik = 1, ne
            rchtot(ik) = dimag (chia(ik))
  702    continue
c        prepare the output grid omega
         efermi = edge + omega(1) - dble(emxs(1))

c        do convolution with excitation spectrum
         if (mbconv .gt. 0) then
            wp = wp / 2.
            call  exconv
     1      (omega, ne1, efermi, s02p, erelax, wp, xsnorm)
            call  exconv
     1      (omega, ne1, efermi, s02p, erelax, wp, rchtot)
         endif

c        normalize to xsec at 50 eV above edge
c        and prepare the output energy grid omega
         edg50 = efermi + 50 / hart
         call terp (omega, xsnorm,  ne1, 1, edg50, xsedge)
         if (absolu.eq.1) xsedge=dble(1)  !KJ 4-06 don't normalize	 
         write(8,660)  coment, xsedge 
  660    format (a2,' xsedge+ 50, used to normalize mu ', 1pe20.4)
         write(8,610) coment
         write(8,665) coment
  665    format (a2,' omega    e    k    mu    mu0     chi     @#')

c        transform from cross section in Angstrom**2 to f"/m*c**2
         do 670 ie = 1,ne
            energy = dble(emxs(ie)) + efermi 
            prefac = 4 * pi * alpinv / energy * bohr**2
c           add alpha**2 to convert to units for f'
            xsec(ie) = xsec(ie) / prefac * alpinv**2
            xsnorm(ie) = xsnorm(ie) / prefac * alpinv**2
  670    continue

         do i=1,nex
	 if (.not.cross) then !KJ I added this block 4-06
	   kxsec(i)=xsec(i)
	 else
	   kxsec(i)=dcmplx(0,0)
	 endif !KJ end my code
	 enddo


c        do correction using brouder method
         ne2 = ne - ne1 - ne3
         call fprime(efermi, emxs, ne1, ne3, ne, ik0, kxsec,xsnorm,chia, !KJ changed xsec to kxsec 4-06
     1       vrcorr, vicorr, cchi)
         do 850 ie=1,ne1
           fpp(ie)=xsnorm(ie) + dimag(xsnorm(ie)*chia(ie))
           rchtot(ie)=dble(xsnorm(ie)*chia(ie)+cchi(ie))
  850    continue
         do 855 ie=1,ne
           chia(ie) = 0
  855    continue
         call fprime(efermi, emxs, ne1, ne3, ne, ik0, kxsec,xsnorm,chia, !KJ id.
     1       vrcorr, vicorr, cchi)
         do 860 ie = 1, ne1
            em0 = dble(emxs(ie))
            xsec0 = dble( cchi(ie))
            chi0  = (rchtot(ie) - xsec0)
            if (ne2.gt.0) then
c             DANES
c             - signs to comply with Cromer-Liberman notation for f', f"
              write(8,700)  omega(ie)*hart, em0*hart, xkp(ie)/bohr,
     1             -rchtot(ie), -xsec0, -chi0
  700         format (1x, 2f11.3, f8.3, 1p, 3e13.5)
            else
c             FPRIME
              write(8,710)  omega(ie)*hart, em0*hart, 
     1              -rchtot(ie), -xsec0, fpp(ie), xsnorm(ie)
  710         format (1x, 2f11.3, 4e13.5)
            endif
  860    continue

         close (unit=8)
         close (unit=3, status='delete')
      endif
c     for if (iabs=abs); or the last absorber

      enddo !KJ of my iip=ipmin,ipmax,ipstep loop  1-06


      return
      end
      subroutine ff2chi (ispec, ipr4, idwopt, critcw, s02, sig2g,
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 3-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line  1-06     
c     adds the contributions from each path and absorber, including
c     Debye-Waller factors. Writes down main output: chi.dat and xmu.dat
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (eps4 = 1.0e-4)
      integer ipmin,ipmax,ipstep,elnes !KJ my variables  1-06    
      integer absolu !KJ 3-06  

c     header from list.dat
      dimension lhead(nheadx)
      character*80  head(nheadx)

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

      parameter (nfinex = 601)
      complex*16 cchi(nfinex), ckck(nfinex), ccc, ckp
c     to keep Im part of cchi 11.18.97 ala
      dimension rchtot(nfinex)
      complex*16 chia(nfinex)
      dimension xkp(nfinex), xk0(nfinex)

      logical dwcorr
      character*512 slog
      character*2 coment
      parameter (coment='# ')

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.
      real rnrmav, xmu, edge
      character*80 title(nheadx)
      character*6  potlbl(0:nphx)
      dimension iz(0:nphx)
c     central atom phase shift at l0
      complex phc(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), beta(legtot,npx), eta(legtot,npx)
      real ri(legtot,npx)
      real achi(nex,npx), phchi(nex,npx)

c     stuff from xsect.bin
      complex*16 emxs(nex), xsec(nex)
      dimension omega(nex), xkxs(nex), xsnorm(nex), fpp(nex)
      dimension omegax(nfinex)
c#mn
      external getxk

c !KJ locals  1-06
      integer iip,nip
      logical cross 
      character*9 f1,f2
      character*10 f0,f3
      complex*16 kxsec(nex)     
!KJ end my variables      
      

c     lines below allow to skip FMS module for DANES
c     after XANES calculations
      open (unit=1, file='phase.bin', status='old', iostat=ios)
      if (ios.le.0 .and. abs(ispec).eq.3) then
        read(1,*) ne3, ne3, ne3, ne3
      endif
      close (unit=1)


c !KJ loop over iip added to process several spectra at once  1-06
c !KJ reading of feff.bin and list.dat moved inside the loop (used to be before reading
c !KJ xsect.bin      
      do iip=ipmin,ipmax,ipstep
        cross=(.not.(iip.eq.1.or.iip.eq.10.or.iip.eq.5.or.iip.eq.9))
      
c !KJ choose different filename for each spectrum.
        if(iip.eq.1) then
	  f1(1:9)='chi.dat  '
	  f2(1:9)='xmu.dat  '
	  f0(1:10)='feff.bin  '
	  f3(1:10)='list.dat  ' 	  
	elseif(iip.eq.10) then
	  f1(1:9)='chi10.dat'
	  f2(1:9)='xmu10.dat'
	  f0(1:10)='feff10.bin'
	  f3(1:10)='list10.dat'	  
	elseif(iip.gt.1.and.iip.lt.10) then
	  f1(1:4)='chi0'
	  f1(5:5)= char(48+iip)
	  f1(6:9)='.dat'
	  f2(1:4)='xmu0'
	  f2(5:5)= char(48+iip)
	  f2(6:9)='.dat'
	  f0(1:5)='feff0'
	  f0(6:6)= char(48+iip)
	  f0(7:10)='.bin'	
	  f3(1:5)='list0'
	  f3(6:6)= char(48+iip)
	  f3(7:10)='.dat'
	else
	  stop 'crazy iip in ff2xmu'
	endif

c     open list.dat and read list of paths we want
      open (unit=1, file = f3, status='old', iostat=ios) !KJ changed 'list.dat' to f3 1-06
      call chopen (ios, f3, 'ff2chi') !KJ id.
      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     read 'xsect.bin'
      call  rdxbin (s02p, erelax, wp, edgep, s02, gamach, ne1, ik0,
     2  emxs, omega, xkxs, xsnorm, xsec, nxsec, mbconv, title, ntitle)
c !KJ I have put rdxbin inside the loop since omega is 'recycled' below,
c !KJ which is a problem if the loop executes more than once.
c !KJ Simply reading the file again and again is the lazy solution,
c !KJ but it avoids confusing changes to the code (eg., new variables).

       call rdfbin (f0, nphx, nex, npx, legtot,  !KJ changed 'feff.bin' to f0  1-06
     $      nptot, ne, npot, ihole, iorder, ilinit, 
     $      rnrmav, xmu, edge, potlbl, iz, phc, ck, xk, index, 
     $      nleg, deg, reff, crit, ipot, 
     $      rat, beta, eta, ri, achi, phchi)
     
c     make combined title
      do 120 ihead = 1, nhead
  120 title(ntitle+ihead) = head(ihead)
      ntitle = ntitle + nhead

c     write feffnnnn.dat
      if (ipr4.eq.3) then
         call feffdt(ntotal,ip,nptot,ntitle,title,ne1,npot,
     $        ihole, iorder, ilinit, rnrmav, xmu, edge, potlbl,
     $        iz,phc,ck,xk,index,
     $        nleg,deg,nepts,reff,crit,ipot,rat,achi,phchi)
       end if

      if (iabs.eq.1) then
c        compare grids in xsect.bin and feff.bin
         do 680 i = 1, nxsec
           del = xk(i)**2 - xkxs(i)**2
           if (abs(ispec).ne.3 .and. abs(del) .gt. 10*eps4)  then
             call wlog(' Emesh in feff.bin and xsect.bin different.')
             call wlog
     1       (' Results may be meaningless, check input files.')
             call wlog
     1       (' Either use XANES card or remove xsect.bin file.')
             write(slog,670)  i, xk(i)/bohr, xkxs(i)/bohr, del
             call wlog(slog)
  670        format(i7, 1p, 3e13.5)
             call par_stop('FF2CHI-1') 
           endif
  680    continue
      endif

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) then
         do 170  ipath = 1, nptot
            do 180  ie = 1, ne
               ckp = sqrt (ck(ie)**2 + coni*2*vicorr)
               xlam0 = aimag(ck(ie)) - dimag(ckp)
               achi(ie,ipath) = achi(ie,ipath) * 
     1              exp (2 * reff(ipath) * xlam0)
 180        continue
 170     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           k' is value for output, k0 is k value used for
c           interpolations with original grid.

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 / 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
c     ik0 is index at fermi level
      if (abs(ispec).ne.3) ik0 = 1
      ik0p = 1
      do 250  i = 1, nfinex
         xkp(i) = xkmin + delk * (i - 1)
         tmp = sign (one, xkp(i))
         e = tmp * xkp(i)**2 /2 - vrcorr
         xk0(i) = getxk(e)
         if (xk0(i).lt.eps4)  ik0p = i
         if (xk0(i) .gt. xk(ne1)+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 headers
      if (iabs.eq.nabs) then
         open (unit=3, file=f1, status='unknown', iostat=ios) !KJ changed chi.dat to f1 1-06
         call chopen (ios, f1, 'ff2chi') !KJ id.
         open (unit=8, file=f2, status='unknown', iostat=ios) !KJ changed xmu.dat to f2  1-06
         call chopen (ios, f2, 'ff2chi') !KJ id.

c        write miscellaneous staff into headers  !KJ corrected typo
         call wrhead (3, ntitle, title, dwcorr, s02,
     1        tk, thetad, sig2g, alphat, vrcorr, vicorr, critcw)

         call wrhead (8, ntitle, title, dwcorr, s02,
     1        tk, thetad, sig2g, alphat, vrcorr, vicorr, critcw)

c        also write information on the screen
         if (alphat .gt. zero)  then
            write(slog,322) alphat
  322       format ('    1st and 3rd cumulants, alphat = ', 1pe20.4)
            call wlog(slog)
         endif
         if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
            write(slog,343) vrcorr*hart, vicorr*hart
  343       format ('    Energy zero shift, vr, vi ', 1p, 2e14.5)
            call wlog(slog)
         endif

         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
  380       format('    S02', f7.3, '  Temp', f8.2, '  Debye temp',f8.2,
     1           '  Global sig2', f9.5)
            call wlog(slog)
         else
            write(slog,381) s02, sig2g
  381       format('    S02', f7.3, '  Global sig2', f9.5)
            call wlog(slog)
         endif
      endif


c     make chi and sum it
      do 400  i = 1, nfinex
         cchi(i) = 0
  400 continue

c     add Debye-Waller factors
      call dwadd (ntotal, nptot, idwopt, ip, index, crit, critcw, sig2g,
     1  sig2u, dwcorr, rnrmav, nleg, deg, reff, iz, ipot,rat, tk,thetad,
     2  alphat, thetae, mbconv, s02, ne1, ck, achi, phchi, nkx, xk, xk0,
     3  xkp, cchi, iabs, nabs, ispec, ipr4, ntitle,
     4  title, vrcorr, vicorr, nused)

c     read or initialize chia - result of configuration average
      if (iabs.eq.1) then
         do 635 ie =1, nfinex
            chia(ie) = 0
  635    continue
      else
         open (unit=1, file='chia.bin', status='old',
     1   access='sequential', form='unformatted', iostat=ios)
         do 640 ie = 1,nkx
  640    read(1) chia(ie)
         close (unit=1, status='delete')
      endif

c     add contribution from an absorber iabs 
c     present scheme assumes that xsec is the same for all iabs.
      do 701 ik = 1, nkx
         chia(ik)   = chia(ik)   + cchi(ik)/ nabs
  701 continue
      if (iabs.lt.nabs) then
c        save chia in chia.bin for averaging
         open (unit=1, file='chia.bin', status='unknown',
     1   access='sequential', form='unformatted', iostat=ios)
         do 760 ie=1,nkx
  760    write(1) chia(ie)
         close(unit=1)
      endif

      if (iabs.eq.nabs) then
c        the loop over absorbers finished, ready to report results

c        Write it out
         write(3,600)  coment, nused, ntotal
         write(8,600)  coment, nused, ntotal
  600    format (a2, 1x, i4, '/', i4, ' paths used')
         write(3,610) coment
  610    format (a2, 1x, 71('-'))
         write(3,620) coment
  620    format(a2,
     1         '      k          chi          mag           phase @#')

         do 702 ik = 1, nkx
           if (abs(ispec).ne.3) then
            rchtot(ik) = dimag (chia(ik))
           else
            rchtot(ik) = dble (chia(ik))
           endif
  702    continue
c        prepare the output grid omegax
         efermi = edge + omega(1) - dble(emxs(1))
         do 590  ik = 1, nkx
            if (xkp(ik) .lt. 0.0) then
               omegax(ik) = - xkp(ik) * xkp(ik) / 2  + efermi
            else
               omegax(ik) = xkp(ik) * xkp(ik) / 2  + efermi
            endif
  590    continue

c        do convolution with excitation spectrum
c        it is currently screwed up since xsnorm is rewritten
c        fix later
         if (mbconv .gt. 0) then
            wp = wp / 2.
            call  exconv
     1      (omega, ne1, efermi, s02p, erelax, wp, xsnorm)
            call  exconv
     1      (omegax, nkx, efermi, s02p, erelax, wp, rchtot)
         endif


c        write to 'chi.dat'
         do 660 ik = 1, nkx
            ccc = chia(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 (ipr4.ne.4) then
              write(3,630)  xkp(ik)/bohr, rchtot(ik), abs(ccc), phase0
  630         format (1x, f10.4, 3x, 3(1pe13.6,1x))
            else
c             need to report ck into chi.dat for Conradson's program
c             complex*16 should be used in terpc
              do 625 i=1,ne
  625         ckck(i) = dble(real(ck(i))) +coni*dble(aimag(ck(i)))
              call terpc (xkxs, ckck, ne, 3, xk0(ik), ckp)
              write(3,650)  xkp(ik)/bohr, rchtot(ik), abs(ccc), phase0,
     1        dble(ckp)/bohr, dimag(ckp)/bohr
  650         format (1x, f10.4, 3x, 5(1pe13.6,1x))
            endif
  660    continue
         close (unit=3)
   
c        write to 'xmu.dat'
c        normalize to xsec at 50 eV above edge
c        and prepare the output energy grid omegax
         edg50 = efermi + 50 / hart
         call terp (omega, xsnorm,  ne1, 1, edg50, xsedge)
	 if (absolu.eq.1) xsedge=dble(1) !KJ 1-06 don't normalize
         write(8,690)  coment, xsedge 
  690    format (a2, ' xsedge+50, used to normalize mu ', 1pe20.4)
         write(8,610) coment
         write(8,695) coment
  695    format (a2,' omega    e    k    mu    mu0     chi     @#')

         do i=1,nex
	 if (.not.cross) then !KJ I added this block 1-06
	   kxsec(i)=xsec(i)
	 else
	   kxsec(i)=dcmplx(0,0)
	 endif !KJ end my code
	 enddo
	 

c        do edge correction and write down results to xmu.dat, chi.dat
         do 710 ie = 1, ne
  710    chia(ie) = 0
         if (abs(ispec).eq.3) then
c          transform from cross section in Angstrom**2 to f"/m*c**2
           do 697 ie = 1,ne
             energy = dble(emxs(ie)) + efermi
             prefac = 4 * pi * alpinv / energy * bohr**2
c            add alpha**2 to convert to units for f'
             kxsec(ie) = kxsec(ie) / prefac * alpinv**2   !KJ changed xsec to kxsec  1-06
             xsnorm(ie) = xsnorm(ie) / prefac * alpinv**2
  697      continue
           ne2 = ne - ne1 - ne3
           call fprime(efermi, emxs, ne1, ne3,ne,ik0, kxsec,xsnorm,chia,
     1       vrcorr, vicorr, cchi)  !KJ changed xsec to kxsec 1-06
           do 850 ie=1,ne1
             omega(ie) = dble(cchi(ie))
  850      continue
         else
           call xscorr (ispec, emxs, ne1, ne, ik0, kxsec, xsnorm, chia,
     1       vrcorr, vicorr, cchi) !KJ xsec to kxsec 7/06
c          omega is not used as energy array, but as xsec array below
           do 711 ie = 1, ne1
  711      omega(ie) = dimag(kxsec(ie)+cchi(ie))  !KJ xsec to kxsec 7/06
         endif

         do 750  ik = 1, nkx
            em0 = omegax(ik) - efermi + edge
            call terp (xkxs, omega,  ne1, 1, xk0(ik), xsec0)
            call terp (xkxs, xsnorm,  ne1, 1, xk0(ik), xsnor0)
            if (omegax(ik).ge.efermi) then
              chi0 = xsnor0 * rchtot(ik)
            else
              chi0 = xsnor0 * rchtot(ik0p)
            endif
            if (abs(ispec).ne.3) then
              write(8,700)  omegax(ik)*hart, em0*hart, xkp(ik)/bohr,
     1              ( chi0 + dble(xsec0) )/xsedge,
     1              xsec0 /xsedge, rchtot(ik)
            else
c             signs to comply with Cromer-Liberman notation for f', f"
              write(8,700)  omegax(ik)*hart, em0*hart, xkp(ik)/bohr,
     1             -(xsec0+chi0), -xsec0, -chi0
            endif
  700       format (1x, 2f11.3, f8.3, 1p, 3e13.5)
  750    continue
         close (unit=8)
      endif
c     for if (iabs=abs); or the last absorber


      enddo !KJ of my iip=ipmin,ipmax,ipstep loop   1-06

      return
      end
      subroutine rdxbin (s02p, erelax, wp, edgep, s02, gamach, ne1, ik0,
     1                   emxs, omega, xkxs, xsnorm, xsec, nxsec, mbconv,
     2                   title, ntitle)

      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

c     header from xsect.bin
      dimension ltitle(nheadx)
      character*80 title(nheadx)
      complex*16 emxs(nex), xsec(nex)
      dimension omega(nex), xkxs(nex), xsnorm(nex)

      open (unit=8, file='xsect.bin', status='old', iostat=ios)
c     read xsect.bin
      ntitle = nheadx
      call rdhead (8, ntitle, title, ltitle)
c     read method for xsec calculation
      read(8,*)  s02p, erelax, wp, edgep, emu
      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, ne1, ik0
      gamach = gamach / hart
c     skip label and read after it
      read(8,*)
      i = 1
  300    read(8,*,end=310)  ereal, eimag, xsnorm(i), dum1, dum2
         xsec(i) = dum1 + coni*dum2
c        xsect.bin is in eV and invA, convert to code units here
         emxs(i) = (ereal + coni*eimag) / hart
         xkxs(i) = getxk (dble(emxs(i)) - edgep)
         omega(i) = dble(emxs(i)) - edgep + emu
         nxsec = i
         i = i + 1
         if (i.le.nex) goto 300
  310 continue
      close(unit=8)
 
      return
      end

      subroutine wrhead (iunit, nhead, head, dwcorr, s02,
     1  tk, thetad, sig2g, alphat, vrcorr, vicorr, critcw)

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/vers.h
      character*12 vfeff
c                       123456789012  
      parameter (vfeff='Feff 8.50')
c= ../HEADERS/vers.h}
      parameter (eps4 = 1.0e-4)
      character*80  head(nheadx)
      logical dwcorr
      character*2 coment
      parameter (coment='# ')

c     write miscellanious staff into headers
c     add feff verdion to the first line
      ll = istrln(head(1))
      if (ll .lt. 0)  then
        head(1)= 'Untitled'
        ll = istrln(head(1))
      endif
      write(iunit,310) coment, head(1)(1:), vfeff
  310 format (a2, a55, t66, a12)

c     the rest of the title
      do 330  ihead = 2, nhead
         ll = istrln(head(ihead))
         if (ll .gt. 0)  then
            write(iunit,320) coment, head(ihead)(1:ll)
         endif
  320    format (a2, a)
  330 continue
      if (dwcorr)  then
         write(iunit,340)  coment, s02, tk, thetad, sig2g
  340    format (a2,' S02=', f5.3, '  Temp=', f7.2,'  Debye_temp=',f7.2,
     1        '  Global_sig2=', f8.5)
      else
         write(iunit,341)  coment, s02, sig2g
  341    format (a2, ' S02=', f5.3,
     1   '                                        Global_sig2=', f8.5)
      endif
      if (alphat .gt. zero)  then
         write(iunit,321)  coment, alphat
  321    format (a2, ' 1st and 3rd cumulants, alphat = ', 1pe20.4)
      endif

      if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
         write(iunit,342) coment, vrcorr*hart, vicorr*hart
      endif
  342 format (a2, ' Energy zero shift, vr, vi ', 1p, 2e14.5)

      if (critcw .gt. 0)  write(iunit,350) coment, critcw
  350 format (a2, ' Curved wave amplitude ratio filter ', f7.3, '%')
      write(iunit,360) coment
  360 format (a2, '    file         sig2 tot  cw amp ratio   deg',
     1        '  nlegs   reff  inp sig2')
c     stop writing misc. staff to files

      return
      end


      subroutine dwadd (ntotal,nptot,idwopt,ip,index,crit,critcw,sig2g,
     1  sig2u, dwcorr, rnrmav, nleg, deg, reff, iz, ipot, rat,tk,thetad,
     2  alphat, thetae, mbconv, s02, ne1, ck, achi, phchi, nkx, xk, xk0,
     3  xkp, cchi, iabs, nabs, ispec, ipr4, nhead,
     4  head, vrcorr, vicorr, nused)
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (eps4 = 1.0e-4)
      character*80  head(nheadx)
      parameter (npx=15000)
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
c     to keep Im part of cchi 11.18.97 ala
      complex*16 dw, dw1, dw3
      dimension xkp(nfinex), xk0(nfinex)

      logical dwcorr
      dimension rattmp(3,0:legtot)
      dimension iztmp(0:legtot)
      character*512 slog
      character*12 fname
      real rnrmav
      dimension iz(0:nphx)
c     central atom phase shift at l0
      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 achi(nex,npx), phchi(nex,npx)
      dimension sig2x(0:nphx, 0:nphx)
      character*2 coment
      parameter (coment='# ')

c     Keep stats on paths used to make chi
      nused = 0
      xkref = dble(ck(1)**2) - xk(1)*abs(xk(1)) 

c     open the files for sigrm and sigem
      if (idwopt.eq.1) then
         iem = 111
         open(unit=iem,file='s2_em.dat',status='unknown', iostat=ios)
         call chopen (ios, 's2_em.dat', 'sigem')
      elseif (idwopt.eq.2) then
         irm1 =111
         open(unit=irm1,file='s2_rm2.dat',status='unknown', iostat=ios)
         call chopen (ios, 's2_rm2.dat', 'sigrm')
         irm2 = 112
         open(unit=irm2,file='s2_rm1.dat',status='unknown', iostat=ios)
         call chopen (ios, 's2_rm1.dat', 'sigrm')
      endif
      if (alphat .gt. 0) then
        icum = 113
        open(unit=icum, file='cum.dat', status='unknown', iostat=ios)
        call chopen (ios, 'cum.dat', 'sig3')
        Write(icum, 363)
  363  format('# first and third icumulant for single scattering paths')
        write(icum,364) thetae, alphat
        write(icum,365)
  364   format ('# Einstein-Temp. =',f9.2 ,'   ', 'alpha=',f9.5)
  365   format ('#       file   sig1    sig2    sig3 ')
      endif

      if (idwopt.ge.1) then
c        initialize statistics for max DW for sigrm
         sig2mx=0
         do 400 iph1=0,nphx
         do 400 iph2=0,nphx
  400    sig2x(iph1, iph2) = 0
      endif
     

c     cycle over all paths in the list
      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 .and. idwopt.ge.0)  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
            if (idwopt.eq.0) then 
c             use CD model
              call sigms (tk, thetad, rs, legtot, nleg(ipath), 
     1                  rattmp, iztmp, sig2d)
            elseif (idwopt.eq.1) then 
c             use EM method
              call sigem
     1        (sig2mx,sig2x,iem,tk,ipath,nleg(ipath),rattmp,sig2d)
            elseif (idwopt.eq.3) then  !KJ 7/06 added this section
c             use CL model
              call sigcl (tk, thetad, rs, legtot, nleg(ipath), 
     1                  rattmp, iztmp, sig2d)   
            else 
c             use RM
              call sigrm
     1        (sig2mx,sig2x,irm1,irm2,tk,ipath,nleg(ipath),rattmp,sig2d)
            endif
            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
           if (thetae.le.0.d0) then
c            call sig3  to get sig1 and sig3 for single scattering paths
c           use reff(ipath) for r, note that reff is single precision
             iz1 = iztmp(nleg(ipath))
             iz2 = iztmp(1)
             call sigte3(iz1, iz2, sig2, alphat, thetad, reff(ipath),
     1                   sig1, sig3)
           else
c            this gets sig1 and sig3 for single scattering paths
c            using Morse potential
             call sigm3(sig1, sig2, sig3, tk, alphat, thetae)
           endif
           write(icum,475) index(ipath),  sig1 * bohr,
     1                 sig2*(bohr**2), sig3*(bohr**3)
  475      format( i10,f9.5,f9.5,' ',f9.7)
         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, ne1
            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 = 0.0
            if (abs(dw).gt.0) 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, ne1
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),  ne1, xk0(ik), achi0)
            call terp1 (xk, phchi(1,ipath), ne1, xk0(ik), phchi0)
            ccpath(ik) = 
     1        achi0 * exp (coni * (2 * xk0(ik) * reff(ipath) + phchi0))
c           note that this already includes s02, deg, sig2, etc.
c           sum total complex chi
            cchi(ik) = cchi(ik) + ccpath(ik)
  500    continue
         nused = nused + 1

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

c        write out a chinnnn.dat for this path, if necessary.
         if (ipr4 .eq. 2 .and. iabs.eq.nabs .and. ispec.eq.0)  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
               lhead = istrln(head(ihead))
               if (lhead .gt. 0)  then
                  write(9,320) head(ihead)(1:lhead)
  320             format (a)
               endif
  530       continue
            if (dwcorr)  then
               write(9,340)  s02, tk, thetad, sig2g
  340          format (' S02', f7.3, '  Temp', f8.2,'  Debye temp',f8.2,
     1        '  Global sig2', f9.5)
            else
               write(9,341)  s02, sig2g
  341          format (' S02', f7.3,
     1      '                                        Global sig2', f9.5)
            endif
            if (alphat .gt. zero)  then
               write(9,321)  alphat
  321          format (' 1st and 3rd cumulants, alphat = ', 1pe20.4)
            endif

            if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
               write(9,342)  vrcorr, vicorr
  342          format (' Energy zero shift, vr, vi ', 1p, 2e14.5)
            endif
            write(9,*) 'Debye-waller factor ', sig2, sig3

            write(9,610)
  610       format (1x, 71('-'))
            write(9,535)
  535       format ('       k         chi           mag          ',
     1              'phase        phase-2kr  @#')
            do 540  i = 1, nkx
               ckp = sqrt (xkp(i)*abs(xkp(i)) + xkref)
c              it would be better to use interpolation for ckp
c              fix later if complaints about chipnnn.dat files, ala
               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)
  630          format (1x, f10.4, 3x, 4(1pe13.6,1x))
  540       continue
            close (unit=9)
         endif

  550    continue
  560 continue

c     close files opened for sigem and sigrem
      if (idwopt.eq.1) then
        close (unit=iem)
      elseif (idwopt.eq.2) then
        close (unit=irm1)
        close (unit=irm2)
      endif
      if (alphat .gt. 0) then
        close (unit=icum)
      endif

      return
      end
      subroutine ff2xmu (ispec, ipr4, idwopt, critcw, s02, sig2g,
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 3-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line 1-06     
c     adds the contributions from each path and absorber, including
c     Debye-Waller factors. Writes down main output: chi.dat and xmu.dat
      implicit double precision (a-h, o-z)

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      parameter (eps4 = 1.0e-4)
      integer ipmin,ipmax,ipstep,elnes !KJ my variables 1-06 
      integer absolu !KJ 3-06     

c     header from list.dat
      dimension lhead(nheadx)
      character*80  head(nheadx)
      complex*16 gtr(nex),gtrful(ipmin:ipmax,nex) !KJ added gtrful 1-06

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

      complex*16 cchi(nex), ckp
c     to keep Im part of cchi 11.18.97 ala
      dimension rchtot(nex), xkp(nex)
      complex*16 chia(nex)

      logical dwcorr
      character*512 slog
      character*2 coment
      parameter (coment='# ')

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.
      real rnrmav, xmu, edge
      character*80 title(nheadx), titfms
      character*6  potlbl(0:nphx)
      dimension iz(0:nphx)
c     central atom phase shift at l0
      complex phc(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), beta(legtot,npx), eta(legtot,npx)
      real ri(legtot,npx)
      real achi(nex,npx), phchi(nex,npx)

c     stuff from xsect.bin
      complex*16 emxs(nex), xsec(nex)
      dimension omega(nex), xkxs(nex), xsnorm(nex)
      
c !KJ locals  1-06
      integer iip,nip
      logical cross 
      character*9 f1,f2
      character*10 f0,f3
      complex*16 gtrtemp(nex*(1+ipmax-ipmin))
      complex*16 kxsec(nex)     
c !KJ end my variables


c     get gtr - result of FMS
      do 112 ie =1,nex
      gtr(ie)= 0
      do 112 iip =ipmin,ipmax  !KJ I added this variable ip 1-06
  112 gtrful(iip,ie) = 0
      ntfms = 0
      nip=ipmax-ipmin+1 !KJ 1-06
      
      open (unit=1, file='fms.bin', status='old', iostat=ios)
      if (ios.le.0) then
         ntfms = 1
         read(1, 113) titfms
  113    format(a)
         read(1, 115) ne, ne1, ne3, nph, npadx
  115    format(5(1x,i3))
         call rdpadx(1, npadx, gtrtemp, ne*nip)  !KJ I added *nip, changed gtr to gtrtemp  1-06
      endif
      close (unit=1)
!KJ Next lines my addition to read several spectra at once. 1-06
	i=1
	do iip=ipmin,ipmax
	do j=1,ne
        gtrful(iip,j)=gtrtemp(i+j-1)
	enddo
	  i=i+ne
	enddo
!KJ Now we don't need gtrtemp anymore.  End my changes



c     read xsect.bin file
      call  rdxbin (s02p, erelax, wp, edgep, s02, gamach, ne1, ik0,
     2  emxs, omega, xkxs, xsnorm, xsec, nxsec, mbconv, title, ntitle)


c !KJ loop over iip added to process several spectra at once  1-06
c !KJ reading of feff.bin moved inside the loop (used to be before reading
c !KJ xsect.bin      
      do iip=ipmin,ipmax,ipstep
        cross=(.not.(iip.eq.1.or.iip.eq.10.or.iip.eq.5.or.iip.eq.9))
      
c !KJ choose different filename for each spectrum.
        if(iip.eq.1) then
	  f1(1:9)='chi.dat  '
	  f2(1:9)='xmu.dat  '
	  f0(1:10)='feff.bin  '
	  f3(1:10)='list.dat  ' 	  
	elseif(iip.eq.10) then
	  f1(1:9)='chi10.dat'
	  f2(1:9)='xmu10.dat'
	  f0(1:10)='feff10.bin'
	  f3(1:10)='list10.dat'	  
	elseif(iip.gt.1.and.iip.lt.10) then
	  f1(1:4)='chi0'
	  f1(5:5)= char(48+iip)
	  f1(6:9)='.dat'
	  f2(1:4)='xmu0'
	  f2(5:5)= char(48+iip)
	  f2(6:9)='.dat'
	  f0(1:5)='feff0'
	  f0(6:6)= char(48+iip)
	  f0(7:10)='.bin'	
	  f3(1:5)='list0'
	  f3(6:6)= char(48+iip)
	  f3(7:10)='.dat'
	else
	  stop 'crazy iip in ff2xmu'
	endif
	do i=1,nex
	gtr(i)=gtrful(iip,i)
	enddo
	


c     open list.dat and read list of paths we want
      open (unit=1, file= f3, status='old', iostat=ios)!KJ changed 'list.dat' to f3 4-06
      ntotal = 0
      if (ios.le.0) then
        call chopen (ios, f3, 'ff2afs')  !KJ id.
        nhead = nheadx
        call rdhead (1, nhead, head, lhead)
c       skip a label line
        read(1,*)
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
      endif
      close (unit=1)


       call rdfbin (f0, nphx, nex, npx, legtot, !KJ changed 'feff.bin' to f0  1-06
     $     nptot, ne, npot, ihole, iorder, ilinit, 
     $     rnrmav, xmu, edge, potlbl, iz, phc, ck, xk,
     $     index, nleg, deg, reff,
     $     crit, ipot, rat, beta, eta, ri, achi, phchi)

c     make combined title
      if (ntfms.eq.1) then
        ntitle = ntitle + 1
        title(ntitle) = titfms
      endif
      do 120 ihead = 1, nhead
 120  title(ntitle+ihead) = head(ihead)
      ntitle = ntitle + nhead

c     write feffnnnn.dat
      if (ipr4.eq.3) then
         call feffdt(ntotal,ip,nptot,ntitle,title,ne,npot,
     $        ihole, iorder, ilinit, rnrmav, xmu, edge, potlbl,
     $        iz,phc,ck,xk,index,
     $        nleg,deg,nepts,reff,crit,ipot,rat,achi,phchi)
       end if

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) then
         do 180  ie = 1, ne
            ckp = sqrt (ck(ie)**2 + coni*2*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     k'**2 = k**2 + vr. If there is no real correction
c     (vrcorr = 0), these two grids will be the same.
c           k' is value for output,  k is  value used for
c           interpolations with original grid.

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

c     ik0 is index at fermi level
      do 250  i = 1, ne
         temp = xk(i)*abs(xk(i)) + 2*vrcorr
         if (temp.ge. 0) then
           xkp(i) = sqrt(temp)
         else
           xkp(i) = - sqrt(-temp)
         endif
  250 continue
     

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

c     Open chi.dat and xmu.dat (output) and start headers
      if (iabs.eq.nabs) then
         open (unit=3, file=f1, status='unknown', iostat=ios) !KJ changed chi.dat to f1
         call chopen (ios, f1, 'ff2chi') !KJ id.  1-06
         open (unit=8, file=f2, status='unknown', iostat=ios) !KJ changed xmu.dat to f2
         call chopen (ios, f2, 'ff2chi') !KJ id.

c        write miscellaneous staff into headers  !KJ corrected typo
         call wrhead (8, ntitle, title, dwcorr, s02,
     1     tk, thetad, sig2g, alphat, vrcorr, vicorr, critcw)
     
c        also write information on the screen
         if (alphat .gt. zero)  then
            write(slog,322) alphat
  322       format ('    1st and 3rd cumulants, alphat = ', 1pe20.4)
            call wlog(slog)
         endif
         if (abs(vrcorr).ge.eps4 .or. abs(vicorr).ge.eps4)  then
            write(slog,343) vrcorr*hart, vicorr*hart
  343       format ('    Energy zero shift, vr, vi ', 1p, 2e14.5)
            call wlog(slog)
         endif

         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
  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)
      endif


c     make chi and sum it
      do 400  i = 1, nex
         cchi(i) = 0
  400 continue
      do 402  ik = 1, ne
         cchi(ik)= s02 * gtr(ik)
  402 continue


c     add Debye-Waller factors
      call dwadd (ntotal, nptot, idwopt, ip, index, crit, critcw, sig2g,
     1  sig2u, dwcorr, rnrmav, nleg, deg, reff, iz, ipot, rat,tk,thetad,
     2  alphat, thetae, mbconv, s02, ne1, ck, achi, phchi, ne, xk, xkp,
     3  xkp, cchi, iabs, nabs, ispec, ipr4, ntitle,
     4  title, vrcorr, vicorr,  nused)

c     read or initialize chia - result of configuration average
      if (iabs.eq.1) then
         do 635 ie =1, nex
            chia(ie) = 0
  635    continue
      else
         open (unit=1, file='chia.bin', status='old',
     1   access='sequential', form='unformatted', iostat=ios)
         do 640 ie = 1,ne
  640    read(1) chia(ie)
         close (unit=1, status='delete')
      endif

      if(iabs.eq.1) then
c        compare grids in xsect.bin and feff.bin
         do 680 i = 1, nxsec
           del = xk(i)**2 - xkxs(i)**2
           if (abs(del) .gt.  10*eps4)  then
             call wlog(' Emesh in feff.bin and xsect.bin different.')
             call par_stop('FF2XMU-1') 
           endif
  680    continue
      endif

c     add contribution from an absorber iabs 
c     present scheme assumes that xsec is the same for all iabs.
      do 701 ik = 1, ne
         chia(ik)   = chia(ik)   + cchi(ik)/ nabs
  701 continue
      if (iabs.lt.nabs) then
c        save chia in chia.bin for averaging
         open (unit=1, file='chia.bin', status='unknown',
     1   access='sequential', form='unformatted', iostat=ios)
         do 760 ie=1,ne
  760    write(1) chia(ie)
         close(unit=1)
      endif

      if (iabs.eq.nabs) then
c        The loop over absorbers is finished. Write out the results.
         write(8,600)  coment, nused, ntotal
  600    format ( a2, 1x, i4, '/', i4, ' paths used')
  610    format ( a2, 1x, 71('-'))

         do 702 ik = 1, ne
            rchtot(ik) = dimag (chia(ik))
  702    continue
c        prepare the output grid omega
         efermi = edge + omega(1) - dble(emxs(1))

c        do convolution with excitation spectrum
         if (mbconv .gt. 0) then
            wp = wp / 2.
            call  exconv
     1      (omega, ne1, efermi, s02p, erelax, wp, xsnorm)
            call  exconv
     1      (omega, ne1, efermi, s02p, erelax, wp, rchtot)
         endif

c        normalize to xsec at 50 eV above edge
c        and prepare the output energy grid omega
         edg50 = efermi + 50 / hart
         if (ispec.eq.2) edg50 = efermi
         call terp (omega, xsnorm,  ne1, 1, edg50, xsedge)
         if (absolu.eq.1) xsedge=dble(1)  !KJ 3-06 don't normalize	 
         write(8,660)  coment, xsedge 
  660    format (a2, ' xsedge+ 50, used to normalize mu ', 1pe20.4)
         write(8,610) coment 
         write(8,670) coment
  670    format (a2,' omega    e    k    mu    mu0     chi     @#')


         do i=1,nex
	 if (.not.cross) then !KJ I added this block 1-06
	   kxsec(i)=xsec(i)
	 else
	   kxsec(i)=dcmplx(0,0)
	 endif !KJ end my code
	 enddo
	 
	
c        do correction using brouder method
         vi0 = 0
         call xscorr(ispec,emxs, ne1, ne, ik0, kxsec,xsnorm,chia,
     1       vrcorr, vi0, cchi) !KJ changed xsec to kxsec  1-06
         do 850 ie=1,ne1
           rchtot(ie)=dimag( kxsec(ie)+xsnorm(ie)*chia(ie)+cchi(ie)) !KJ id.
  850    continue
  
  
         do 855 ie=1,ne
           chia(ie) = 0
  855    continue
         call xscorr(ispec, emxs, ne1, ne, ik0, kxsec,xsnorm,chia,
     1       vrcorr, vi0, cchi) !KJ changed xsec to kxsec  1-06
         do 856 ie = 1, ne1
 856     cchi(ie) = dimag(kxsec(ie)+cchi(ie)) * coni+rchtot(ie) !KJ id.

         if (vicorr.gt.eps4 .and. ntotal.eq.0) then
c           add correction due to vicorr
            call conv(omega,cchi,ne1,vicorr)
c           call conv(omega,xsec,ne1,vicorr)
         endif


         do 860 ie = 1, ne1
            em0 = dble(emxs(ie))
            xsec0 = dimag(cchi(ie))
            rchtot(ie) = dble (cchi(ie))
            chi0  = (rchtot(ie) - xsec0)/xsedge
            write(8,700)  omega(ie)*hart, em0*hart, xkp(ie)/bohr,
     1              rchtot(ie)/xsedge, xsec0/xsedge, chi0

c           if you want f'' at the output in el. units use next line
c    1          rchtot(ie)*omega(ie)*prefac, xsec0*omega(ie)*prefac, chi0
c   with        prefac = alpinv / 4 / pi /bohr**2

  700       format (1x, 2f11.3, f8.3, 1p, 3e13.5)
  860    continue

         close (unit=8)
         close (unit=3, status='delete')
      endif
c     for if (iabs=abs); or the last absorber

      enddo !KJ of my iip=ipmin,ipmax,ipstep loop  1-06
      
      
      return
      end
      subroutine fprime( ei, emxs ,ne1, ne3, ne, ik0, xsec, xsnorm,chia,
     1                  vrcorr, vicorr, cchi)
c     calculate f' including solid state and lifetime effects.
c     using algorithm in Ankudinov, Rehr danes paper.
c     the output correction is returned via cchi. The rest is input
c      mu(omega) = xsec + xsnorm*chia  + (cchi)

      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension  xsnorm(nex), omega(nex)
      complex*16 emxs(nex), xsec(nex), chia(nex), cchi(nex) 
      complex*16 xmu(nex), aa, bb, c1, x1, x2, ec, temp
      complex*16 xmup(nex)
      dimension emp(nex)
      parameter (eps4 = 1.0d-4)
      complex*16 lorenz, funlog, value
      external lorenz, funlog
      dimension dout(7,nex)
      character*72 string
      dimension oscstr(14), enosc(14)
      integer ient
      data ient /0/

c     read data from fpf0.dat
      open (unit=16, file='fpf0.dat', status='old', iostat=ios)
      read  (16,*)  string
      read  (16,*)  eatom
      read  (16,*)  nosc
      do 5 i=1, nosc
        read (16,*) oscstr(i), enosc(i)
   5  continue
c     the rest is f0(Q) and is not currently needed
      close (unit=16)

      ient = ient+1
      ifp = 1
      efermi = dble(emxs(ne1+1)) 
      xloss = dimag(emxs(1))
      ne2 = ne-ne1-ne3
      if (ne2.gt.0) then
c        DANES
         do 10 ie = 1,ne1
   10    xmu(ie) = coni*xsnorm(ie) +  xsnorm(ie)*chia(ie)
         do 11 ie = ne1+1,ne1+ne2
   11    xmu (ie) = xsnorm(ie)*chia(ie)
         do 12 ie = ne-ne3+1, ne
   12    xmu (ie) =  coni*xsnorm(ie)
      else
c        FPRIME
         do 13 ie = 1,ne
   13    xmu (ie) = xsec(ie) + xsnorm(ie)*chia(ie)
      endif

      if (abs(vrcorr).gt.eps4) then
         bb = xmu(ik0)
         efermi = efermi - vrcorr
         do 20 ie = 1,ne1
   20    omega(ie) = dble(emxs(ie))
         call terpc(omega, xmu ,ne1, 1, efermi, bb)
         do 30 ie = 1, ne2
   30    emxs(ne1+ie) = emxs(ne1+ie) - vrcorr
         if (abs(xmu(ik0)).gt. eps4) bb = bb/xmu(ik0)
c        rescale values on vertical axis
         do 60 ie = ne1+1, ne-ne3
   60    xmu(ie) = xmu (ie) * bb 
      endif
              

      if (vicorr.gt.eps4) then
         xloss = xloss + vicorr
         do 40 ie=1,ne2
   40    omega(ie) = dimag(emxs(ne1+ie))
         call terpc(omega, xmu(ne1+1) ,ne2, 1, xloss, aa)
         do 50 ie = 1, ne1
            xx = vicorr**2 /(vicorr**2 + (dble(emxs(ie))-efermi)**2)
            xmu(ie) = xmu(ie)*(1.0d0 - xx) + aa * xx
            emxs(ie) = emxs(ie) + coni*vicorr
   50    continue
      endif

      do 200 ie = 1, ne1
c        cycle over energy points on horizontal grid

         dout(1,ie) = dble(emxs(ie)) * hart
         dele = dble(emxs(ie)) - efermi
c        delp correspond to pole with negative frequency
c        see Sakurai for details

         delp = -dele - 2*ei
c        delp = dele
c        dele = delp

         cchi(ie) = 0
         if (ne2.gt.0) then
            if (abs(dele).lt.eps4) dele = 0.0d0
            w1 = dimag(emxs(ne1+1))
            w2 = dimag(emxs(ne1+2))
            w3 = dimag(emxs(ne1+3))

c           matsubara pole
            temp = lorenz(ifp,xloss,w1,dele)*xmu(ne1+1)*2*coni*w1
            temp = temp + lorenz(ifp,xloss,w1,delp)*xmu(ne1+1)*2*coni*w1
            dout(2,ie)=dble(temp)
c           sommerfeld correction
            temp = coni*w1**2/ 6*(lorenz(ifp,xloss,w3,dele)*xmu(ne1+3)-
     2      lorenz(ifp,xloss,w2,dele)*xmu(ne1+2)) / (w3-w2) 
            dout(3,ie)=dble(temp)

            cchi(ie) = lorenz(ifp,xloss,w1,dele)*xmu(ne1+1) *2*coni*w1
     1      + coni * w1**2 / 6 * (lorenz(ifp,xloss,w3,dele)*xmu(ne1+3)-
     2      lorenz(ifp,xloss,w2,dele)*xmu(ne1+2)) / (w3-w2) 
c           from negative pole has additional minus sign
            cchi(ie) = cchi(ie) + 
     1      lorenz(ifp,xloss,w1,delp)*xmu(ne1+1) *2*coni*w1
     1      + coni * w1**2 / 6 * (lorenz(ifp,xloss,w3,delp)*xmu(ne1+3)-
     2      lorenz(ifp,xloss,w2,delp)*xmu(ne1+2)) / (w3-w2) 

c           theta funcion contribution only for positive pole
            if (dele .lt. eps4)    cchi(ie) = cchi(ie) - xmu(ie)
            if (abs(dele).lt.eps4) cchi(ie) = cchi(ie) + xmu(ie)/2

c           anomalous contribution
            temp = 0
            wp = 2*ei
            if (dele.ge.eps4) temp = xmu(ie)
            if (abs(dele).lt.eps4) temp = xmu(ie)/2
            temp = temp + xmu(ik0)*  funlog(1,xloss,wp,dele)
c               xmu(iko) + xsec(ik0)  if n3 >0
            dout(4,ie)=dble(temp) 

c           integration over vertical axis to final point
            n1 = ne1+2
            n2 = ne-ne3
            call fpint (emxs, xmu, n1, n2, dele, xloss, eps4, efermi,
     1                  value)
            cchi(ie) = cchi(ie) + value
c           add contribution from other pole
            call fpint (emxs, xmu, n1, n2, delp, xloss, eps4, efermi,
     1                  value)
            cchi(ie) = cchi(ie) + value
         endif 

c        integration over horizontal axis to final point
         temp = 0
         if (ne2.gt.0) then
c           DANES
            n1 = ne1-ik0 + 1
            do 120 i = ik0, ne1
              emp(i-ik0+1) = dble(emxs(i))
              xmup(i-ik0+1) = coni*xsnorm(i)
  120       continue
            do 130 i = 1, ne3
              emp(i+n1) = dble(emxs(i+ne-ne3))
              xmup(i+n1) = xmu(i+ne-ne3)
  130       continue
            n2 = n1 + ne3
         else
c           FPRIME
            n1 = 0
            do 140 i = 1, ne1
              if (n1.eq.0 .and. dble(emxs(i)).gt. dble(emxs(ne1+1))) 
     1            n1 = i
  140       continue
            do 150 i = 1, ne3
               emp(i) =  dble(emxs(ne1+i))
               xmup(i) =  xmu(ne1+i)
  150       continue
            n2 = ne3
         endif
         call fpintp (emp, xmup , n2, dele, xloss, efermi, value)
         temp  = temp + value
c        add contribution from other pole
         call fpintp (emp, xmup , n2, delp, xloss, efermi, value)
         temp  = temp + value

c         was used before
cc          contribution to fp from poles of the core states
c           temp=0
c           do 110  i=2, nosc
cc             eif = E_f- E_i  in hartrees
cc             eif = enosc(i)-enosc(1) 
cc             deltaf = deltaf - oscstr(i)*2*alpinv**2/eif
c              temp = temp + alpinv**2 * oscstr(i)* (dele -
c    1      enosc(i)+efermi-1)/ ((dele-enosc(i)+efermi-1)**2+xloss**2)
c              temp = temp + alpinv**2 * oscstr(i)* (delp -
c    1      enosc(i)+efermi-1)/ ((delp-enosc(i)+efermi-1)**2+xloss**2)
c 110       continue

         dout(5,ie) = dble(temp)
         cchi(ie) = cchi(ie) + temp

c        total contribution (not normalized)
         temp = xmu(ie) + cchi(ie)
         dout(6,ie) = dble(temp)
c        (integral w2 to wmax) minus (cusp formula)
         dout (7,ie) = dout(6,ie)-dout(4,ie)
  200 continue

c     restore the input energy mesh
      if (vicorr.gt.eps4) then
         do 250 ie = 1, ne1
  250    emxs(ie) = emxs(ie) - coni*vicorr
      endif
      if (abs(vrcorr).gt.eps4) then
         do 260 ie = 1, ne2
  260    emxs(ne1+ie) = emxs(ne1+ie) + vrcorr
      endif

c     if (ient.eq.1) then
      open(unit=3,file='danes.dat', status='unknown', iostat=ios)
      write(3,310) '# E  matsub. sommerf. anomal. tale, total, differ.'
  310 format (a)
      do 300 ie = 1, ne1
         write(3,320) (dout(i,ie), i=1,7)
  320    format ( 7(1x,1pe11.4))
  300 continue
      close(unit=3)
c     endif

      return
      end

      complex*16 function funlog (icase, xloss, w, dele)
c     anomalous fp should have all main features of total fp
c     except smooth difference 
c     analytic expression for anomalous fp (without integral)
c     is obtained by adding and subtracting G(Ef + i*Gamma) / E-w
c     and performing integral for Im axis analytically
c     icase = 1 simplified expression (compared to 2) 
c     icase=2  use real w 
c     icase=3  pure imaginary w (absolute value is input)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      parameter (eps4 = 1.0d-4)

      if (icase.eq.1) then 
         if (abs(dele).ge.eps4) then 
            funlog= coni/2/pi*
     1      (log((-xloss+coni*dele)/w)+ log((xloss+coni*dele)/w))

         else
            funlog= coni/pi*log(abs(xloss/w))
         endif

      elseif (icase.eq.2) then
        if (abs(dele).ge.eps4) then
          funlog= coni/2/pi* (w+coni*xloss) * (
     1    ( log((-xloss+coni*dele)/w)) / (w+dele+coni*xloss) +
     2    ( log(( xloss+coni*dele)/w)) / (w+dele-coni*xloss))
        else
          funlog= coni/pi*(log(abs(xloss/w)))*
     1    (1 + coni*xloss/(w-coni*xloss))
        endif

      elseif (icase.eq.3) then
        if (abs(dele).ge.eps4) then
          funlog= -(w+xloss)/2/pi* (
     1    log((-xloss+coni*dele)/w) / (dele+coni*(w+xloss)) +
     2    log(( xloss+coni*dele)/w) / (dele+coni*(w-xloss)) )
        else
          funlog= coni/pi* log(abs(xloss/w))*
     1    (1 + xloss/(w-xloss))
        endif
      
      endif

      return
      end

      subroutine fpint (emxs, xmu, n1, n2, dele, xloss, eps4, efermi,
     1                  value)
c     performs integral for fp calculations between points n1 and n2.
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      complex*16 emxs(nex), xmu(nex), value
      complex*16  z1, z2, aa, bb, c1

c     last interval - similar to Matsubara pole ( shift and - sign)
c     notice that this also works for horizontal axis if last value
c     is small
      z1 = emxs(n2)-efermi
      z2 = emxs(n2-1)-efermi
      value =  - coni/pi * (z1-dele) / (xloss**2+(z1-dele)**2)
     1          *xmu(n2) * (2 * (z1-z2))
c     all other intervals
      do  300 i = n1, n2-2
         z1 = emxs(i) - efermi
         z2 = emxs(i+1) - efermi
         bb=(xmu(i+1)*(z2-dele) - xmu(i)*(z1-dele)) / xloss / (z2-z1)
         aa = xmu(i)*(z1-dele)/xloss - bb * z1
         c1 = (aa+bb*(dele+coni*xloss )) / 2 /coni
         if (abs(dele-dble(z1)).lt.eps4 .and.
     1       abs(dele-dble(z2)).lt.eps4) then
            value = value  -  coni/pi *c1*
     1      log( abs((z2-dele-coni*xloss)/(z1-dele-coni*xloss)) )
         else
            value    = value   -  coni/pi *c1*
     1      log((z2-dele-coni*xloss)/(z1-dele-coni*xloss))
         endif
         c1 = -(aa+bb*(dele-coni*xloss )) / 2 /coni
         value    = value    -  coni/pi *c1*
     1   log((z2-dele+coni*xloss)/(z1-dele+coni*xloss))
  300  continue

      return
      end

      subroutine fpintp (em, xmu, n2, dele, xloss, efermi, value)
c     performs integral for fp calculations between points 1 and n2.
c     and adds tail to infinity
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension em(nex)
      complex*16 xmu(nex), value
      complex*16  z1, z2, aa, bb, cc

      value = 0
c     all intervals 
      do  300 i = 1, n2-1
         x1 = em(i) - efermi
         x2 = em(i+1) - efermi
         de = (x2-x1)/2
         x0 = (em(i) + em(i+1)) / 2
         call terpc(em, xmu, n2, 3, x0, aa)
         bb=(xmu(i+1) - xmu(i)) / (x2-x1)
         cc = (xmu(i+1) - aa - bb * de) / de**2
         z1 =  dele - x0 + efermi - coni*xloss
         z2 =  dele - x0 + efermi + coni*xloss
         value    = value  + 2*de*bb + 2*z1*de*cc +
     1    log((de-z1)/(-de-z1)) * (aa+bb*z1+cc*z1**2)
         value    = value  + 2*de*bb + 2*z2*de*cc +
     1    log((de-z2)/(-de-z2)) * (aa+bb*z2+cc*z2**2)
  300 continue

c     tail of xmu to infinity approximated by aa/(w-bb)**2
      x1 = em(n2-1)
      x2 = em(n2)
      a = sqrt ( dble(xmu(n2-1)/xmu(n2)) )
      b = ( a*x1 - x2) / (a-1)
      if (b.gt. x1) b = 0
      aa = xmu(n2) * (x2-b)**2
      z1 = dele -coni*xloss - b
      z2 = dele +coni*xloss - b
      x0 = x2 - b
      value = value + log( x0/(x0-z1) ) *aa/z1**2 - aa/z1/x0
      value = value + log( x0/(x0-z2) ) *aa/z2**2 - aa/z2/x0

c     multiply by constant factor
      value = - coni /2 /pi *value

      return
      end
       subroutine rdfbin(fbfile, nphx, nex, npathx, nlegx, 
     $      npaths, ne, npot, ihole, iorder, ilinit, 
     $      rnrmav, xmu, edge,  potlbl, iz, phc, ck, xk, index, 
     $      nleg, deg, reff, crit, ipot, 
     $      rat, beta, eta, ri, achi, phchi)
c
c read path information from PAD-format feff.bin
c  arguments:
c   fbile   name of feff.bin file                             [in]
c   nphx    dimension of  potlbl, iz (both (0:nphx)           [in]
c             max # of potentials
c   nex     dimension of many energy arrays                   [in]
c             max # of energy points
c   npathx     dimension of index,nleg,ipot,deg,reff,crit,    [in]
c           rat,beta, eta, ri, achi, phchi
c             max # of paths
c   nlegx  dimension of  ipot, rat, beta,eta,ri              [in]
c            max # of legs in a path
c   npaths  number of paths read                             [out]
c   ne      maximum number of energy points read             [out]
c   npot    number of potentials read                        [out]
c   rnrmav  average norman radius                            [out]
c   edge    shift in edge energy (?)                         [out]
c   iorder  order of genfmt matrix used                      [out]
c   potlbl  array of potential labels                        [out]
c   iz      array of atomic numbers for potentials           [out]
c   phc     array of central atom phase shift (complex)      [out]
c   ck      array of wavenumbers/momentum (complex)          [out]
c   xk      array of wavenumbers/momentum (real)             [out]
c   index   array of path indices                            [out]
c   nleg    array:  number of legs in path                   [out]
c   deg     array:  path degeneracy                          [out]
c   reff    array:  half path length of path                 [out]
c   crit    array:  importance factor for path               [out]
c   ipot    array:  pots, in order, that make up the path    [out]
c   rat     array:  atomic positions of atoms in path        [out]
c   beta    array:  euler angle for path                     [out]
c   eta     array:  second euler angle for path              [out]
c   ri      array:  path leg distances for path              [out]
c   achi    array:  amplitude of chi for path                [out]
c   phchi   array:  phase of chi for path                    [out]
c
c notes:
c   the data in feff.bin is written completely in printable
c   ascii characters.  The file is however, highly formatted
c   and kept fairly small.  all text is stored as is, but most
c   numerical data in arrays (both real and complex) is stored
c   in a special Packed Ascii Data (PAD) format which uses 6
c   printable characters to represent a real number.
c
c   special markers in the first 1 or 2 characters of each line
c   give hints about the contents of the line:
c      #_    top 2 lines.  The first line must begin "#_feff.bin"
c      #"    title lines / plain text
c      #&    misc info about potentials, calc method
c      #@    potential labels and iz
c      ##    path index,  deg, reff, crit, ipots involved
c      !     PAD characters to be read as a real array
c      $     PAD characters to be read as a complex array
c
c copyright (c) 1999  matt newville:  jan 1999
c modified by alex ankudinov: feb 2000; few fixes for feff8.2
c------------------------------------------------------------------
       integer nphx, nex, npathx, nlegx, npaths
       integer i, j, ivers, nexmax
       character*(*) fbfile
       character*(*) potlbl(0:nphx), filnam*128, str*128, msg*256
       integer iorder,  index(npathx), nleg(npathx)
       integer ne, npot, ipot(nlegx,npathx), iz(0:nphx)
       integer istrln, ier1, ier2, ier3, nwords, npadx, nwordx
       real    deg(npathx), reff(npathx), crit(npathx)
       real    rnrmav, edge, xk(nex)
       double precision bohr, tmpdp
       parameter (bohr = 0.529 177 249d0, nwordx = 20)
       parameter(nexmax = 256)
       character*20 words(nwordx)
       real     rat(3,nlegx,npathx), beta(nlegx,npathx)
       real     eta(nlegx,npathx),  ri(nlegx,npathx)
       real     achi(nex,npathx), phchi(nex,npathx), tmpr(nexmax)
       complex  phc(nex), ck(nex), tmpc(nexmax)
       external  istrln

c open feff.bin
       filnam = ' '
       filnam = fbfile
       call triml(filnam)
       il     = istrln(filnam)
       if (filnam.eq.' ') filnam = 'feff.bin'
cc       print*, ' RDFBIN!  ', filnam(1:il),':',il
       open (unit=3, file=filnam, status='old', err=450)
 10    format(a)
c first line, must match  "#_feff.bin"
       read(3,10,err=920) str
       call triml(str)
       if ((str(1:10).ne.'#_feff.bin')) go to 900
c check version of feff.bin : only support version 3 here!!
       ivers = 0
       if ((str(1:14).eq.'#_feff.bin fil')) ivers = 1
       if ((str(1:14).eq.'#_feff.bin v02')) ivers = 2
       if ((str(1:14).eq.'#_feff.bin v03')) ivers = 3
       if (ivers.ne.3) go to 930
c second line:   npot, ne
       read(3,10,err=920) str
       call triml(str)
       if ((str(1:2).ne.'#_')) go to 900
       nwords = 3
       str    = str(3:)
       call bwords(str,nwords,words)
       if (nwords.ne.3) go to 905
       call str2in(words(1), npot,  ier1)
       call str2in(words(2), ne,    ier2)
       call str2in(words(3), npadx, ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910

c  read in misc stuff:  (rnrmav, edge, iorder )
       read(3,10,err=920) str
       call triml(str)
       if (str(1:2).ne.'#&') go to 900
       nwords = 6
       str    = str(3:)
       call bwords(str,nwords,words)
       if (nwords.ne.6) go to 905
       call str2in(words(1), ihole,  ier1)
       call str2in(words(2), iorder, ier2)
       call str2in(words(3), ilinit, ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
       call str2re(words(4), rnrmav, ier1)
       call str2re(words(5), xmu   , ier2)
       call str2re(words(6), edge  , ier3)
       if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
c  read pot label and iz line
       read(3,10,err=920) str
       call triml(str)
       if (str(1:2).ne.'#@') go to 900
       nwords = 2 * npot + 2
c  note: potlbl cannot be blank!!
       str    = str(3:)
       call bwords(str, nwords, words)
       if (nwords.ne.(2 + 2*npot)) go to 905
       do 200 i = 0, npot
          potlbl(i) = words(i+1)
          iz(i) = -1
          call str2in(words(2+npot+i),iz(i),ier1)
          if (ier1.ne.0)  go to 910
 200   continue

c read  numerical data that are the same for all paths
       call rdpadc(3,npadx, phc, ne)
       call rdpadc(3,npadx, ck,ne)
       call rdpadr(3,npadx, xk,ne)
       npaths = 0
c now, for each path:
       do 300  i = 1, npathx
          index(i) = 0
c  read path  info "##" line  and retrieve all the stuff from it
          read(3,10,end=450,err=920) str
          call triml(str)
          if (str(1:2).ne.'##')   go to 900
          nwords = nwordx
          str    = str(3:)
          call bwords(str,nwords,words)
          call str2in(words(1),  index(i), ier1)
          call str2in(words(2),  nleg(i), ier2)
          call str2re(words(3),  deg(i), ier3)
          if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
          call str2dp(words(4),  tmpdp, ier2)
          reff(i) = tmpdp / bohr
          call str2dp(words(5),  tmpdp, ier3)
          crit(i) = tmpdp
          if ((ier1.ne.0).or.(ier2.ne.0).or.(ier3.ne.0)) go to 910
          npaths = npaths + 1
          do 230 j = 1, nleg(i)
             call str2in(words(5+j),ipot(j,i),ier1)
             if (ier1.ne.0) go to 910
 230      continue
c
c  next, read padded arrays for rat,beta, ..., achi, phchi
          call rdpadr(3,npadx, rat(1,1,i),3*nleg(i))
          call rdpadr(3,npadx, beta(1,i),   nleg(i))
          call rdpadr(3,npadx, eta(1,i),    nleg(i))
          call rdpadr(3,npadx, ri(1,i),     nleg(i))
          call rdpadr(3,npadx, achi(1, i),  ne)
          call rdpadr(3,npadx, phchi(1, i), ne)
c  fill in rest of achi and phchi with zeros
          do 270 j = ne+1, nex
             achi(j,i)  = 0
             phchi(j,i) = 0
 270      continue
 300    continue
 450    continue
       close(3)
cc       print*, ' RDFBIN done!'
       return
 900   call wlog (' -- rdfbin error: wrong format : at line')
       go to 990
 905   call wlog (' -- rdfbin error: missing data : at line')
       go to 990
 910   call wlog (' -- rdfbin error:   bad data   : at line')
       go to 990
 920   call wlog (' -- rdfbin error: unknown error: at line')
       go to 990
 930   call wlog (' -- rdfbin error: unknown version of feff.bin')
       go to 990

 990   call wlog (str)
       call par_stop(' -- fatal error reading feff.bin -- ')
       end

      subroutine reff2x(mchi, ispec, ipr6, idwopt, critcw, s02, sig2g,
     1                   tk, thetad, mbconv, absolu,  !KJ added absolu 3-06
     1                   vrcorr, vicorr, alphat, thetae, iabs, nabs,
     4            elnes,ipmin,ipmax,ipstep)   !KJ added this line  1-06     

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

cc    global.dat 
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    mod6.inp
        integer  mchi, idwopt, ipr6, mbconv, absolu  !KJ added absolu 3-06
        double precision  vrcorr, vicorr, s02, tk, thetad
        double precision  alphat, thetae, sig2g

        integer elnes,ipmin,ipmax,ipstep  !KJ my variables  1-06
c     Local stuff
      character*512 slog

c     standard formats for string, integers and real numbers
  10  format(a)
  20  format (20i4)
  30  format (6f13.5)

cc    read global.inp
      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c       configuration average data
        read  (3, 10) slog
        read  (3, 45) nabs, iphabs, rclabs
  45    format ( 2i8, f13.5)
      close(3)
c     read mod6.inp
      open (file='mod6.inp', unit=3, status='old',iostat=ios)
        read (3,10)  slog
        read (3,20)  mchi, ispec, idwopt, ipr6, mbconv, absolu !KJ added absolu 3-06
        read (3,10)  slog
        read (3,30)  vrcorr, vicorr, s02, critcw
        read (3,10)  slog
        read (3,30)  tk, thetad, alphat, thetae, sig2g
      close(3)

      
c  !KJ Next section added to read ELNES variables       1-06
c     read eels.inp
      elnes=0
      open(file='eels.inp',unit=3,status='old',err=900)
        read(3,*,err=900,end=900) 
	read(3,20,err=900,end=900) elnes
        read(3,*,err=900,end=900)
        read(3,*,err=900,end=900)
	read(3,*,err=900,end=900)
	read(3,20,err=900,end=900) ipmin,ipstep,ipmax
      close(3)
      goto 901
900   continue
      elnes=0
901   continue
      if(elnes.eq.0) then
        ipstep=1
	ipmax=1
	ipmin=1
      endif
               
c  !KJ end my changes      

c     transform energies to atomic units
      vrcorr = vrcorr / hart
      vicorr = vicorr / hart

      return
      end
      subroutine xscorr(ispec, emxs ,ne1, ne, ik0, xsec, xsnorm, chia,
     1                  vrcorr, vicorr, cchi)
c     convolute xmu(E)=xsec+xsnorm*chia with lorentzian using 
c     calculations in the complex energy plane

c     Input: ispec - type of spectroscopy
c       emxs - complex energy grid
c       ne1 - number of points on horizonatal axis 
c       ne - total number of points (ne-ne1) points on vertical axis
c       ik0 - Fermi level index on horizontal axis
c       xsec, xsnorm, chia - give function f in complex energy plain
c           xmu(ie) = xsec + xsnorm*chia
c       vrcorr = correction for the shift of the Fermi level
c       vicorr = 0 (disabled)
c     Output: cchi(w) - result of convolution for w = dble(emxs)
c       cchi(w) = \int_C dE xmu(E)*xloss/pi/((E-w)**2+xloss**2) = 
c       xmu(w+i*xloss)* [1/2+atan(w-efermi/xloss)/pi] +
c       \int_C dE ff(E)*xloss/pi/((E-w)**2+xloss**2)
c       where ff(E)=xmu(E)-xmu(w+i*xloss) for w<efermi we use 
c       xmu(efermi+i*xloss) instead of xmu(w+i*xloss);
c       contour C starts at efermi, goes vertically to efermi+i*xloss 
c       and then goes horizontally to infinity + i*xloss

      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension  xsnorm(nex), omega(nex)
      complex*16 emxs(nex), xsec(nex), chia(nex), cchi(nex) 
      complex*16 xmu(nex), aa, bb, c1, f1, f2, ff(nex), xmu0
      parameter (eps4 = 1.0d-4)
      complex*16 ec(nex), fc(nex), e1,e2, z1,z2, corr
      complex*16 lorenz
      external lorenz, astep

      ne2 = ne-ne1
      efermi = dble(emxs(ne)) 
      xloss = dimag(emxs(1))

c     xmu - analytic function in complex energy plain
      do  ie = 1,ne
        xmu (ie) = xsec(ie) + xsnorm(ie)*chia(ie)
      enddo
c     real frequencies
      do ie = 1, ne1
        omega(ie) = dble(emxs(ie))
      enddo

      if (abs(vrcorr).gt.eps4) then
c       account for the fermi level shift
        bb = xmu(ik0)
        efermi = efermi - vrcorr
        call terpc(omega, xmu ,ne1, 1, efermi, bb)

c       shift the vertical axis
        do ie = 1, ne2
          emxs(ne1+ie) = emxs(ne1+ie) - vrcorr
        enddo

c       rescale values on vertical axis
        bb = bb/xmu(ik0)
        do ie = ne1+1, ne
          xmu(ie) = xmu (ie) * bb 
        enddo
      else
        bb = 1
      endif

c     construct the integration countur C
      nc = 0
c     start with points on vertical axis below xloss
      do ie = 1,ne2
        if (dimag(emxs(ne1+ie)).lt.xloss) then
          nc = nc+1
          ec(nc) = emxs(ne1+ie)
          fc(nc) = xmu(ne1+ie)
        endif
      enddo
c     add corner at efermi + xloss*i
      nc = nc+1
      ic0 = nc
      if (abs(vrcorr).gt.eps4) then
        ec(nc) = efermi + coni*xloss
        fc(nc) = bb * xmu(ik0)
      else
        ec(nc) = emxs(ik0)
        fc(nc) = xmu(ik0)
      endif
c     add points on horizontal axis above efermi
      if (ispec.ne.2) then
        do ie = 1,ne1
          if (dble(emxs(ie))-efermi.gt.eps4) then
            nc = nc+1
            ec(nc) = emxs(ie)
            fc(nc) = xmu(ie)
          endif
        enddo
      else
c       ispec=2 - emission calculations- need points below E_fermi
        do ie = ne1,1,-1
          if (efermi-dble(emxs(ie)).gt.eps4) then
            nc = nc+1
            ec(nc) = emxs(ie)
            fc(nc) = xmu(ie)
          endif
        enddo
      endif
c     endo of countour construction
              
c     cycle over frequency points 
      do ie = 1, ne1
        if (omega(ie).ge.efermi) then
          xmu0 = xmu(ie)
          if (ispec.eq.2) xmu0 = xmu(ik0)*bb
        else
          xmu0 = xmu(ik0)*bb
          if (ispec.eq.2) xmu0 = xmu(ie)
        endif
        e1 = omega(ie) + coni*xloss
        e2 = omega(ie) - coni*xloss
        do ic = 1, nc 
          ff(ic) = fc(ic) - xmu0
        enddo
        dele = omega(ie) - efermi
        cchi(ie) = xmu0 * astep( xloss, dele)
        if (ispec.eq.2) cchi(ie) = xmu0 - cchi(ie)
        corr = 0

        if (abs(dele).lt.eps4) dele = 0.0d0
        w1 = dimag(ec(1))
        w2 = dimag(ec(2))
        w3 = dimag(ec(3))
        ip =0

c       add half matsubara pole contribution
c       equivalent to integral from efermi to efermi+i*w1
        corr = corr + lorenz(ip,xloss,w1,dele)*ff(1) *coni*w1
        if (nc0.gt.3) then
c       add sommerfeld correction (correction for derivative)
c         corr = corr + coni * w1**2 / 6   / (w3-w2) *
c    2   (lorenz(ip,xloss,w3,dele)*ff(3)-lorenz(ip,xloss,w2,dele)*ff(2))
        endif


c       cycle over contour points 
        do ic = 1,nc-1
c         perform integration over contour from efermi+i*2*w1 to 
c         efermi+i*xloss; linear interpolation of ff between  z1 and z2
          z1 = ec(ic)
          z2 = ec(ic+1)
c         if (ic.eq.1) z1 = efermi+coni*2*w1
          f1 = ff(ic)
          f2 = ff(ic+1)
c         if (ic.eq.1) f1 = (f1*(z2-z1) + f2*(z1-ec(ic))) / (z2-ec(ic))
c         add correction from pole above real axis
          aa = 0
          if (abs(z1-e1).gt.eps4 .and. abs(z2-e1).gt.eps4) then
            aa = log((z2-e1)/(z1-e1)) *(f1*(z2-e1)+f2*(e1-z1))
c           z1 or z2 equal to e1; in this case corr is exactly zero
          endif
c         second pole 
          aa = aa - log((z2-e2)/(z1-e2)) *(f1*(z2-e2)+f2*(e2-z1))
          corr = corr + aa/ (z2-z1) /2/pi/coni
        enddo
c       end of cycle over contour points
        if (ispec.eq.2) corr = -corr
c       if (ispec.eq.2) corr = 0

        cchi(ie) = cchi(ie) +  corr
c       return the result of convolution minus bare value
        cchi(ie) = cchi(ie) - xmu(ie)
      enddo
c     end of cycle over frequency points

c     restore the input energy mesh
      if (abs(vrcorr).gt.eps4) then
        do  ie = ne1+1, ne
          emxs(ie) = emxs(ie) + vrcorr
        enddo
      endif

      return
      end

      complex*16 function lorenz (ifp, xloss, w, dele)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c     ifp is dummy now. correspond to ifp=0 in old code
c     can remove it and change calls to lorenz in other routines

      lorenz = xloss /pi / (xloss**2+(coni*w-dele)**2)

      return
      end

      double precision function astep ( xloss, dele)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      astep = 0.5d0 + atan(dele/xloss) /pi
      if (astep.lt.0.d0) astep = 0.d0
      if (astep.gt.1.d0) astep = 1.d0

      return
      end
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     nlegx is max number of atoms in any one path
      dimension rat(3,0:nlegx)
      dimension iz(0:nlegx)
c#mn
       external dist

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.

      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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

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#mn
       external atwtd

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
c---------------------------------------------------------------------
c     program sigem
c
c     calculate the Debye-Waller factors for each MS path
c     using the equation-of-motion methods
c
c     input files:  feff.inp and spring.inp
c
c     version 2  ( January 99)
c
c     coded by  A. Poiarkova
c
c---------------------------------------------------------------------
c  References:  
c             for the EM method: Phys. Rev. B , 59, p.948, 1999
c     also see dissertation 
c        "X-ray Absorption Fine Structure Debye-Waller Factors"
c         by Anna V. Poiarkova
c
c---------------------------------------------------------------------
c         tk temperature in degrees K
c         nleg  nlegs in path
c         rat   positions of each atom in path
c         NB Units of distance in this routine
c            are angstroms, including sig2. 
c         sig2 is output DW factor
c
c---------------------------------------------------------------------
      subroutine sigem (sig2mx, sig2x, iem, tk, ipath, nleg, rat, sig2)
      implicit double precision (a-h, o-z)

c={dwpar.h
c-*-fortran-*-
c nlegx1 MUST be the same as legtot, the maximum number of scattering
c       legs in a path
c nphx1 MUST be the same as nphx, the maximum number of atomic species

      parameter (natxdw = 200)
      parameter (nlegx1 = 9)
      parameter (nphx1=7)

c= dwpar.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

c feff parameters (from dim.h):
c     parameter (legtot=9) 
c     parameter (nphx = 7)

      parameter (nphx = nphx1)
      parameter (natx = natxdw)

c local parameters:
      parameter (amu0  = 1.660 54)
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      parameter (nwx = 700)

      double precision sig2mx, sig2x(0:nphx,0:nphx)
      dimension iphat(natx), izph(0:nphx)

c variables shared with rdspr.f:
      dimension rat1(3,natx), iz(natx)
      dimension dm(3,3,natx,natx)
      dimension rnn(3,natx,natx)
      dimension nnl(natx,natx)

c local variables:
      dimension rat(3,0:nlegx1)
      dimension nconv(0:nlegx1)
      dimension q0(3,natx)
      dimension gr(nwx), w(nwx)
      dimension nq0(0:nlegx1) 
      dimension uu(3,natx), up(3,natx), ff(3,natx)

      character*30  fname
      parameter (ntitx1 = 10)
      character*71  title(ntitx1)
      dimension ltit(ntitx1)
c     character*80  titlep(ntitx1)

      character*512 slog
      logical iem_open

      save 
      data nsigc /0/
c-------------------------------------------------------------

      inquire(unit=iem,opened=iem_open)
      if (nsigc.eq.0) then

c Read coordinates and potentials from feff.inp
      call dwrdin (rat1, iphat, izph, natom,
     1            ntitle, title, ltit)

      if (natom.gt.natx) natom=natx
      do 5 iat=1, natom
         iz(iat) = izph(iphat(iat))
         if (iphat(iat).eq.0) i0=iat
  5   continue

c Read spring.inp and build dynamical matrix
      call rdspr(rat1, iz, natom, i0, 
     1           dm, rnn, 
     1           acut, res, wmax, dosfit, zshell, w0,
     1           rintr, iprdos, nnl)

            write(slog,7)
   7        format(2x,'Calculating Debye-Waller factors via EMM...')
            call wlog(slog)
            write(slog,9)
   9        format(2x,'This might take a while.')
            call wlog(slog)

      if (ipath.ne.0.and.iem_open) then
c           Echo title cards to s2_em.dat
            do 10  i = 1, ntitle
               write(iem,12)  title(i)(1:ltit(i))
  10        continue
  12        format (1x, a)
            write(iem,17) tk, natom
  17        format(1x,'temperature =',f7.2,2x,'N_at =',i4)
            write(iem,19)
  19        format (1x, 71('-'))
            write(iem,25)
            write(slog,25)
            call wlog(slog)
  25        format(3x,'ipath',4x,'nleg',3x,'sig2',5x,
     1            'mu_ipath',2x,'check0(%)')
      endif

c Integration parameters:
      wmaxx=sqrt(zshell)
      dt=2.*pi/wmaxx/15.
c top limit in t integration:
      cutoff=2.*sqrt(2.*acut)/res/wmaxx 
      nstep=cutoff/dt
      xlam=acut/(cutoff)**2
      wl=0.0000001
c top limit in w integration:
      wm=wmax*wmaxx 
      dw=0.01 
      nw=(wm-wl)/dw + 1
      if (nw .gt. nwx) then
          nw = nwx
          dw = (wm-wl)/(nw -1)
      endif
      nfit = dosfit*nw/20.

      endif
c------------------------------------

cc    Open path input file (unit in) and read title.  Use unit 2.
c     ntitle2 = 5
c     open(unit=2,file='paths.dat',status='old', iostat=ios)
c     call chopen (ios, 'paths.dat', 'sigem')
c     call rdhead (2, ntitle2, titlep, ltit)
cc    if (ntitle2 .le. 0)  then
cc       titlep(1) = ' '
cc    endif

c 84  continue
c     read(2,*,end=1010) ipath, nleg
c     skip label (x y z ipot rleg beta eta) and read the path
c     read(2,*)
      do 78 ileg=0,nleg
c        read(2,*,end=1010) (rat(j,ileg),j=1,3)
         nconv(ileg)=0
  78  continue

      do 88 n=1,3
         aa = rat(n,nleg)
         do 87 i=0,(nleg-2)
            j=nleg-i
            rat(n,j)=rat(n,j-1)
  87     continue
         rat(n,1)=aa
  88  continue
      do 89 i=1,nleg
         nq0(i)=0.
  89  continue

c nconv converts # of an atom in the nleg list of coordinates (rat) to
c its # in the full list of all atomic coordinates (rat1)
      do 94 i=1,natom
         do 91 n=1,3
   91    q0(n,i)=0.
         do 95 jl=1,nleg
            m=0
            do 93 n=1,3
               l=nint(100.*rat(n,jl))
               l1=nint(100.*rat1(n,i))
               if (abs(l-l1).le.1) m=m+1
   93       continue
            if (m.eq.3) then
              nconv(jl)=i
            endif
   95    continue
   94 continue
c     check that all path atoms are found
      do 96 jl=1,nleg
        if (nconv(jl).eq.0) then
           print*,' did not find atom jl=', jl
           print*, rat(1,jl),rat(2,jl),rat(3,jl)
           call par_stop('SIGREM-1')
        endif
  96  continue

      atmu=0.
      iq0=0
      nconv(0)=nconv(nleg)
      do 100 il=1,nleg
         l=nconv(il)
         do 101 jq=1,iq0
  101    if(nq0(jq).eq.l) go to 102
         iq0=iq0+1
         nq0(iq0)=l
  102    continue
         nq0x=iq0
         i=nconv(il)
         im=nconv(il-1)
         ip=nconv(il+1)
c        if (il.eq.1) im=nconv(nleg)
         if (il.eq.nleg) ip=nconv(1)
         atmass=atwtd(iz(i))
      do 100 n=1,3
         atmu=atmu + 0.25*( rnn(n,i,im)+rnn(n,i,ip) )**2 /atmass
  100 continue
      atmu=1./atmu
      icount=1
  108 continue
      icount= icount+1
      if (icount.gt.10) call par_stop('SIGREM-2')

      do 115 i=1,natom
      do 115 n=1,3
  115 q0(n,i)=0.

c Build initial state vector |Q_j(0)> for the current path
      do 116 n=1,3
      do 116 il=1,nleg
         i=nconv(il)
         im=nconv(il-1)
         ip=nconv(il+1)
         if (il.eq.1) im=nconv(nleg)
         if (il.eq.nleg) ip=nconv(1)
         atmass=atwtd(iz(i))
         q0(n,i)=q0(n,i)+sqrt(atmu/atmass)*(rnn(n,im,i)-rnn(n,i,ip))/2.
  116 continue

c make sure it's normalized <Q_j(0)|Q_j(0)>=1
      q0q0=0.
      do 120 iq0=1,nq0x
      i=nq0(iq0)
      do 120 n=1,3
         q0q0=q0q0+q0(n,i)*q0(n,i)
 120  continue
      p00=nint(q0q0*1000.d0)/1000.d0
      if (abs(p00-1.d0).gt.5.d-4) then
         atmu=atmu/q0q0
         go to 108
      endif

c     to get THz units:
      wnorm=100.*w0/sqrt(amu0*10.) 
c*** moments
      a0=0.
      do 132 il=1,nq0x
      do 132 im=1,nq0x
         l=nq0(il)
         m=nq0(im)
      do 132 n1=1,3
      do 132 n2=1,3
         a0 = a0 + q0(n1,l)*dm(n1,n2,l,m)*q0(n2,m)/w0/w0
  132 continue
      a0=wnorm*sqrt(a0)

      do 125 kw=1, nwx
         gr(kw) = 0.
  125 w(kw) = (wl+(kw-1)*dw)

c  make file prdennnnn.dat
      if (master.and.ipath.ne.0.and.ipath.le.iprdos) then 
         write(fname,130)  ipath
  130    format('prden', i4.4, '.dat')
         open (unit=25, file=fname, status='unknown',iostat=ios)
         call chopen (ios, fname, 'sigem')
         do 134  i = 1, ntitle
            write(25,136)  title(i)(1:ltit(i))
  134    continue
         write(25,135) natom
  135    format('#',1x,'N_at =', i4)
  136    format ('#',1x, a)
         write(25,138)
  138    format ('#',1x, 71('-'))
      endif


c  set initial conditions
      do 150 i=1, natom
      do 150 n=1,3
         uu(n,i)=q0(n,i)
         up(n,i)=uu(n,i)
  150 continue

c Solve 3*natom equations of motion and find projected VDOS (gr)
      dt2=dt*dt
      t=dt/2.
      do 200 kstep = 1, nstep
c        damping factor:
         e1=exp(-xlam*t*t) 
         xat=0.
         do 167 i=1, natom
         do 167 n=1,3
  167    xat = xat + uu(n,i)*q0(n,i)
         xat=xat*e1
         do 170 kw=1, nw
  170    gr(kw) = gr(kw) + xat*cos(w(kw)*t)*dt
         if(kstep.eq.nstep) go to 200

         do 175 i=1,natom
         do 175 n=1,3
  175    ff(n,i)=0.

         do 180 i=1,natom
            jn=1
  185       if (nnl(i,jn).ne.0) then
               j=nnl(i,jn)
               am=w0*w0
               do 187 n1=1,3
               do 187 n2=1,3
                  ff(n1,i)=ff(n1,i)-dm(n1,n2,i,j)*uu(n2,j)/am
                  if(i.ne.j) ff(n1,j)=ff(n1,j)-dm(n1,n2,j,i)*uu(n2,i)/am
  187          continue
               jn = jn + 1
               go to 185
            endif
  180    continue

         do 199 i=1,natom
         do 199 n=1,3
            put=2.*uu(n,i)-up(n,i)+dt2*ff(n,i)
            up(n,i)=uu(n,i)
            uu(n,i)=put
  199    continue

  200 t=t+dt

      afit = 0.
      if (nfit.ne.0) then
         if (w(nfit).ne.0.) afit=gr(nfit)/(w(nfit)**4)
      endif

c fit vibr.density to A*w^4, for low w
      do 225 kw=1, nfit
         gr(kw)=afit*w(kw)**4
  225 continue

c Normalization of the pr.density of modes 
c (it's the 2/pi factor which was left out till now with,
c perhaps, a small diffrence due to the fit) 
      gr(nw)=0.
      if (gr(1).lt.0.) gr(1)=0.
      xx=(gr(1)+gr(nw))*dw/2.
      do 247 kw=2, (nw-1)
         if (gr(kw).lt.0.) gr(kw)=0.
  247 xx = xx + gr(kw)*dw
      cn1=1./xx

      if (master.and.ipath.ne.0.and.ipath.le.iprdos) then
c to get THz units:
         wnorm=100.*w0/sqrt(amu0*10.) 
         write(25,349) ipath, nleg
  349    format('#',2x,'ipath =',i3,2x,'nleg =',i2)
         write(25,350)
c 350    format(1h#,6x,5hw,THz,18x,6hrho(w))
  350    format(1h#,6x,'cm^-1',18x,6hrho(w))
         do 370 kw=1,nw
            write(25,360) w(kw)*wnorm*100./6./pi, gr(kw)*cn1/wnorm
c           write(25,360) w(kw)*wnorm, gr(kw)*cn1/wnorm
  360       format(2x,f10.3,15x,f10.7)
  370    continue
         close (unit=25)
      endif

      wt=tk/187.64/w0
      ccc=cn1
      check0 = abs((2./pi - cn1)/(2./pi))
      check0=check0*100.
      coef = ccc*0.5*0.2587926/atmu/w0
c integrate over w to get sig2
      cth=0.
      s2=0.
c     gr(1)=0.
      do 400 kw=2, (nw-1)
         cth = 1./tanh( w(kw)/(2.*wt) )
         s2 = s2 + coef*gr(kw)*cth*dw/w(kw)
  400 continue
      sig2 = s2

      if (ipath.ne.0.and.iem_open) then
         write(iem,473) ipath, nleg, sig2,atmu,check0
         write(slog,473) ipath, nleg, sig2,atmu,check0
         call wlog(slog)
  473    format(4x,i3,4x,i3,4x,f7.5,3x,f7.3,4x,f5.2)
      endif

      nsigc = nsigc + 1
c1000 go to 84
c1010 continue
c     close (unit=2)
      if (sig2.gt.1.0) then
        sig2 = 1.0d0
        call wlog (' WARNING: Found sig**2>1. Set sig2=1. ')
        write (slog,1011) nconv(1), nconv(2)
 1011   format('          Possible zero ferquency modes with atoms', i4,
     1   ' or', i4)
         call wlog(slog)
         call wlog('          Check springs.inp')
      endif
      if (check0.gt.5.0) then
        write (slog,*) ' WARNING: Failed check0 test:missing VDOS.',
     1  ' Reduce dosfit and/or increase wmax.'
        call wlog(slog)
      endif

c     update maximum DW factors
      if (sig2.gt.sig2mx) sig2mx=sig2
      if (sig2.gt.sig2x( iphat(nconv(1)),  iphat(nconv(2)) )) then
         sig2x( iphat(nconv(1)),  iphat(nconv(2)) ) = sig2
         sig2x( iphat(nconv(2)),  iphat(nconv(1)) ) = sig2
      endif

      return
      end
c----------------------------------------------------
      subroutine dwrdin (rat, iphat, izph, nat,
     1            ntitle, title, ltit)

c     Read feff.inp for sigem.f
c     (here we need only coordinates and potentials)

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

c={dwpar.h
c-*-fortran-*-
c nlegx1 MUST be the same as legtot, the maximum number of scattering
c       legs in a path
c nphx1 MUST be the same as nphx, the maximum number of atomic species

      parameter (natxdw = 200)
      parameter (nlegx1 = 9)
      parameter (nphx1=7)

c= dwpar.h}

c feff parameters:
c     parameter (nphx = 7)

      parameter (nphx = nphx1)
      parameter (natx = natxdw)

      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)

      character*6  potlbl(0:nphx)

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

      parameter (ntitx = 10)
      character*71  title(ntitx)
      dimension ltit(ntitx)
      dimension izph(0:nphx)
      logical iscomm
      parameter (nssx = 16)

      parameter (big = 1.0e5)
      character*512 slog

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

cc    initialize things

      ntitle = 0

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

      nph = 0
      do 110  iph = 0, nphx
         iatph(iph) = 0
         izph(iph) = 0
         potlbl(iph) = ' '
  110 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             7 if TITL (TITLE)
c            10 if DEBY (DEBYE)
c            13 if PRIN (PRINT)
c            14 if POTE (POTENTIALS)
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),'feff.inp')

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. 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

c           elseif (itok .eq. 10)  then
cc             DEBYE  temp debye-temp
cc                  temps in kelvin
cc                  These add to any sig2 from SIG2 card or files.dat
c              read(words(2),30,err=900)  tk
c              read(words(3),30,err=900)  thetad
c              idwopt=0
c              read(words(4),20,err=900)  idwopt
c              mode = 0
            elseif (itok .eq. 14)  then
c              POTENTIALS
c              Following lines are unique potential defs, 1 per line
               mode = 3

            elseif (itok .eq. -1)  then
cc             END
               goto 220
            else
               mode = 0
c *            write(slog,'(1x,a)') line(1:70)
c *            call wlog(slog)
c *            write(slog,'(1x,a)') words(1)
c *            call wlog(slog)
c *            write(slog,'(a,i8)') ' Token ', itok
c *            call wlog(slog)
c *            call wlog(' Keyword unrecognized.')
c *            call wlog(' See FEFF document -- some old features')
c *            call wlog(' are no longer available.')
c *            call par_stop('DWRDIN-1')
            endif
         elseif (mode .eq. 1)  then
            if (itok .ne. 0)  then
cc             We're done reading atoms.
cc             Change mode and process current card.
               mode = 0
               goto 210
            endif
            nat = nat+1
            if (nat .gt. natx)  then
               write(slog,'(1x,a,i5)') 'Too many atoms, max is ', natx
               call wlog(slog)
               write(slog,'(1x,a,i5,a)') 'Only', natx,
     1       ' atoms will be considered in the DW factor calculations.'
               call wlog(slog)
               nat = nat-1
               mode = 0
               goto 210
c              call par_stop('DWRDIN-2')
            endif
            if (nat.le.natx) then
               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)
               if (iphat(nat).eq.0) iat0 = nat
            else
               mode = 0
               goto 210
            endif
         elseif (mode .eq. 3)  then
            if (itok .ne. 0)  then
cc             We're done reading unique potential definitions
cc             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)
               call par_stop('DWRDIN-3')
            endif
            read(words(2),20,err=900)  izph(iph)
cc          No potential label if user didn't give us one
cc          Default set above is potlbl=' '
            if (nwords .ge. 3)  potlbl(iph) = words(3)
         else
            write(slog,'(a,i8)') 
     .        'DWRDIN-4: Mode unrecognized, mode ', mode
c           call wlog(slog)
            call par_stop(slog)
         endif
      goto 200
  220 continue

cc    We're done reading the input file, close it.
      close (unit=1)
            if (nat .gt. natx)  then
               write(slog,'(a,i8)') 'Too many atoms for DW calculations,
     1         max is ', natx
               call wlog(slog)
               write(slog,'(a,i8,a)') 'Only atoms up to #',natx,
     1         '  will be considered'
               call wlog(slog)
            endif

      do 250 iat = 1, nat
      do 250 i = 1,3
        if (iat.ne. iat0) rat(i,iat) = rat(i,iat) - rat(i,iat0)
 250  continue
      do 251 i = 1,3
 251  rat(i,iat0) = 0.d0

cc    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
cc    Must have central atom
      if (izph(0) .le. 0)  then
         call wlog(' No absorbing atom (unique pot 0) was defined.')
         call par_stop('DWRDIN-5')
      endif
cc    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')
               call par_stop('DWRDIN-6')
            endif
         endif
  400 continue

cc    Then find model atoms for unique pots that have them
cc    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
cc                this is the closest so far
                  rabs = tmp
                  iatph(iph) = iat
               endif
            endif
  320    continue
  330 continue
cc    if iatph > 0, a model atom has been found.

      if (ntitle .le. 0)  then
         ntitle = 1
         title(1) = 'Null title'
      endif
      do 490  i = 1, ntitle
         ltit(i) = istrln (title(i))
  490 continue

      return

  900 continue
      call wlog(' Error reading input, bad line follows:')
      write(slog,'(1x,a)') line(1:71)
      call wlog(slog)
      call par_stop('DWRDIN-7 fatal error.')

c      return
      end

c----------------------------------------------------------
      subroutine rdspr(rat1, iz, natom, i0, 
     1           dm, rnn, 
     1           acut, res, wmax, dosfit, zshell, w0, 
     1           rintr, iprdos, nnl)

c     Read spring.inp for multiple scattering feff and
c     build dynamical matrix.

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

c={dwpar.h
c-*-fortran-*-
c nlegx1 MUST be the same as legtot, the maximum number of scattering
c       legs in a path
c nphx1 MUST be the same as nphx, the maximum number of atomic species

      parameter (natxdw = 200)
      parameter (nlegx1 = 9)
      parameter (nphx1=7)

c= dwpar.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

c feff parameters:

c     parameter (nphx = nphx1)
      parameter (natx = natxdw)

c new local parameters:
      parameter (nangx = 7*natx)
      parameter (nsprx = 40)
      parameter (nshx = 100)

c variables shared with sigem.f:
      dimension rat1(3,natx), iz(natx)
      dimension dm(3,3,natx,natx)
      dimension rnn(3,natx,natx)
      dimension nnl(natx,natx)

c local variables:
      dimension rshell(natx,0:nshx)
      dimension nspr(2,nsprx), drij(natx,natx)
      dimension str(natx,natx)
      dimension ang(nangx), dang(nangx)
      dimension nang(3,nangx)
      dimension dmstr(3,3,natx,natx),dma(3,3,natx,natx)
      dimension si(3), sj(3), sk(3)

      character*150  line
      parameter (nwordx = 20)
      character*20  words(nwordx)
      character*512 slog

      logical iscomm

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

c initialize things

      do 40 i=1, natom
      do 40 j=1, natom
         str(i,j)=0.
         drij(i,j)=0.02
   40 continue
      do 47 na=1,nangx
         ang(na)=0.
         dang(na)=0.
      do 47 m=1,3
         nang(m,na)=0
   47 continue

      do 50 ispr=1, nsprx
      do 50 n=1,2
   50 nspr(n,ispr)=0

      acut=3.
      res=0.05
      dosfit=0.
      wmax=1.
      na=1
      nintr=0
      strx=10000.
      ispr=1
      iprdos = 0
      ddrij=0.02
      ddang=0.02

      open(unit=1,file='spring.inp',status='old', iostat=ios)
      call chopen (ios, 'spring.inp', 'rdspr')

c     tokens  0 if not a token
c             1 if STRE (STRETCHES)
c             2 if ANGL (ANGLES)
c             3 if VDOS
c             4 if PRDOS 
c            -1 if END  (end)
c     mode flag  0 ready to read a keyword card
c                1 reading stretches
c                2 reading angle-bends
 
      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),'spring.inp')

c        process the card using current mode
  210    continue

         if (mode .eq. 0)  then
            if (itok .eq. 1)  then
c              STRE
c              Following lines are stretches, one per line
c              read(words(2),20,err=900)  nintr
               mode = 1
            elseif (itok .eq. 2)  then
c              ANGL
c              Following are ...
               mode = 2
            elseif (itok .eq. 3)  then
c              VDOS
c              VDOS  resolution, a_cut, wmax, dosfit
c               0 - do not run modules, 1 - run module
               read(words(2),30,err=900)  res
               read(words(3),30,err=900)  wmax
               read(words(4),30,err=900)  dosfit
               if (nwords.gt.4) then
                   read(words(5),30,err=900)  acut
               endif
               mode = 0
            elseif (itok .eq. 4)  then
c              PRINT  iprdos
c              to print or not to print prdennnnn.dat files;
c              if the card is present, these files will be
c              printed for paths 1 through iprdos
               iprdos = 1 
               read(words(2),20,err=900)  iprdos
               mode = 0
            elseif (itok .eq. -1)  then
c              END
               goto 220
            else
               write(slog,'(1x,a)') line(1:71)
               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.')
             call par_stop('RDSPR-1')
            endif
         elseif (mode .eq. 1)  then
            if (itok .ne. 0)  then
c              We're done reading stretches
c              Change mode and process current card.
               mode = 0
               goto 210
            endif
            read(words(1),20,err=900) ii
            i=ii+1
            call chekin (ii, natom, line)
            read(words(2),20,err=900) jj
            j=jj+1
            call chekin (jj, natom, line)
            read(words(3),30,err=900) str(i,j)
            if (str(i,j).lt.strx) then
               strx=str(i,j)
               ix=i
               jx=j
            endif
            nspr(1,ispr)=i
            nspr(2,ispr)=j
            ispr=ispr+1
            read(words(4),30,err=900) ddrij
            drij(i,j) = abs(ddrij)/100.
            drij(j,i) = abs(ddrij)/100.
         elseif (mode .eq. 2)  then
            if (itok .ne. 0)  then
c              We're done reading angle-bends
c              Change mode and process current card.
               mode = 0
               goto 210
            endif
            read(words(1),20,err=900) ii
            i=ii+1
            call chekin (ii, natom, line)
            read(words(2),20,err=900) jj
            j=jj+1
            call chekin (jj, natom, line)
            read(words(3),20,err=900) kk
            k=kk+1
            call chekin (kk, natom, line)
            read(words(4),30,err=900) ang(na)
            nang(1,na)=i
            nang(2,na)=j
            nang(3,na)=k
            read(words(5),30,err=900) ddang
            dang(na) = abs(ddang)/100.
            na=na+1
         else
            write(slog,'(a,i8)') 'Mode unrecognized, mode ', mode
            call wlog(slog)
            call par_stop('RDSPR-2')
         endif
      goto 200
  220 continue

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

c     write statistics on found bonds and angles into spring.dat 
      if (master) then
        open (unit=2, file='spring.dat', status='unknown',iostat=ios)
        call chopen (ios, 'spring.dat', 'spring')
        write(2,*) ' Statistics on spring constants in spring.inp.'
        write(2,*) '   STRETCHES  i  j  aa   found_number'  
      endif

c find all stretching bonds
      do 321 jspr=1, (ispr-1)
         icnt=0
         i=nspr(1,jspr)
         j=nspr(2,jspr)
         aa = str(i,j)
         ddrij=drij(i,j)
         ip=iz(i)
         jp=iz(j)
         rij = dist (rat1(1,i), rat1(1,j))
         if (aa.eq.0.) go to 321
         do 320 k=1, natom
            do 320 l=k+1, natom
               kp=iz(k)
               lp=iz(l)
               rkl = dist (rat1(1,k), rat1(1,l))
               comp = abs(rij/rkl - 1.)
               if (comp.gt.ddrij) go to 320
               if (ip.ne.kp.or.jp.ne.lp) then
                  if (ip.ne.lp.or.jp.ne.kp) go to 320
               endif
               str(k,l) = aa
               str(l,k) = aa
calex       to check the bonds, that were found
calex        print*, k,l,aa
                icnt = icnt+1
  320    continue
         str(j,i) = aa
         if (master) write (2,*) i-1, j-1, aa, icnt
  321 continue
      if (master) write(2,*) '   BENDS   i  j  k   aa   found_number'  

c find all bending angles
      naxx=nax
      do 323 na=1,nax
         icnt=1
         i=nang(1,na)
         j=nang(2,na)
         k=nang(3,na)
         ddrij=drij(i,j)
         ddrkj=drij(k,j)
         ip=iz(i)
         jp=iz(j)
         kp=iz(k)
         call coss(rat1(1,i),rat1(1,j),rat1(1,k),cosijk)
         rij = dist (rat1(1,i), rat1(1,j))
         rkj = dist (rat1(1,k), rat1(1,j))
         aa=ang(na)
c        print*, na, i,j,k, aa
         do 326 ii=1, natom
         do 326 jj=1, natom
            if (ii.eq.jj) go to 326
            rrij=dist (rat1(1,ii), rat1(1,jj))
            do 322 kk=ii+1, natom
               if (kk.eq.jj) go to 322
               rrkj=dist (rat1(1,kk), rat1(1,jj))
               comp1 = abs(rrij/rij - 1.)
               comp2 = abs(rrkj/rkj - 1.)
               if (comp1.gt.ddrij.or.comp2.gt.ddrkj) then
                  comp1 = abs(rrkj/rij - 1.)
                  comp2 = abs(rrij/rkj - 1.)
                  if (comp1.gt.ddrij.or.comp2.gt.ddrkj) go to 322
               endif
               iip=iz(ii)
               jjp=iz(jj)
               kkp=iz(kk)
            if (iip.ne.ip.or.jjp.ne.jp.or.kkp.ne.kp) then
               if (kkp.ne.ip.or.jjp.ne.jp.or.iip.ne.kp) go to 322
            endif
               call coss(rat1(1,ii),rat1(1,jj),rat1(1,kk),cssijk)
               if (dacos(cosijk).eq.0.) go to 322
                  comp = abs( dacos(cssijk)/dacos(cosijk) -1.)
               if (comp.ge.dang(na)) go to 322
               do 324 na1=1,naxx
                  ii1=nang(1,na1)
                  jj1=nang(2,na1)
                  kk1=nang(3,na1)
               if (ii.eq.ii1.and.jj.eq.jj1.and.kk.eq.kk1) go to 322
               if (kk.eq.ii1.and.jj.eq.jj1.and.ii.eq.kk1) go to 322
 324           continue
               naxx=naxx+1
               ang(naxx)=aa
               nang(1,naxx)=ii
               nang(2,naxx)=jj
               nang(3,naxx)=kk
calex          to check the bends, that were found
c              print*, naxx, ii,jj,kk,aa
               icnt = icnt + 1
               if (naxx.eq.nangx) goto 333
 322        continue
 326     continue
         if (master) write (2,*) i-1, j-1, k-1, aa, icnt
 323  continue
 333  continue

      if (master) close (unit=2)

      do 325 i=1, natom
      do 325 nshell=0, nshx
         rshell(i,nshell)=0.
 325  continue

c find shells
      rintr=0.
      nintr=1
      do 330 i=1, natom
      nshell=0
      do 335 j=1, natom
         if (j.eq.i) go to 332
         if (nshell.gt.nshx) go to 332
         rij = dist (rat1(1,i), rat1(1,j))
         ddrij=drij(i,j)
         ncount=0
         do 331 ish=0, nshell
            b = real(rshell(i,ish))
            dif=1.
            if (b.ne.0.) dif = abs(rij -b)/b
            if (dif.le.ddrij) ncount=ncount+1 
 331     continue
         if (ncount.eq.0) then
            nshell = nshell + 1
            if (str(i,j).ne.0.and.rij.gt.rintr) rintr=rij
            rshell(i,nshell) = rij
         endif
 332     do 335 n=1,3
         rnn(n,i,j)=0.
         do 335 m=1,3
            dmstr(n,m,i,j)=0.
            dma(n,m,i,j)=0.
            dm(n,m,i,j)=0.
 335  continue
c sort rshell into ascending numerical order
c and find maximum order of interacting neighbor nintr
      do 342 jsh=2,nshell 
         aa = rshell(i,jsh)
         do 341 ish=jsh-1,1,-1
            if(rshell(i,ish).le.aa) go to 340
            rshell(i,ish+1)=rshell(i,ish)
 341     continue
         ish=0
 340     rshell(i,ish+1) = aa
         if (aa.le.rintr.and.(ish+1).gt.nintr) nintr = ish+1
 342  continue
 330  continue

      zshell=0.
      i1=0
      do 350 i=1,natom
         do 352 in=1,natx
 352     nnl(i,in)=0
         do 350 j=i+1,natom
            dx=rat1(1,j)-rat1(1,i)
            dy=rat1(2,j)-rat1(2,i)
            dz=rat1(3,j)-rat1(3,i)
            dr=sqrt(dx*dx+dy*dy+dz*dz)
            rnn(1,i,j)=dx/dr
            rnn(2,i,j)=dy/dr
            rnn(3,i,j)=dz/dr
            rnn(1,j,i)=-rnn(1,i,j)
            rnn(2,j,i)=-rnn(2,i,j)
            rnn(3,j,i)=-rnn(3,i,j)
            rrij = abs( dr/rshell(1,1) -1.)
c           if (i.eq.1.and.rrij.le.drij(i,j)) zshell=zshell+1
            if (i.eq.i0.and.rrij.le.drij(i,j)) then
               zshell=zshell+1
               if (i1.eq.0.and.str(i,j).ne.0.) i1 = j
            endif
  350 continue

c Build dynm. matrix for angle bends 
      nan=0
      do 355 na=1,naxx
c        print*,na, naxx, nangx
         i=nang(1,na)
         j=nang(2,na)
         k=nang(3,na)
         if (i.eq.j.or.j.eq.k) go to 355
         if(ang(na).eq.0.) go to 355
         nan=nan+1
         rij = dist(rat1(1,i),rat1(1,j))
         rkj = dist(rat1(1,k),rat1(1,j))
         if (rij.gt.rintr.or.rkj.gt.rintr) go to 355
         call sang (i, j, k, rat1, si, sj, sk)
         do 357 n1=1,3
         do 357 n2=1,3
            dma(n1,n2,i,j)=dma(n1,n2,i,j)+ang(na)*si(n1)*sj(n2)
            dma(n1,n2,j,k)=dma(n1,n2,j,k)+ang(na)*sj(n1)*sk(n2)
            dma(n1,n2,i,k)=dma(n1,n2,i,k)+ang(na)*si(n1)*sk(n2)

            dma(n1,n2,i,i)=dma(n1,n2,i,i)+ang(na)*si(n1)*si(n2)
            dma(n1,n2,j,j)=dma(n1,n2,j,j)+ang(na)*sj(n1)*sj(n2)
            dma(n1,n2,k,k)=dma(n1,n2,k,k)+ang(na)*sk(n1)*sk(n2)

            dma(n2,n1,j,i)=dma(n1,n2,i,j)
            dma(n2,n1,k,j)=dma(n1,n2,j,k)
            dma(n2,n1,k,i)=dma(n1,n2,i,k)
  357    continue
  355 continue

c Build dynm. matrix for stretches 
      do 375 l=1,natom
      do 375 m=l,natom
         do 373 n1=1,3
            x2=str(l,m)*rnn(n1,l,m)
         do 373 n2=1,3
         dmi=0.
         if (l.eq.m) then
            do 377 i=1,natom
               if (real(str(i,m)).eq.0.) go to 377
               dmi = dmi + str(i,m)*rnn(n1,i,m)*rnn(n2,i,m)
 377        continue
         endif
         dmstr(n1,n2,l,m) = dmi - x2*rnn(n2,l,m)
         dmstr(n2,n1,m,l)=dmstr(n1,n2,l,m)
 373  continue
 375  continue

c Add two dynm. matrices D_str+D_ang
      lnx=0
      do 380 i=1,natom
      ami=sqrt(atwtd(iz(i)))
      in=0
      do 380 j=1,natom
      amj=sqrt(atwtd(iz(j)))
      sumdm=0.
      do 381 n1=1,3
      do 381 n2=1,3
         dmdm=dma(n1,n2,i,j)+dmstr(n1,n2,i,j)
         sumdm=sumdm+abs(dmdm)
         dm(n1,n2,i,j)=dmdm/ami/amj
 381  continue
      if (real(sumdm).ne.0.and.i.le.j) then
         in=in+1
         nnl(i,in)=j
      endif
      if (in.ge.lnx) lnx=in
 380  continue

      atmu = 1./(1./atwtd(iz(i0)) + 1./atwtd(iz(i1)))
      a0=0.
      do 450 i=1,2
      do 450 j=1,2
      if (i.eq.1) l=i0
      if (i.eq.2) l=i1
      if (j.eq.1) m=i0
      if (j.eq.2) m=i1
      do 450 n1=1,3
      do 450 n2=1,3
         fact = (-1)**(i+j)*atmu
         atmass = 1./atwtd(iz(l))/atwtd(iz(m))
         a0 = a0 + fact*sqrt(atmass)*rnn(n1,i0,i1)*
     1             dm(n1,n2,l,m)*rnn(n2,i0,i1)
  450 continue
c     effective freq. for the 1st shell:
      w0=sqrt(a0) 
      if (w0.eq.0.) then
         atmux = 1./(1./atwtd(iz(ix)) + 1./atwtd(iz(jx)))
         w0=sqrt(strx/atmux)
      endif

      return

  900 continue
      call wlog(' Error reading input, bad line follows:')
      write(slog,'(1x,a)') line(1:71)
      call wlog(slog)
      call par_stop('RDSPR fatal error.')

cc      return
      end

c---------------------------------------------------

      subroutine sang (i, j, k, rat1, si, sj, sk)

c*calculates coeficients s  (Sint=sum {si*ui}) connecting internal
c*coordinate delta_phi(ijk)=(valence ijk angle bend) with ui (atomic
c*displacements)

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

c={dwpar.h
c-*-fortran-*-
c nlegx1 MUST be the same as legtot, the maximum number of scattering
c       legs in a path
c nphx1 MUST be the same as nphx, the maximum number of atomic species

      parameter (natxdw = 200)
      parameter (nlegx1 = 9)
      parameter (nphx1=7)

c= dwpar.h}

      parameter (natx = natxdw)

      dimension rat1(3,natx), rji(3), rjk(3)
      dimension eji(3), ejk(3), ej(3)
      dimension si(3), sk(3), sj(3)

      dji=0.
      djk=0.
      dik=0.
      do 905 m = 1, 3
         rji(m) = rat1(m,i) - rat1(m,j)
         rjk(m) = rat1(m,k) - rat1(m,j)
         dji = dji + rji(m)**2
         djk = djk + rjk(m)**2
         dik = dik + ( rat1(m,k) - rat1(m,i) )**2
         si(m) = 0.
         sj(m) = 0.
         sk(m) = 0.
  905 continue
      dji = sqrt(dji)
      djk = sqrt(djk)
      dik = sqrt(dik)

      dotj=0.
      do 910 m = 1, 3
         eji(m) = rji(m)/dji
         ejk(m) = rjk(m)/djk
         dotj = dotj + eji(m) * ejk(m)
  910 continue
c     ri = dji
c     rk = djk
c     rj = sqrt(dji*djk)
c     rj = dik
      rj=1.
      call vect (eji, ejk, ej, sinj)
      do 920 m = 1, 3
         si(m) = rj*(dotj * eji(m) - ejk(m))/dji/sinj
         sk(m) = rj*(dotj * ejk(m) - eji(m))/djk/sinj
         sj(m) = rj*((dji - djk * dotj)*eji(m) +
     1              (djk - dji * dotj)*ejk(m))/dji/djk/sinj
  920 continue
      return
      end

c-----------------------------------------------------------
      subroutine vect (v1, v2, v3, sin12)

c*calculates vector product v3 = [v1 x v2] and sin of the angle

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

      dimension v1(3), v2(3), v3(3)

      v3(1) = v1(2)*v2(3) - v1(3)*v2(2)
      v3(2) = v1(3)*v2(1) - v1(1)*v2(3)
      v3(3) = v1(1)*v2(2) - v1(2)*v2(1)
      d1 = 0.
      d2 = 0.
      d3 = 0.
      do 990 m = 1, 3
         d1 = d1 + v1(m)**2
         d2 = d2 + v2(m)**2
         d3 = d3 + v3(m)**2
  990 continue
      sin12 = sqrt(d3/d1/d2)
      return
      end

c-----------------------------------------------------------
      subroutine coss (v1,v2,v3,cos12)
c* calculates cos between two vectors v1-v2 and v3-v2
      implicit double precision (a-h, o-z)
      dimension v1(3), v2(3), v3(3)

      vv1=0.
      vv2=0.
      scal=0.
      do 995 m=1,3
         vv1=vv1+(v1(m)-v2(m))**2
         vv2=vv1+(v3(m)-v2(m))**2
         scal=scal+(v1(m)-v2(m))*(v3(m)-v2(m))
  995 continue
      cos12=scal/vv1/vv2
      return
      end

c-----------------------------------------------------------
      subroutine chekin (i, natom, line)
      character*150  line
      character*512  slog

            if (i .gt. (natom-1) .or. i .lt. 0) then
               write(slog,'(a,i8)')
     1             'the atomic indexes must be between 0 and ',
     1             (natom - 1)
               call wlog(slog)
               write(slog,'(i8,a)') i, ' not allowed'
               call wlog(slog)
               write(slog,'(1x,a)') line(1:71)
               call wlog(slog)
               call par_stop('RDSPR')
            endif
        return
        end

c---------------------------------------------------------------------
c     program sigrm
c
c     calculate the Debye-Waller factors for each MS path
c     using the recursion method
c
c     input files:  feff.inp and spring.inp
c
c     version 2  ( January 99)
c
c     coded by  A. Poiarkova
c
c---------------------------------------------------------------------
c  References:
c             for the RM: J. Synchrotron Rad., 1999 (to bu published)
c     also see dissertation
c        "X-ray Absorption Fine Structure Debye-Waller Factors"
c         by Anna V. Poiarkova
c
c---------------------------------------------------------------------
c         tk temperature in degrees K
c         nleg  nlegs in path
c         rat   positions of each atom in path
c         NB Units of distance in this routine
c            are angstroms, including sig2.
c         sig2 is output DW factor
c
c---------------------------------------------------------------------
      subroutine sigrm (sig2mx, sig2x,ir1, ir2, tk,ipath,nleg,rat,sig2)
      implicit double precision (a-h, o-z)

c={dwpar.h
c-*-fortran-*-
c nlegx1 MUST be the same as legtot, the maximum number of scattering
c       legs in a path
c nphx1 MUST be the same as nphx, the maximum number of atomic species

      parameter (natxdw = 200)
      parameter (nlegx1 = 9)
      parameter (nphx1=7)

c= dwpar.h}

c feff parameters (from dim.h):
c     parameter (legtot=9) 
c     parameter (nphx = 7)

      parameter (nphx = nphx1)
      parameter (natx = natxdw)

c local parameters:
      parameter (amu0  = 1.660 54)
      double precision sig2mx, sig2x(0:nphx,0:nphx)
      dimension iphat(natx), izph(0:nphx)

c variables shared with rdspr.f:
      dimension rat1(3,natx), iz(natx)
      dimension dm(3,3,natx,natx)
      dimension rnn(3,natx,natx)
      dimension nnl(natx,natx)

c local variables:
      dimension rat(3,0:nlegx1)
      dimension nconv(0:nlegx1)
      dimension q0(3,natx)
c   list of atoms |0>=|Q>:
      dimension nq0(0:nlegx1)  
c   state |1>=D|Q>:
      dimension q1(3,natx)  
c   list of atoms in |1>:
      dimension nq1(natx)   

c     character*30  fname
      parameter (ntitx1 = 10)
      character*71  title(ntitx1)
      dimension ltit(ntitx1)
c     character*80  titlep(ntitx1)

      character*512 slog

      logical ir1_open, ir2_open

      save 
      data nsigc /0/
c-------------------------------------------------------------

      inquire(unit=ir1,opened=ir1_open)
      inquire(unit=ir2,opened=ir2_open)

      if (nsigc.eq.0) then
c        Read coordinates and potentials from feff.inp
         call dwrdin (rat1, iphat, izph, natom,
     1            ntitle, title, ltit)

         if (natom.gt.natx) natom=natx
         do 5 iat=1, natom
            iz(iat) = izph(iphat(iat))
            if (iphat(iat).eq.0) i0=iat
  5      continue

         write(slog,7)
   7     format(2x,'Calculating Debye-Waller factors via RM...')
         call wlog(slog)
         write(slog,9)
   9     format(2x,'This might take a while.')
         call wlog(slog)

c        Read spring.inp and build dynamical matrix
         call rdspr(rat1, iz, natom, i0, 
     1           dm, rnn, 
     1           acut, res, wmax, dosfit, zshell, w0,
     1           rintr, iprdos, nnl)

         if (ipath.ne.0) then
	    if(ir1_open) then
c             Echo title cards to s2_rm2.dat
              do 10  i = 1, ntitle
                write(ir1,12)  title(i)(1:ltit(i))
  10          continue
  12          format (1x, a)
              write(ir1,17) tk, natom
  17          format(1x,'temperature =',f7.2,2x,'N_at =',i4)
              write(ir1,19)
  19          format (1x, 71('-'))
              write(ir1,25)
              write(slog,25)
  25          format(1x,'ipath',2x,'nleg',4x,'sig2',3x,'mu_ipath',4x,
     1          'w_1',6x,'w_2',7x,'A1',5x,'A2')
              call wlog(slog)
            endif
            if (iprdos.ne.0.and.ir2_open) then
c              Echo title cards to s2_rm1.dat
               do 30  i = 1, ntitle
                  write(ir2,12)  title(i)(1:ltit(i))
  30           continue
               write(ir2,17) tk, natom
               write(ir2,19)
               write(ir2,35)
  35           format(1x,'ipath',2x,'nleg',4x,'sig2',3x,'mu_ipath',
     1              4x,'w_e')
            endif
         endif
      endif
      nsigc = nsigc + 1
c---- end of first time reading -------

cc    Open path input file (unit in) and read title.  Use unit 2.
c     ntitle2 = 5
c     open(unit=2,file='paths.dat',status='old', iostat=ios)
c     call chopen (ios, 'paths.dat', 'sigrm')
c     call rdhead (2, ntitle2, titlep, ltit)
cc    if (ntitle2 .le. 0)  then
cc       titlep(1) = ' '
cc    endif

c 84  continue
c     read(2,*,end=1010) ipath, nleg
c     skip label (x y z ipot rleg beta eta) and read the path
c     read(2,*)
      do 78 ileg=0,nleg
c        read(2,*,end=1010) (rat(j,ileg),j=1,3)
         nconv(ileg)=0
  78  continue

      do 88 n=1,3
         aa = rat(n,nleg)
         do 87 i=0,(nleg-2)
            j=nleg-i
            rat(n,j)=rat(n,j-1)
  87     continue
         rat(n,1)=aa
  88  continue
      do 89 i=1,nleg
         nq0(i)=0.
  89  continue

c nconv converts # of an atom in the nleg list of coordinates (rat) to
c its # in the full list of all atomic coordinates (rat1)
      do 94 i=1,natom
         do 91 n=1,3
            q1(n,i)=0.
   91    q0(n,i)=0.
            do 95 jl=1,nleg
            m=0
            do 93 n=1,3
               l=nint(100.*rat(n,jl))
               l1=nint(100.*rat1(n,i))
               if (abs(l-l1).le.1) m=m+1
   93       continue
            if (m.eq.3) then
              nconv(jl)=i
              go to 95
            endif
   95    continue
   94 continue

      atmu=0.
      inn=1
      nq1(inn)=1
      iq0=0
      nconv(0)=nconv(nleg)
      do 100 il=1,nleg
         l=nconv(il)
         do 101 jq=1,iq0
  101    if(nq0(jq).eq.l) go to 102
         iq0=iq0+1
         nq0(iq0)=l
  102    continue
         do 105 ii=1,natom
            a = dist(rat1(1,ii),rat1(1,l))
            if (a.le.rintr) then
               do 103 jn=1,inn
  103          if(nq1(jn).eq.ii) go to 105
               inn=inn+1
               nq1(inn)=ii
            endif
  105    continue
         nq1x=inn
         nq0x=iq0
         i=nconv(il)
         im=nconv(il-1)
         ip=nconv(il+1)
c        if (il.eq.1) im=nconv(nleg)
         if (il.eq.nleg) ip=nconv(1)
         atmass=atwtd(iz(i))
      do 100 n=1,3
         atmu=atmu + 0.25*( rnn(n,i,im)+rnn(n,i,ip) )**2 /atmass
  100 continue
      atmu=1./atmu
  108 continue

      do 115 i=1,natom
      do 115 n=1,3
  115 q0(n,i)=0.

c Build initial state vector |Q_j(0)> for the current path
      do 116 n=1,3
      do 116 il=1,nleg
         i=nconv(il)
         im=nconv(il-1)
         ip=nconv(il+1)
         if (il.eq.1) im=nconv(nleg)
         if (il.eq.nleg) ip=nconv(1)
         atmass=atwtd(iz(i))
         q0(n,i)=q0(n,i)+sqrt(atmu/atmass)*(rnn(n,im,i)-rnn(n,i,ip))/2.
  116 continue

c make sure it's normalized <Q_j(0)|Q_j(0)>=1
      q0q0=0.
      do 120 iq0=1,nq0x
      i=nq0(iq0)
      do 120 n=1,3
         q0q0=q0q0+q0(n,i)*q0(n,i)
 120  continue
      p00=nint(q0q0*1000.)/1000.
      if (abs(p00-1.d0).gt.5.d-4) then
         atmu=atmu/q0q0
         go to 108
      endif

c     to get THz units:
      wnorm=100.*w0/sqrt(amu0*10.) 
c*** moments
      a0=0.
      do 132 il=1,nq0x
      do 132 im=1,nq0x
         l=nq0(il)
         m=nq0(im)
      do 132 n1=1,3
      do 132 n2=1,3
         a0 = a0 + q0(n1,l)*dm(n1,n2,l,m)*q0(n2,m)/w0/w0
  132 continue
      we=wnorm*sqrt(a0)
      if (we.lt.1) then
c        recursion method is inapplicable, use statistics to set sig2
         sig2 = sig2x ( iphat(nconv(1)),  iphat(nconv(1)) )
         if (sig2.lt.1.d-6) sig2 = sig2mx
         return
      endif

      do 137 iset=1,nq1x
         i=nq1(iset)
      do 137 n1=1,3
            q1i=0.
            do 138 im=1,nq0x
               m=nq0(im)
            do 138 n2=1,3
               q1i=q1i+dm(n1,n2,i,m)*q0(n2,m)/w0/w0
  138       continue
         q1(n1,i) = q1i - a0*q0(n1,i)
  137 continue

      b0=0.
      do 139 i=1,natom
      do 139 n1=1,3
         b0=b0+q1(n1,i)*q1(n1,i)
  139 continue

      a1=0.
      do 150 iset=1,nq1x
         i=nq1(iset)
         do 150 n1=1,3
         q2=0.
         do 151 jset=1,nq1x
         j=nq1(jset)
            do 151 n2=1,3
               q2 = q2 + dm(n1,n2,i,j)*q1(n2,j)/w0/w0
  151       continue
            a1 = a1 + q1(n1,i)*q2
  150 continue

      a0=a0*wnorm**2
      a1=a1/b0
      a1=a1*wnorm**2
      b0=b0*wnorm**4

c** recursion sigma^2
      dd = (a0+a1)**2 - 4.*(a0*a1-b0)
      x1 = (a0+a1+sqrt(dd))/2.
      x2 = (a0+a1-sqrt(dd))/2.
      aa2 = (a1-x2)/(x1-x2)
c     aa2 = (a1-x2)/(x1-x2)*9./8.
      aa1 = (x1-a1)/(x1-x2)
      w1 = sqrt(x1)
      w2 = sqrt(x2)
      s1 = 3.1746/(atmu*w1*tanh(w1*7.6383/2./tk))
      s2 = 3.1746/(atmu*w2*tanh(w2*7.6383/2./tk))
      sigma2 = aa1*s1+aa2*s2
      sig2e = 3.1746/(atmu*we*tanh(we*7.6383/2./tk))

      if (ipath.ne.0) then
         write(slog,250) ipath,nleg,sigma2,atmu,w1,w2,aa1,aa2
         call wlog(slog)
         if (ir1_open) then
           write(ir1,250) ipath,nleg,sigma2,atmu,w1,w2,aa1,aa2
  250      format(1x,i3,4x,i1,3x,f9.5,2x,f7.3,2x,f7.2,2x,f7.2,
     1       4x,f5.3,2x,f5.3)
         endif
         if (iprdos.ne.0.and.ir2_open) then
            write(ir2,260) ipath,nleg,sig2e,atmu,we
  260       format(1x,i3,4x,i3,3x,f7.5,2x,f7.3,2x,f7.2)
         endif
      endif
      sig2 = sigma2

c     update maximum DW factors
      if (sig2.gt.sig2mx) sig2mx=sig2
      if (sig2.gt.sig2x( iphat(nconv(1)),  iphat(nconv(2)) )) then
         sig2x( iphat(nconv(1)),  iphat(nconv(2)) ) = sig2
         sig2x( iphat(nconv(2)),  iphat(nconv(1)) ) = sig2
      endif

      return
      end
c----------------------------------------------------
      subroutine sigte3 (iz1,iz2, sig2, alphat, thetad, reff, sig1,sig3)
c     single scattering only.

c     input: sig2
c     iz1, iz2 are iz at central atom and neighbor
c     alphat coeef of thermal expansion at high T
c     reff

c     output: sig1 sig3
      implicit double precision (a-h, o-z)
      real reff

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)
      parameter (hbar = 1.054 572 666 e-34)
      parameter (amu = 1.660 540 e-27)
      parameter (xkb = 1.380 6581 e-23)

      ami=atwtd(iz1)*amu
      amj=atwtd(iz2)*amu

c     reduced mass
      xmu = 1 / (1/ami + 1/amj)
c     Einstein frequency
      omega = (2 * xkb * thetad) / (3 * hbar)
      xks = xmu * omega**2
      xk3 = xks**2 * reff * alphat / (3 * xkb)
      sig02 = hbar * omega / xks
      sig1 = -3 * (xk3 / xks) * sig2
      sig3 = 2 - (4.0/3.0) * (sig02 / sig2)**2
      sig3 = sig3 * (sig1 * sig2)

      return
      end
      subroutine sigm3(sig1, sig2, sig3, tk, alphat, thetae)
c     using correlated Einstein-model with a morse potential
c     Nguyen Van Hung & J.J.Rehr Phys. Rev. B 56 , 43

      implicit double precision (a-h, o-z)
      real sig02,  sig01, z
c     dimension alphat=[1/anstroems]
      parameter (bohr = 0.529 177 249d0)
      parameter(three= 3)
      parameter(four= 4 )
      parameter(fourthird= four/three)
      parameter(threequater= three/four)
              
      alphat= alphat * bohr  
      z=exp(- thetae/tk)
      sig02= (1-z)/ (1+z) * sig2
      sig01 = alphat * sig02 * threequater
      sig1 = sig01 * sig2 / sig02
      sig3 = (2- fourthird * (sig02/sig2) **2)* sig1 * sig2

      return
      end
c---------------------------------------------------------------------
c     program sigcl.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     Hacked for classical Debye Model, 7/2006, Kevin Jorissen  !KJ
c
c---------------------------------------------------------------------

      subroutine sigcl (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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     nlegx is max number of atoms in any one path
      dimension rat(3,0:nlegx)
      dimension iz(0:nlegx)
c#mn
       external dist

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.

      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 corrfn2 (rij, cij, thetad, tk, iz(il), iz(jl), rs)
         sig2ij=cij

         rimjm = dist (rat(1,il-1), rat(1,jl-1))
         call corrfn2 (rimjm, cimjm, thetad, tk, iz(il-1), iz(jl-1), rs)
         sig2ij=sig2ij+cimjm

         rijm = dist (rat(1,il), rat(1,jl-1))
         call corrfn2 (rijm, cijm, thetad, tk, iz(il), iz(jl-1), rs)
         sig2ij=sig2ij-cijm

         rimj = dist (rat(1,il-1), rat(1,jl))
         call corrfn2 (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 corrfn2(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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

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#mn
       external atwtd

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 bingrt2 (grater, eps, nx)
      cij=fac*grater
      return
      end
      double precision function fn2(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
      fn2=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)
!      fn2=fac*(1+emwy)/(1-emwy)
      fn2=fac*2*yinv/w  !KJ coup de grace
      return
      end
c-----------------------------------------------
      subroutine bingrt2 (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=(fn2(zero)+fn2(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+fn2(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
c///////////////////////////////////////////////////////////////////////
c Distribution:  FEFF_ATOM 1.0
c Copyright (c) [2002] University of Washington
c 
c This software was prepared in part with US Government Funding under
c DOE contract DE-FG03-97ER45623.

c Redistribution and use of this Distribution in source and binary
c formats, with or without modification is permitted, provided the 
c following conditions are met:
c 
c Redistributions must retain the above notices and the following list
c of conditions and disclaimer;
c 
c Modified formats carry the marking
c     "Based on or developed using Distribution: FEFF_ATOM 1.0
c      FEFF_ATOM 1.0 Copyright (c) [2002] University of Washington"
c 
c Recipient acknowledges the right of the University of Washington to
c prepare uses of this Distribution and its modifications that may be
c substantially similar or functionally equivalent to
c Recipient-prepared modifications.
c
c Recipient and anyone obtaining access to the Distribution through
c recipient's actions accept all risk associated with possession and
c use of the Distribution.
c
c THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
c WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
c MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
c IN NO EVENT SHALL THE UNIVERSITY OF WASHINGTON OR CONTRIBUTORS TO THE
c DISTRIBUTION BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
c EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
c PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
c REVENUE; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
c LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
c NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
c SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      subroutine scfdat ( ipr1, iph, nph, iz, ihole, xion, iunf, vcoul,
     1     srho, dmag, srhovl, ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,
     2     s02, efrozn, eatom, xntot, xnval, indorb, norbp, eorb, kappa)
c     single configuration Dirac-Fock atom code
c     Ankudinov, Zabinsky, Rehr, Comp.Phys. Comm. 98, p.359 (1996).
c     which is modified Desclaux multi-configuration code.
c     written by a.ankudinov 1996

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

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
c     save central atom dirac components, see comments below.
      dimension dgc0(251), dpc0(251)
      dimension dgc(251, 30, 0:nphx), dpc(251, 30, 0:nphx)
      dimension adgc(10, 30, 0:nphx), adpc(10, 30, 0:nphx)
      dimension xntot(0:lx), xnval(30), eorb(30), kappa(30)
      dimension xmag(30)
 
      dimension vcoul(251)
      dimension srho(251), dmag(251), srhovl(251)
c     temporary do not use core-valence separation
      dimension xnvalp(30), indorb(-4:3)
      logical open_16
     
      dimension ovpint(30, 30)
      character*30 fname
c#mn:
       external dsordf

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'/
 
      if (ipr1 .ge. 3 .and. iph.le.nph)  then
c        do not want to have extra file
c        prepare file for atom output
         write(fname,14)  iph
   14    format('atom', i2.2, '.dat')
         if (master) then
           open (unit=16, file=fname, status='unknown', iostat=ios)
           open_16 = .true.
         else
           open_16 = .false.
         endif
c        call chopen (ios, fname, 'atom')
c        call head (16)
         if (open_16) write (16,*)  ' free atom ', iph
      endif

c  initialize the data and test parameters
      jfail = 0
      ibgp = 10
      numerr = 0
      nz = iz
 11   call inmuat (ihole, xion, iunf, xnval, iholep, xmag, indorb)

      idfock = 1
c     idfock = 2
c     idfock=1  --  pure Dirac-Fock.
c     idfock=2  --  pure LDA
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
      elseif (idfock.eq.2) then
         do 44 i=1,30
  44     xnvalp(i) = xnel(i)
      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
      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 (ipr1 .ge. 5 .and. iph.le.nph .and. open_16)  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
      call par_stop('SCFDAT-1')
 999  if (numerr .eq. 0) then
         if (jfail .ne. 0) then
            call par_stop(
     1    '  Failed to match lower component, results are meaningless')
c           stop
         endif
c        tabulation of the results
         if (ipr1 .ge. 5 .and. iph.le.nph)  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) 

c        jcore = 1

c        prepare information for SCMT and core-valence separation
         norbp = norb
         do 499 i = 0,lx
  499    xntot(i)=0.0d0
         do 500 j = 1, norb
           eorb(j) = en(j) 
           kappa(j) = kap(j)
           i = kap(j)
           if (kap(j) .lt.0) i=-kap(j)-1
           if (i.le.lx) xntot(i)=xntot(i)+xnval(j)
  500    continue
c 500     if (xnel(j).gt.xnval(j) .and. nmax(j).gt.jcore) jcore=nmax(j)

c  get difference in spin-up and -down densities per spin 
c  the spin - polarizable orbitals are specified in subroutine getorb
c  The spin amplitude and directions are taken care of in subroutine ovrlp
c  and specified in feff.inp file
         spin = 0
         do 530 i = 1, idim
  530    dmag(i) = 0.0
         do 536 iorb = 1, norb
           spin = spin + xmag(iorb)
           do 535 i = 1, np
  535      dmag(i)= dmag(i)+ xmag(iorb)* (cg(i,iorb)**2 + cp(i,iorb)**2)
  536    continue
         if (spin.gt.0.d0) then
c          normalize dmag per  spin
           do 537 i = 1, np
  537      dmag(i) = dmag(i) / spin
         endif

c  return coulomb potential
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)) 

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 (ipr1 .ge. 3 .and. iph.le.nph)  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, iunf, i, j, indorb,
     1                   iholep, nre, nq, scw, sce, eps)
            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,iph) = cg(i,j)
               dpc(i,j,iph) = cp(i,j)
  570       continue
            do 575 i = nmax(j) + 1, 251
               dgc(i,j,iph) = 0.0d 00
               dpc(i,j,iph) = 0.0d 00
  575       continue
            do 580 i = 1, 10
               adgc(i,j,iph) = bg(i,j)
               adpc(i,j,iph) = 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
c        this logic is fulfilled only in the last call of scfdat
c        in subroutine pot ( ihole=0 and iholep=ispinr.neq.0)
         efrozn = en(iholep) 
         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
           iph1 = 0
           if (iph.eq.0) iph1 = nph + 1
           do 720 ir = 1, idim
             gg(ir) = dgc(ir, i0, iph1)
  720        gp(ir) = dpc(ir, i0, iph1)
           do 730 ir = 1, ndor
              ag(ir) = adgc(ir, i0, iph1)
  730         ap(ir) = adpc(ir, i0, iph1)
           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
         do 810 j=1,norb
             xnel(j) = xnel(j)-xnval(j)
 810     continue

c        need better control here. for now always print fpf0.dat
c        if (ipr1.ge.3) call  fpf0 ( iz, iholep, srho, dr, hx,
         call  fpf0 ( iz, iholep, srho, dr, hx,
     1     dgc0, dpc0, dgc, dpc,
     2     eatom, xnel, norb, eorb, kappa)

         call s02at (iholep, norb, kap, xnel, ovpint, s02)
c        print*,'z=',iz, '   s02 calculated = ', s02
      endif

      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
      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
      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 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) call par_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 par_stop
     .     ('stopped in programm nucdev, ndor should be > 4.')
c        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 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)
c#mn
       external akeato, bkeato, aprdev
 
      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 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)
c#mn
       external aprdev
 
      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
      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
      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 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 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)
c#mn
       external akeato, bkeato, fdrirk
 
      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 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
c#mn
       external dsordf
 
      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 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 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)
      parameter (ryd  = 13.605 698d0)
      parameter (hart = 2*ryd)
      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)
      character*2  titre(30)
      character*2  ttire(9)
      dimension at(8),mbi(8)
      logical open_16

      external dsordf
      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)
      inquire(unit=16,opened=open_16)
      do 201 i=2,8
 201     mbi(i)=8-i-i/3-i/4+i/8
      if(open_16) then
        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 (5x,'nel     -E ','     n=',7(i2,8x))
      endif
      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     if (open_16) 
     .     write(16,2071) nq(i),titre(i),xnel(i),-en(i)*hart,
     1                  (at(k),k=2,j)
 2071 format(i1,a2,f6.3,8(1pe10.3))

c      overlap integrals
      if (norb.le.1) return
      if (open_16) 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)
            if(open_16) 
     .        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 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 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)
c#mn
       external cwig3j
 
      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
      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
      subroutine fpf0 ( iz, iholep, srho, dr, hx,
     1     dgc0, dpc0, dgc, dpc, 
     2     eatom, xnel, norb, eorb, kappa)
c      everything is input. output is written in fpf0.dat
c      to be read by ff2afs.f to get scattering amplitude

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

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
c     save central atom dirac components, see comments below.
      dimension dgc0(251), dpc0(251)
      dimension dgc(251, 30, 0:nphx), dpc(251, 30, 0:nphx)
      dimension xnel(30), eorb(30), kappa(30)
      dimension srho(251), dr(251), xpc(251), xqc(251)
      logical open_16
 
c     output arrays
      dimension enosc(13), oscstr(13), index(13)
 
      if (master) then
        open (unit=16, file='fpf0.dat', status='unknown', iostat=ios)
        fpcorr =  -(iz/82.5)**2.37
        write (16,*)  ' atom Z = ', iz
        write (16,10)  eatom *alphfs**2 *5/3, fpcorr,
     1        ' total energy part of fprime - 5/3*E_tot/mc**2'
  10    format (2(1pe19.5), a)
        open_16 = .true.
      else
        open_16 = .false.
      endif

c     get oscillator strengths
      do 20 i=1,13
        oscstr(i)=0.d0
        enosc(i)=0.d0
  20  continue
      enosc(1)= eorb(iholep)
      index(1)= iholep
      kinit = kappa(iholep)
      oscstr(1) = 2*abs(kinit)
c     always will use first spot to represent initial state
      nosc=1
      np = 251

      do 30 iorb =1, norb
        if (xnel(iorb) .gt.0.d0) then
c         it is core orbital, check if it satisfies dipole selection
          jkap = kappa(iorb)
          if (jkap+kinit.eq.0 .or. abs(jkap-kinit).eq.1) then
             nosc = nosc+1
c            calculate reduced dipole matrix element
             kdif= jkap-kinit
             if (abs(kdif).gt.1) kdif=0
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
             xk0 = abs(eorb(iorb)-eorb(iholep)) * alphfs
             do 190  i = 1, np
                xj0 = sin(xk0*dr(i))/(xk0*dr(i))
                xpc(i) = (xmult1*dgc0(i)*dpc(i,iorb,0)+
     1            xmult2*dpc0(i)*dgc(i,iorb,0)) * xj0
                xqc(i) = 0.0d0
  190        continue
c            xirf=lfin+linit+2
             xirf=2
             call somm (dr, xpc, xqc, hx, xirf, 0, np)
             oscstr(nosc) = xirf**2/3.0d0 
             enosc(nosc) = eorb(iorb)
             index(nosc) = iorb
          endif
        endif
  30  continue

c     write down information about oscillators
      if(open_16) then
        write(16, *) nosc
        do 210 i=1,nosc
          write(16,220) oscstr(i), enosc(i), index(i)
  220     format ( f9.5, f12.3, i4)
  210   continue
      endif

c     calculate and write out f0(Q) on grid delq=0.5 Angstorm**(-1)
      dq=0.5*bohr 
      do 300 iq = 1,81
         xk0 = dq*(iq-1)
c        srho is 4*pi*density 
         do 560  i = 1, np
            xj0 = 1.d0
            if(iq.gt.1) xj0 = sin(xk0*dr(i))/(xk0*dr(i))
            xpc(i) = srho(i) * (dr(i)**2) *xj0
            xqc(i) = 0.d0
  560    continue
         xirf = 2.d0
         call somm (dr, xpc, xqc, hx, xirf, 0, np)
         if (open_16) write (16, 570) 0.5*(iq-1), xirf
  570    format ( f5.1, 1x, f9.4)
  300 continue

      if (open_16) close(unit=16)

      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 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
      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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      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.
      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
        elseif (idfock.eq.2) then
           rhoc = srho(i) / (dr(i)**2)
        else
            call par_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 and edp in Hartrees
           if (idfock.eq.5 .or. idfock.eq.2) then
c             for exch=5, 2
              call vbh(rsc, xm, vxcvl)
           elseif (idfock.eq.6) then
c             for exch=6
              call vbh(rs, xm, vvbh)
                 xf = fa/rs
              call edp(rsc,xf,vdh)
              vxcvl = vvbh - 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 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 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)
      parameter (ryd  = 13.605 698d0)
      parameter (hart = 2*ryd)
      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)
      logical io_open

      external akeato, bkeato, fdrirk, fdmocc
      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)
      inquire(unit=io,opened=io_open)
      if (iprint .ge. 5 .and. io_open)  
     .  write (io, '(a,1pd18.7)') 'etot', eatom*hart
      do 215 i = 1, 4
        if (iprint.ge.5 .and. io_open) 
     .    write(io, '(a4,1pd18.7)') iner(i), ener(i)*hart
 215  continue
      return
      end
      subroutine inmuat (ihole, xionin, iunf, xnval, iholep, xmag, iorb)
      implicit double precision (a-h,o-z)
      dimension xnval(30), xmag(30), iorb(-4:3)
      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
      do 10 i = 1, 30
        en(i) = 0.d0
        xmag(i) = 0
  10  xnval(i) = 0

      call getorb (nz, ihole, xionin, iunf, norb, norbsc, iorb,
     1             iholep, nq, kap, xnel, xnval, xmag)
      xk=0
      do 411 i=1,norb
 411  xk=xk+xnel(i)
      if ( abs(nz-xionin-xk) .gt. 0.001) then
         call par_stop('check number of electrons in getorb.f')
c        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 par_stop('kappa out of range, check getorb.f')
c           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 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)
c#mn
       external cwig3j

      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 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 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
c#mn
       external dentfa

      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
         ifail = 0
         call soldir
     1     (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),ifail)

         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
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      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 aprdep (a,b,l)
c     need to be in library for ATOM and PHASE; renamed aprdev
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)
 
      aprdep=0.0d 00
      do 11 m=1,l
 11      aprdep=aprdep+a(m)*b(l+1-m)
      return
      end
      subroutine dfovrg (ncycle, ikap, rmt, jlast, jri, p2, dx,
     1                  ri, vxc, vxcval, dgcn, dpcn, adgc, adpc,
     2                  xnval, pu, qu, ps, qs,
     2                  iz, ihole, xion, iunf, irr, ic3)
c     Dirac equation solver for complex energy
c     coded by a.ankudinov 1996
c     modified by a.ankudinov 1997 to get irregular solution 

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        jlast   last point for integration of Dirac eq.
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 'iph' 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        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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      complex*16 vxc(nrptx), vxcval(nrptx), p2
      dimension ri(nrptx)
      complex*16 ph0, amp, 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), adpc(10,30)
 
c     iph 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/comdic/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/mulabc/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/snoyac/dvn(nrptx),anoy(10),nuc
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension xnval(30)

c     initialize the data and test parameters
      ndor = 3
      cl = alpinv
      if (irr.gt.0) then
c        for irregular solution
         ndor=2
         aps(1) =  pu
         aqs(1) =  qu
         do 5 i=1, jri
           gg(i) = ps(i)
           gp(i) = qs(i)
 5       continue
      endif
      do 9 i = jri+1,nrptx
         vxc(i)=vxc(jri+1)
 9       vxcval(i)=vxc(jri+1)
      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     numerical integration of Dirac eq. works if you have 6 grid points
c     for one period of oscillations, switch to analytical expression
c     for a steplike potential  at large distances
      aa = 0.5
c     if (irr.gt.0) aa = 0.05
      rwkb = aa / dx / sqrt(abs(2*p2+(p2/cl)**2))
      x0 = 8.8
      iwkb= (log(rwkb) + x0) / dx  +  2
      if (iwkb.gt.idim) iwkb = idim
      if (iwkb.lt. 10) iwkb = 10
      
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) 
 13      bp(i,j)=adpc(i,j) 
      do 15 j=1,30
      do 15 i=1,idim
         cg(i,j)=dgcn(i,j) 
 15      cp(i,j)=dpcn(i,j) 

      call inmuac (ihole, xion, iunf, ikap)
      nmax(norb)=jlast
      if (iwkb.ge. jlast-1) iwkb = idim
c     note that here norb correspond to photoelectron

c     calculate initial photoelectron orbital using lda
      call diff (vxc,ri,ikap,cl,hx,jri,vm)
      do 18 i = jri, nrptx
  18  vm(i)=0.0d0
      call wfirdc (p2,kap,nmax,vxc,ps,qs,aps,aqs,irr,ic3,vm,
     1             rmt,jri, iwkb)

      if (numerr .ne. 0) call par_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,iwkb
  50  dv(i)=vxcval(i)/cl
c     keep dv=vxc/cl above iwkb

      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
         jriwkb = min (jri, iwkb)
         call potex( ps, qs, aps, aqs, jriwkb, p2)

c        resolution of the dirac equation
         if (irr.lt.0) then
            call solout (p2, fl(norb), aps(1), aqs(1), ikap, rmt,
     1        jri, nmax(norb), ic3, vm, iwkb)
         else
            call solin (p2, fl(norb), pu, qu, ikap, rmt,
     1        jri, nmax(norb), ic3, vm, iwkb)
         endif

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
        if (irr.lt.0 ) then
cc        need pu, qu for regular solution
cc        want to have vxc(jri)-smooth and vxc(jri+1)=v_mt
cc        assume no exchange beyond jri 
           vu=vxc(jri+1)
           call flatv 
     1     (ri(jri), rmt, ps(jri), qs(jri), p2, vu, ikap, pu, qu)
           jlast = nmax(norb)
c          jlast might change on very rare occasion
        endif

      else
        call par_stop('error in dfovrg.f')
      endif

      return
      end

      subroutine flatv (r1, r2, p1, q1, en, vav, ikap, p2, q2)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c     solution of Dirac equation for flat potential for ikap is known
c     exactly (see e.g. in Loucks T.L. eq. 4-19)
c     given p1 and q1 at point r1 this subrotuine finds p2, q2 at r2
c     for given energy(en) and average potential (vav)
c     en and vav in hartrees
      external besjn, atancc

      complex*16 p1, q1, en, vav, p2, q2
      complex*16 ck, xkr, jl(ltot+2), nl(ltot+2), a,b, factor 

c     initialize staff
      ck = sqrt(2*(en-vav) + (alphfs*(en-vav))**2)
      xkr = ck*r1
      if (ikap.lt.0) then
        isign = -1
        lp = -ikap - 1
        lq = lp + 1
      else
        isign = 1
        lp = ikap
        lq = lp - 1
      endif
      a = ck * alphfs
      factor = isign*a/(1+sqrt(1+a**2))

c     find a and b that p1 = r1*(a*jl+b*nl), q1=factor*r1*(a*jl'+b*nl')
      call besjn (xkr, jl, nl)
      a = isign*ck*xkr* (p1*nl(lq+1) - q1*nl(lp+1)/factor)
      b = isign*ck*xkr* (q1*jl(lp+1)/factor - p1*jl(lq+1))

c     get values at r2
      xkr = ck * r2
      call besjn (xkr, jl, nl)
      p2 =  r2 * (jl(lp+1)*a + nl(lp+1)*b)
      q2 =  r2* factor * (jl(lq+1)*a + nl(lq+1)*b)

      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      
      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
      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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)
c     common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
c    1   nq(30),kap(30),nmax(30)
      common/tabtec/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
      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 inmuac (ihole, xionin, iunf, ikap)
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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/snoyac/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/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension xnval(30), iorb(-4:3)
      data nucm/11/

      testy=10.**(-5)
c testy precision for the wave functions

      call getorb (nz, ihole, xionin, iunf, norb, norbsc, iorb,
     1            iholep, nq, kap, xnel, xnval, en)
c     don't need xmag here, so use en as a dummy

      ipl=0
      do 40 i=1,norb
         en(i) = 0.d0
         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
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 intout (en,i0, 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 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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      parameter (npi=6, test=1.0d+5)
      complex*16 en,c3,vmh
      complex*16 gg,ag,gp,ap,dv,av,eg,ceg,ep,cep, vm(nrptx)
      common/comdic/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/tabtec/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
      exphx = exp (hx/2)
      ihard = 0
      ec=en/cl
 
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     runge-kutta for first npi points
      i = i0
      j=1
      f = (ec - dv(i))*dr(i)
      g = f + ccl * dr(i)
      c3 = ic3*vm(i)/g**2
      dg(j) = hx * (g*gp(i) - kap*gg(i) + ep(i))
      dp(j) = hx * (kap*gp(i) - (f-c3)*gg(i) - eg(i))

 44   continue
      if (i.ge.max0) goto 999
      ac = gg(i) + 0.5d0 * dg(j)
      bc = gp(i) + 0.5d0 * dp(j)
      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 .and. i0.eq.1) 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
      elseif (i0.eq.1) then
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
      else
c        outward integration of irregular solution near jri
         vh = dv(i)*xm1 + dv(i+1)*xm2
         vmh = xm1*vm(i) +xm2*vm(i+1)
      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(j))
      bc = bc + 0.50*(dp2-dp(j))
      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
      j=j+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(j-1) + 2.0*(dg2+dg3)+dg4)/6.0
      gp(i) = gp(i-1)+(dp(j-1) + 2.0*(dp2+dp3)+dp4)/6.0
      dg(j) = hx * (g*gp(i) - kap*gg(i) + ep(i))
      dp(j) = hx * (kap*gp(i) - (f-c3)*gg(i) - eg(i))
      if (j.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+i0-1,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

 999  do 741 i=max0+1,np
         gg(i)=0.0d 00
 741     gp(i)=0.0d 00

      return
      end
      subroutine muatcc(xnval) 
c               * angular coefficients *
c        sous programmes utilises  cwig3j
c
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/mulabc/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)
c#mn
       external cwig3j

      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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) call par_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.')
         call par_stop('NUCDEC-1')
      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 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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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/tabtec/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 potdvp
c     this programm uses aprdep,multrk,yzkrdf
c     to calculate potential development coefficients
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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/comdic/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/snoyac/dvn(nrptx),anoy(10),nuc
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)
c#mn
       external aprdep

      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)*(aprdep(bgj,bgj,i)+
     1            aprdep(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, p2)
c        this programm uses bkeato,aprdec,multrk,yzkrdc
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 aprdec, p2
      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/comdic/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/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      common/mulabc/afgkc
      dimension afgkc(-ltot-1:ltot,30,0:3)
      dimension bgj(10),bpj(10)
c#mn
       external aprdec
 
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, p2, norb)
         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 solin (en,fl,agi,api,kap,rmt,jri,imax,ic3,vm, iwkb)
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 imax the last point of tabulation of the wave function

      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      parameter (npi=6, test=1.0d+5)
      complex*16 en,agi,api,c3,vmh
      complex*16 gg,ag,gp,ap,dv,av,eg,ceg,ep,cep, vm(nrptx)
      common/comdic/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, 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/tabtec/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
      complex*16 jl(0:ltot+1), hl(0:ltot+1), xkmt, ck, dum1, factor
      external besjh

      ccl=cl+cl
      ihard = 0
      ec=en/cl
      do 115 i=2,ndor
         ag(i)=0.0d0
 115     ap(i)=0.0d0
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     started with h_l above jri inside dfovrg
      vmh = cl * dv(jri+1)
      ck = sqrt(2*(en-vmh) + (alphfs*(en-vmh))**2)
      il = abs(kap)
      if (kap.lt. 0) il = il - 1
      ilp = il - 1
      if (kap .lt. 0) ilp = il + 1
      ilx = il+1
      if (ilp.gt.il) ilx=ilp+1
      xsign = -1.d0
      if (kap.gt.0) xsign = 1.d0
      factor = ck*alphfs
      factor = xsign * factor/(1+sqrt(1+factor**2))
      dum1 = 1/ sqrt(1+factor**2)

      iflat = min ( jri, iwkb)
      do i = jri, imax
        j= iflat + npi - i
        xkmt = ck * dr(i)
        call besjh( xkmt, ilx, jl, hl)
        gg(i) = hl(il) * dr(i) * dum1
        gp(i) = hl(ilp) * dr(i) * dum1 * factor
        if (j.gt.0) then
          f = (ec - dv(i))*dr(i)
          g = f + ccl * dr(i)
          c3 = ic3*vm(i)/g**2
          dg(j) = -(  g*gp(i) - kap*gg(i) )
          dp(j) = -(  kap*gp(i) - (f-c3)*gg(i) )
c         neglect exchage term outside jri
c         dg(j) = -(  g*gp(i) - kap*gg(i) + ep(i) )
c         dp(j) = -(  kap*gp(i) - (f-c3)*gg(i) - eg(i) )
        endif
      enddo

c     use flatv between iwkb and jri
      do i = jri-1, iflat, -1
         j= iflat + npi - i
         if (i.eq.iwkb) then
            eph = cl* ( 3*dv(iwkb+1) - dv(iwkb+2)) /2
            if (iwkb.eq.jri-1) eph=  cl* (dv(i) + dv(i+1)) /2
         else
            eph = cl* (dv(i) + dv(i+1)) /2
         endif
         if (ic3.gt.0) then
           rav = (dr(i)+dr(i+1)) / 2
           ec = rav**3 * ( ccl+ (en - eph) / cl )**2
           eph = eph + ic3 * cl / ec * (vm(i) + vm(i+1)) / 2
         endif
         call flatv( dr(i+1), dr(i), gg(i+1), gp(i+1), en, eph, kap,
     1               gg(i), gp(i))
         if (j.gt.0) then
          f = (ec - dv(i))*dr(i)
          g = f + ccl * dr(i)
          c3 = ic3*vm(i)/g**2
          dg(j) = -(  g*gp(i) - kap*gg(i) + ep(i) )
          dp(j) = -(  kap*gp(i) - (f-c3)*gg(i) - eg(i) )
         endif
      enddo

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
c     do 55 i = jri - npi + 1 , 2, -1
      do 55 i = iflat, 2, -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=imax+1,np
         gg(i)=0.0d 00
 741     gp(i)=0.0d 00
      ag(1)=gg(1)* dr(1)**(-fl)
      ap(1)=gp(1)* dr(1)**(-fl)

      return
      end
      subroutine solout(en, fl, agi, api, kap, rmt,
     1                  jri, max0, ic3, vm, iwkb)
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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      parameter (npi=6, test=1.0d+5)
      parameter (ccl=2*alpinv, csq=ccl**2 )
      complex*16 en,agi,api
      complex*16 gg,ag,gp,ap,dv,av,eg,ceg,ep,cep, vm(nrptx)
      common/comdic/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,f,g

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/tabtec/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


c{#mn: g77 chokes on taking real of a double-precision complex
c      if (real(av(1)).lt.0.0d 00.and.kap.gt.0) api=-agi*(kap+fl)/av(1)
c      if (real(av(1)).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(kap-fl)
      if (dble(av(1)).lt.0.0d 00.and.kap.gt.0) api=-agi*(kap+fl)/av(1)
      if (dble(av(1)).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(kap-fl)
c#mn}
      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
         do 41 j=1,ndor
            a=fl+j-1
            b=dr(i)**a
            gg(i)=gg(i)+b*ag(j)
 41         gp(i)=gp(i)+b*ap(j)
      else
c        see fovrg.f in feff6, be aware of different units
         twoz = -dble(av(1)) * 2.0*cl
         rat1 = twoz/ccl
         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)/ccl
            ag(2)= ag(2)*rat3
            ap(2)= ap(2)*rat3/ccl
            ag(3)= ag(3)*rat3**2
            ap(3)= ap(3)*rat3**2/ccl
         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

      i0=1
      iflat = min ( jri, iwkb)
      call intout (en, i0, kap, iflat, ic3, vm)

      do 100 i = iflat, max0-1
         if (i.eq.iwkb) then
            eph = cl* ( 3*dv(iwkb+1) - dv(iwkb+2)) /2
            if (iwkb.eq.jri-1) eph=  cl* (dv(i) + dv(i+1)) /2
         else
            eph = cl* (dv(i) + dv(i+1)) /2
         endif
         if (ic3.gt.0 .and. i.lt.jri) then
           rav = (dr(i)+dr(i+1)) / 2
           ec = rav**3 * ( ccl+ (en - eph) / cl )**2
           eph = eph + ic3 * cl / ec * (vm(i) + vm(i+1)) / 2
         endif
         call flatv( dr(i), dr(i+1), gg(i), gp(i), en, eph, kap,
     1               gg(i+1), gp(i+1))
  100 continue

      return
      end
      subroutine wfirdc (eph,kap,nmax,vxc,ps,qs,aps,aqs,irr,ic3,vm,
     1                   rmt,jri, iwkb) 
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     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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      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/comdic/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/snoyac/dvn(nrptx),anoy(10),nuc
      common/tabtec/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
      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,jri-1
 21   dv(i)= vxc(i)/cl
      do  i=jri,idim
        dv(i)= vxc(jri+1)/cl
      enddo
      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
      if (irr.lt.0) then
         if (a .gt. 0.0d0) then 
            aps(1) = 1.0
            if (kap(norb) .lt. 0) then
               aqs(1)=aps(1)*dz/(cl*(kap(norb)-fl(norb)))
            else
               aqs(1)=aps(1)*cl*(kap(norb)+fl(norb))/dz
            endif
         else
            if (kap(norb).lt.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
      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
         
      if (irr.lt.0) then
         call solout( eph, fl(norb), aps(1), aqs(1), kap(norb), rmt,
     1              jri, nmax(norb), ic3, vm, iwkb)
      else
         call solin( eph, fl(norb), aps(1), aqs(1), kap(norb), rmt,
     1              jri, nmax(norb), ic3, vm, iwkb)
      endif
         
      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)
      return
      end
      subroutine yzkrdc (i,k,flps,ps,qs,aps,aqs,p2, norb)
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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 aprdec,p2, dyzk
c     complex*16 a1,a2,b1,b2,coni
c     complex*16 xck, temp, ck, phx
      parameter (coni=(0.d0,1.d0))
      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/comdic/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/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgi(10),bpi(10)
c#mn
       external aprdec
 
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)

      dyzk = 0
c     if (id .ge. nmax(norb)) then
c        id = nmax(norb)-1
c        ck0 = log(cg(id,i)/cg(id+1,i))  / (dr(id+1)-dr(id))
c        ck = sqrt(2*p2)
c        xck = ck/cl
c        xck = -xck/(1+sqrt(1+xck**2))
c        temp = -ps(id+1) / qs(id+1) *xck
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) / (xx**2 + (yy-1)**2)
c        beta = log(beta) / 4

c        phx = dcmplx (alph, beta)
c        a1 =   ps(id+1) / sin(phx)
c        a2 = - qs(id+1) / cos(phx)
c        xck=ck*dr(id+1)
c        phx = phx -xck
c        a1 = a1*cg(id+1,i)/2/coni
c        a2 = a2*cp(id+1,i)/2
c        b1=exp(coni*phx) * (a1 - a2)
c        b2=exp(-coni*phx) * (-a1 - a2)
c        xck = (ck0 - coni*ck)*dr(id+1)
c        n = k +1
c        dyzk = dyzk + b1*exp(-xck)/xck
c        dyzk = dyzk + b1*expint(n,xck)
c        xck = (ck0 + coni*ck)*dr(id+1)
c        dyzk = dyzk + b2*exp(-xck)/xck
c        dyzk = dyzk + b2*expint(n,xck)
c        dyzk = dyzk*dr(id+1)
c     endif

      call yzktec (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim, dyzk)
      return
      end

c     complex*16 function expint(n,x)
c     implicit double precision (a-h,o-z)
c     integer n, maxit
c     complex*16 x, b, c, d, h, del, fact, zero
c     parameter (zero=(0.d0,0.d0))
c     parameter (maxit=100, eps=1.d-7, fpmin=1.d-30, euler=.5772156649)

c     nm1 = n - 1
c     if (n.lt.0 .or. (dble(x).lt.0.d0 .and. dimag(x).eq.0.d0) .or.
c    1     (x.eq.zero .and. (n.eq.0.or.n.eq.1))) then
c        call par_stop('Bad arguments in expint')
c     elseif (n.eq.0) then
c        expint = exp(-x) / x
c     elseif (x.eq.0) then
c        expint = 1.d0 /nm1
c     elseif (dble(x).gt.1) then
c        b = x + n
c        c = 1/fpmin
c        d = 1/b
c        h = d
c        do 10 i=1,maxit
c           a = -i*(nm1+i)
c           b = b + 2
c           d = 1 / (a*d+b)
c           c = b + a/c
c           del = c*d
c           h = h*del
c           if (abs(del-1) .lt. eps) then
c              expint = h * exp(-x)
c              return
c           endif
c 10     continue
c        call par_stop(' continued fraction failed in expint')
c     else
c        if (nm1.ne.0) then
c           expint = 1/nm1
c        else
c           expint = -log(x) - euler
c        endif
c        fact = 1
c        do 30 i=1,maxit
c           fact = - fact *x / i
c           if (i.ne.nm1) then
c              del = - fact / (i-nm1)
c           else
c              psi = - euler
c              do 20 ii=1,nm1
c                 psi = psi + 1.d0 / ii
c 20           continue
c              del = fact*(-log(x)+psi)
c           endif
c           expint = expint + del
c           if (abs(del).lt.abs(expint)*eps) return
c 30     continue
c        call par_stop('series failed in expint')
c     endif
c     return
c     end
      subroutine yzktec (f,af,g,ag,dr,ap,h,k,nd,np,idim, dyzk)
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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 f,af,g,ag,ap, dyzk
      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) + dyzk
      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
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      subroutine xcpot (iph, ie, index, lreal, ifirst, jri,
     1                  em, xmu,
     2                 vtot, vvalgs, densty, dmag, denval,
     3                  eref, v, vval, iPl, WpCorr, Gamma, AmpFac,
     4                  vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim,rnrm)

      implicit double precision (a-h, o-z)
c     calculate self-energy correction
c     first coded j. mustre de leon
c     last modified a.ankudinov 1996 for non-local self-energies
c     Ankudinov, Rehr, J. Physique IV, vol. 7, C2-121, (1997).

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       not equal zero for real self energy
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     vi0         const imag part to subtract from potential
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     iPl         Control for many pole self energy (Josh)
c
c     OUTPUT
c     eref        complex energy reference for current energy
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
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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      dimension   vtot(nrptx), vvalgs(nrptx), densty(nrptx)
      dimension   dmag(nrptx), denval(nrptx)
      complex*16  em, eref, v(nrptx), vval(nrptx)
      dimension   vxcrmu(nrptx), vxcimu(nrptx)
      dimension   vvxcrm(nrptx), vvxcim(nrptx), gsrel(nrptx)

c     Josh added variables:
c     ZRnrm      - renormalization constant
c     ZTmp       - Temp var for ZRnrm
c     csig       - control for using many pole self energy
c     NRPts      - Number of points to use inside atom.
c                  Other points are linearly interpolated.
c     WpCorr     - Array of frequencies for many pole self energy.
c     rsTmp      - Temp var for rs
c     WpTmp      - Temp var for Wp
c     AmpFac     - g_i (pole strengths)
c     Gamma      - pole broadening
c     RsInt      - Rs in the intersitial
c     DRs        - RsCore - RsInt
c     delrHL     - Re[delta sigma] for many pole self energy
c     deliHL     - Im[delta sigma] for many pole self energy
c     Rs1(NRPts) - Array of Rs points for interpolation
      complex*16  delta, deltav, ZRnrm, ZTemp
      character*512 slog
      logical csig, rdmpse
      integer NRPts, iexist, lastPl
      parameter (tol=0.0004)
      parameter (NRPts=10)
      double precision WpCorr(MxPole), rsTmp, WpTmp, 
     &     AmpFac(MxPole), Gamma(MxPole)
      double precision RsInt, DRs, delrHL(NRPts), deliHL(NRPts),
     &     Rs1(NRPts), dx, x0, volume, totvol, rnrm, ri, riInt, omp,
     &     ompmax 
      complex*16 delavg
c    Josh END

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
c     Atom r grid
      dx = 0.05d0
      x0 = 8.8d0
      totvol = 4.d0/3.d0*pi*rnrm**3
      delavg = 0.d0 
c      totvol = 0.d0
      ZRnrm = 0.d0
      csig=.false.
      ompm1 = 0.d0
      jri1 = jri + 1
      rsTmp = RsCorr
      nmax=1
      nul=0
      ibp = index / 10
      ixc = mod(index,10)
      ixcTmp=ixc
      DO i = 1, MxPole
         IF(WpCorr(i).le.0.d0) then
            lastPl = i-1
            GOTO 5
         END IF
      END DO
   5  CONTINUE        
      if((ixc.eq.0).and.(iPl.gt.0)) then
         csig=.true.
      end if
      if (ixc .eq. 2 .or. dble(em).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     Josh - Added CSigma to calculate HL Sigma with broadening and such.
c     Calculate Rs at the core and interstitial densities.
      if (densty(jri1).le.0) then
         RsInt =10
      else
         RsInt = (3 / (4*pi*densty(jri1))) ** third
      endif
      if (densty(1).le.0) then
         rscore =101.d0
      else
         rscore = (3 / (4*pi*densty(1))) ** third
      endif
      DRs = (RsInt-rscore)/(NRPts-1)
      omp = SQRT(3.d0/RsInt**3)*hart
      ompmax=omp*WpCorr(lastPl)
c     Now calculate delta sigma as a function of Rs and energy
      if (csig) then
         do i= NRPts, 1, -1
            rdmpse = .false.
c            if((ifirst.eq.0).and.(i.eq.NRPts)) then
c               open(unit=23,file='mpse.bin',status='old',iostat=iexist)
c               if(iexist.eq.0) then
c                  rdmpse = .true.
c               else
c                  open(unit=23,file='mpse.bin',status='replace',
c     &                 iostat=iexist)
c               end if
c            end if
c            if(rdmpse) then
c               read(23,*) RsTmp, Rs1(i), delrHL(i), deliHL(i), ZTemp
c               if(abs(1-abs(RsTmp/DBLE(em))).gt.0.001) then
c                  goto 16
c               else
c                  goto 17
c               end if
c            end if
c 16         continue
            delrHL(i) = 0.d0
            deliHL(i) = 0.d0
            Rs1(i)=rscore+DBLE(i-1)*DRs
            
c           If iPl > 1, use renormalization, else not
c           If iPl = 2, use Sigma(r) = Sigma[Wp(r)*Wp/Wp(RsInt)]
c           If iPl = 3, use Sigma(r) = 0 outside of intersitial region
c                       actually linearly interpolates to zero at the 
c                       first RPt.
c           If iPl > 3, use Sigma(r) = Sigma(RsInt) (Sigma as a bulk property)
            if(iPl.gt.1) then
               if((iPl.eq.2).or.(i.eq.NRPts)) then                  
                  call CSigZ(em,xmu,Rs1(i),delrHL(i),deliHL(i),ZTemp,
     &                 WpCorr,Gamma,AmpFac)
               elseif(iPl.eq.3) then
                  delrHL(i) = 0.d0
                  deliHL(i) = 0.d0
               else
                  delrHL(i) = delrHL(NRPts)
               end if
               if(i.eq.NRPts) ZRnrm = ZTemp
            else
               call CSigma(em,xmu,Rs1(i),delrHL(i),deliHL(i),WpCorr,
     &              Gamma,AmpFac)
            end if
c            Josh Kas - Write self energy to mpse.bin for fast processing later
c            write(23,'(6f30.10)') DBLE(em), Rs1(i), delrHL(i),
c     &           deliHL(i), Ztemp
c 17         continue
c           debugging output of deltaSigma(em, rs)
c           write(44,'(6f30.10)') DBLE(em), Rs1(i), delrHL(i), deliHL(i),
c     &           dble(ZRnrm), dimag(ZRnrm)
         end do
c        write(44,*)
      end if
c     END Josh
      
c     Add the self energy correction
      do 20  i =  jri1,1,-1
         ri = exp((i-1)*dx - x0)
         if(i.eq.jri1) then
            riInt = ri
         end if
         niter = 0
         if (densty(i).le.0) then
            rs =10
         else
            rs = (3 / (4*pi*densty(i))) ** third
         endif
c         write(22,*) 1.d0*exp(dble(i)*0.01), densty(i)         
c        Josh - If csigma is turned on, interpolate onto rs.
c        Then skip to 15 (skip other calculations and self
c        consistency)
         if(csig) then          
            omp = SQRT(3.d0/rs**3)*hart
            if(iPl.ge.4) then
               delr = delrHL(NRPts)
               deli = deliHL(NRPts)
            else
               call terp (Rs1, delrHL, NRPts, 1, rs, delr)
               call terp (Rs1, deliHL, NRPts, 1, rs, deli)
            end if
            if((iPl.ne.5).or.(omp.lt.ompmax)) then
               goto 15
            end if
         end if
c        END Josh
         
c        xf = 1.9191.../rs
         xf = fa / rs
         rsm = rs / (1+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)
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))
               if (ixc.eq.5 .and. i.eq.jri1) then
                  vvxcrm(jri1) =  vxcrmu(jri1)
                  vvxcim(jri1) =  vxcimu(jri1)
               endif
            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 - 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?)
         xk2 = 2 * (dble(em) - xmu) + xf**2
         xk = sqrt(xk2)
         xkm2 = 2 * (dble(em) - xmu) + xfm**2
c        quick fix
         if (xkm2.lt.0) xkm2=xk2
         xkm = sqrt(xkm2)

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        Correct local momentum according to the formula
c        p^2 = k^2 - 2*mu + kf^2 - 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 = 2*(dble(em) - xmu - del1r) + xf**2
         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)') dble(em), xf**2, xmu, del1r
            call wlog(slog)
            call par_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 .or. ixc.eq.6) then
               delvr = delr
               delvi = deli
            endif
         endif

         if (niter.lt.nmax) then
            del1r=delr
            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        Josh - Skip SC loop if CSigma is called. CSigma calculates self consistently.
 15      continue
         
         delta = dcmplx(delr,deli)

c	 Josh - write out delta sigma at interstitial level to sigma.dat.
         if(i.eq.jri1) then
            write(45,'(X,20e14.6)') (DBLE(em) - xmu)*hart, delr*hart, 
     &                        deli*hart, DBLE(ZRnrm), DIMAG(ZRnrm), 
     &                        SQRT(DBLE(ZRnrm)**2+DIMAG(ZRnrm)**2), 
     &                        ATAN2(DIMAG(ZRnrm),DBLE(ZRnrm)),
     &                        SQRT(DBLE(em-xmu)/2.d0)/ABS(deli)*bohr
         end if
c	 Josh END

         if (ixc .eq. 5) delta = dcmplx(delr,delvi)
         v(i) = vtot(i) + delta
         if (ixc .ge. 5) then
            deltav = dcmplx(delvr,delvi)
            vval(i) = vvalgs(i) + deltav
         endif
         if(i.eq.jri1) then
            volume = 0.d0
         elseif(i.eq.jri) then
            volume = 4.d0*pi/3.d0*(rnrm**3 - exp(3.d0*((i-1)*dx - x0)))
         else
            volume = 4.d0*pi/3.d0*exp(3.d0*((i-1)*dx-x0))*(exp(3.d0*dx)
     &           - 1.d0)
         end if
         if(volume.lt.0.d0) volume = 0.d0
         omp = SQRT(3.d0/rs**3)
         write(39,'(I5,20f30.10)') i, dble(em-xmu), volume/totvol,
     &        exp((i-1)*dx - x0)*bohr,
     &        rnrm*bohr, densty(i), denval(i), dble(volume*delta),
     &        dimag(volume*delta), omp*hart, omp-ompm1
         ompm1 = omp
         delavg = delavg + volume*delta
 20   continue
 25   continue
      write(39,*)
      
      ifirst = 1
      delavg = delavg/totvol
      write(38,'(X,20e14.6)') (DBLE(em) - xmu)*hart, dble(delavg)*hart, 
     &     dimag(delavg)*hart,
     &     SQRT(DBLE(em-xmu)/2.d0)/ABS(dimag(delavg))*bohr,
     &     totvol
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
         do 920 i = 1, jri1
  920    vval(i) = vval(i) - eref
      else
         do 930 i = 1, jri1
  930    vval(i) = v(i)
      endif

c     Real self energy, zero imag part
      if (lreal.gt.0)  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)
      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
         vi = 0
         call edp(rs,xk,vr)
      elseif (ixc .eq. 3) then
         call edp(rs,xk,vr)
         call imhl (rs,xk,vi,icusp)
      endif

      if (ixc .ge. 6) then
         call edp(rscore,xk,vrp)
         vr = vr - vrp
      endif

      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
c     qz2 = -(s1 + sqrt(three)*dimag(s1) + a2/3)
      qz3 = -(s1 - sqrt(three)*dimag(s1) + a2/3)
      qplus = qz1
      qminus = qz3

      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     outputs:   vr --- dirac potential (Hartrees)
c     written by j. mustre 8/31/87
c**********************************************************************

      subroutine edp (rs, xk, vr)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      vr = 0.0d0
      if (rs .le. 100.0) then
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

        xf = fa / rs
        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))
      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 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
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 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      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 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      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 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      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)  call par_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)  call par_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 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) )
c APS parameter (gamma = 5.129762496709890 ) changed
      parameter (gamma = 5.129762802484097 )

      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
c     transform to code units (Hartrees) from Rydbergs
      vxc = vxc / 2.d0

      return
      end

      double precision 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     double precision 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 CSigma(Energy, Mu, Rs, ReSig, ImSig, WpScl, Gamma,
     &     AmpFac)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Written by Josh Kas
c     This subroutine calculates the self energy Sigma(k(Energy),Energy)
c     based on an electron gas model of epsilon^-1.
c      
c     Solve: k0**2 = 2*Energy - 2*Mu -
c                    2*(Sigma(k0,Energy)-Sigma(kFermi,EFermi))
c            
c     Steps:
c
c            1. k0**2  = 2*(Energy-Mu) + SigmaF (SigmaF is self energy at fermi level).
c            2. Sigma0 = Sigma(k0,Energy)
c            3. k1**2  = 
c                  k0**2 - 2*(Sigma0-SigmaF)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c     Parameters:
c     MxPole - Maximum number of poles      
      INTEGER MxPole
      PARAMETER(MxPole=1000)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input:
c     Energy - Energy at which to evaluate Sigma
c     Mu     - Fermi energy as calculated by FEFF
c     Rs     - R sub s (sphere of radius Rs holds charge e)
c     WpScl  - Scale Wp in interstitial by WpScl
c     Gamma  - Use broadening Gamma when calculating Sigma
c     AmpFac - Use amplitude AmpFac for plasmon pole.
c     Note: Atomic units are used.
      DOUBLE PRECISION Rs, WpScl(MxPole), Gamma(MxPole), AmpFac(MxPole),
     &     Mu
      COMPLEX*16 Energy
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output:
c     ReSig  - Re[Sigma(Energy,k(Energy))]
c     ImSig  - Im[Sigma(Energy,k(Energy))]
      DOUBLE PRECISION ReSig, ImSig
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
c     kFermi - Fermi momentum calculated from Rs via electron gas
c              approximation.
c     EFermi - Fermi energy = kFermi^2/2
c     Wp     - Electron gas plasmon frequency.
c     Gam    - broadening for broadened pole.
c     ckF    - complex variable to store kFermi
c     ck0    - complex momentum
c     SigmaF - Self energy at the fermi energy and fermi momentum
c              Does not include the Hartree Fock part.
c     Sigma0 - Single pole self energy evaluated at
c              Wp = Wp(ipole)/Wp(R_Interstitial)*Wp(Rs)
c     dSgdE  - Derivative of sigma w.r.t. Energy
c     ZTot   - Renormalization factor Z = 1/(1-dSgdE)
c     RelEn  - Energy relative to the fermi energy from FEFF      
c              Relen = Energy - Mu + EFermi
c     SigTot - Total many pole deltaSigma = Sigma(E,k(E))-Sigma(EF,kF)
c     DelHF  - Sigma_HartreeFock(k) - Sigma_HartreeFock(kF)      
      DOUBLE PRECISION kFermi, EFermi, Wp, Gam
      COMPLEX*16 ckF, ck0, Sig, SigmaF, Sigma0,
     &     RelEn, SigTot, DelHF
      INTEGER i1, i2

c     Parameters:
      DOUBLE PRECISION DPZero, h
      PARAMETER(DPZero = 0.d0, h = 1.d-3)
      INTEGER MxIter
      LOGICAL MPole
      PARAMETER(MxIter = 1)

c     Externals:
      COMPLEX*16 Sigma1, dSigma, HFExc
      EXTERNAL Sigma1, dSigma, HFExc
      
c     Initialization
      kFermi = fa/Rs
      EFermi = kFermi*kFermi/2.d0
      SigTot=0.d0
      SigmaF = 0.d0 
      Gam = 0.d0

c     Loop1: Start self consistency loop.
      DO i2 = 1, MxIter
c        Loop2: Loop over poles to find SigmaF
         DO i1 = 1, MxPole
            IF(WpScl(i1).lt.-1000.d0) GOTO 5
            
c           Wp is in Hartrees
            Wp = SQRT(3.d0/rs**3)*WpScl(i1)
            
c           find Sigma_Fermi (SigmaF)
            ckF = kFermi*1.00001d0
            RelEn = EFermi
            SigmaF = SigmaF + Sigma1(ckF,RelEn,Wp,Gam,AmpFac(i1),
     &           kFermi,EFermi)
         END DO
 5       CONTINUE
         
c        Loop3: Loop over poles
         DO i1 = 1, MxPole
            IF(WpScl(i1).lt.-1000.d0) GOTO 10
c           Wp is in Hartrees
            Wp = SQRT(3.d0/rs**3)*WpScl(i1)

c           Start with ck0=Sqrt[Re(Energy)-Mu+EFermi]
            RelEn = DBLE(Energy) - Mu + EFermi
            ck0 = SQRT(2.d0*DBLE(RelEn))
            
c           Find Sigma0
            Sigma0 = Sigma1(ck0,RelEn,Wp,Gam,AmpFac(i1),kFermi,
     &           EFermi)
            
            SigTot = SigTot + Sigma0
            
c        End loop over poles.            
         END DO
 10      CONTINUE
         
c     End self-consistency loop
      END DO

c     Form delta sigma and retur.n
      SigTot = SigTot - SigmaF
      DelHF = HFExc(ck0,EFermi,kFermi) - HFExc(ckF,EFermi,kFermi)
      SigTot = SigTot + DelHF
      
      ReSig = DBLE(SigTot)
      ImSig = DIMAG(SigTot)
      
      RETURN
      END

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      FUNCTION Sigma1(ck,Energy,Wi,Gamma,Amp,kFermi,EFermi)
c     Written by Josh Kas
c     Function Sigma calculates the energy dependent part
c     of Sigma(ck,Energy) from H.L. electron gas model.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c     Input:
c     ck     - complex momentum
c     Energy - Energy
c     Wi     - Plasmon pole energy
c     Gamma  - Broadening of plasmon pole.
c     Amp    - Amplitude of plasmon pole.
c     kFermi - Fermi momentum
c     EFermi - Fermi energy
c              This is used when calculating dSigma/dE
      DOUBLE PRECISION Wi, Gamma, Amp, kFermi, EFermi
      COMPLEX*16 ck, Energy
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output:
c     Sigma(ck,Energy)
      COMPLEX*16 Sigma1
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
c     NSing  - Number of singularities of integrand (used in cgratr)
c     NCalls - Number of fcn calls used in cgratr
c     MaxNR  - Max number of regions used in cgratr
c     DPPar  - Array of double precision parameters passed to cgratr
c              to be used in the functions r1, r2, and r3
c     CPar   - Array of complex parameters passed to cgratr
c              to be used in the functions r1, r2, and r3
c     Limit1 - Lower limit of integration
c     Limit2 - Upper limit of integration
c     HLInt1 - Integral of r2 (first integral in eq. 13 of H.L.)
c     HLInt2 - Integral of r1 (second integral in eq. 13 of H.L.)
c     HLInt3 - Integral of r1 or r3 (3rd or 4th integral)
c     XSing  - Array of singularities of integrand (used by cgratr)      
      INTEGER NSing, NCalls, MaxNR
      DOUBLE PRECISION DPPar(10), Wp, Beta
      COMPLEX*16 CPar(10), Limit1, Limit2, HLInt1, HLInt2, HLInt3,
     &     XSing(20)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Loop variables:
      INTEGER i1, i2
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Parameters:
c     ZeroPl - lower bound Limit1
c     Inf    - Upper bound of Limit2
c     AbsErr - absolute error used by cgratr
c     RelErr - Relative error used by cgratr
c     Error  - used for error codes by cgratr      
      DOUBLE PRECISION ZeroPl, Inf, AbsErr, RelErr, Error
      PARAMETER(ZeroPl = 1.d-5, Inf = 1.d2)
      PARAMETER(AbsErr = 1.d-5, RelErr = 1.d-4)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Externals:
c     Externals:
c     cgratr      - integration routine
c     dr1,dr2,dr3 - functions to integrate
c     HFExc       - Calculates Hartree Fock exchange      
      COMPLEX*16 cgratr, r1, r2, r3, HFExc, Intgrl
      EXTERNAL cgratr, r1, r2, r3, HFExc, Intgrl
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc      
c     Initialization:
      NSing  = 0
      NCalls = 0
      MaxNR  = 0
c     DPPar is array of dp parameters to evaluate functions in cgratr.
c     Everything is in dimensionless units.
c     1. xwg
      DPPar(1) = (Wi/EFermi)
c     2. xgam
      DPPar(2) = gamma/EFermi
c     3. xe
      DPPar(3) = DBLE(Energy)/EFermi
c     4. xeg (gap energy)
      DPPar(4) = 0.d0
c     CPar is array of complex parameters to evaluate functions in cgratr.
c     ck in dimensionless units.
      CPar(1) = ck/kFermi
c     2. ce (complex energy)
      CPar(2) = Energy/EFermi
      
c     Josh - This is a possible fix for functions that overlap zero by a large
c     amount so that Wp does not equal Wi. 
*      Beta = 1.d0*Gamma*SQRT(2.d0/(Wi**2+Gamma**2))
c      Beta  = 0.9d0*Gamma*Gamma/(Wi**2+Gamma**2)
c      Wp =  2.d0*Gamma*LOG(Gamma/Beta) + 2.d0*ATAN2(Wi,Gamma) -
c     &     Gamma*LOG(Gamma**2 + Wi**2)
c      Wp = SQRT(Wi*Wp)
      
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DO i1 = 1, 1
         IF(i1.eq.2) THEN
            DPPar(1) = 0.d0
            DPPar(2) = 0.9d0*Gamma/EFermi
         END IF         
c     Calculate integrals in eq. 13 of H.L.
c     1)
c     Integral { ln[((ck+q)**2-E+Wq)/((ck-q)**2-E+Wq)] }
c     from ck + kFermi to Inf.
         Limit1 = ck/kFermi+1.d0
         Limit2 = Inf
      
c     Find singularities in r2
         iFcn = 2
         CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
      
c     Calculate integral
         HLInt1 = cgratr(r2,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &        NSing, XSing,Error,NCalls,MaxNR)
         DO i2 = 1, NSing
            XSing(i2) = (1.d0,0)*XSing(i2)
         END DO

c     2)
c     Integral { ln[(kFermi**2-E-Wq)/(kFermi**2-E+Wq)*
c                     ((ck+q)**2-E+Wq)/((ck-q)**2-E-Wq)] }
c     From ck - kFermi to ck + kFermi
         Limit1 = MAX(ABS(DBLE(ck)/kFermi-1.d0), ZeroPl)
         Limit2 = ck/kFermi+1.d0

c     Find singularities in r1
         IFcn = 1
         CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)

c     Calculate integral
         HLInt2 = cgratr(r1,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &        NSing, XSing,Error,NCalls,MaxNR)
         DO i2 = 1, NSing
            XSing(i2) = (1.d0,0)*XSing(i2)
         END DO      
            
c     3)
c     Theta(kFermi-Re(ck)) *
c     Integral { ln[((ck+q)**2-E-Wq)/((ck-q)**2-E-Wq)] } +
c     Theta(Re(ck)-kFermi) *
c     Integral { ln[((ck+q)**2-E+Wq)/((ck-q)**2-E+Wq)] }
c     (Integrals from 0 to kFermi - k and 0 to k - kFermi)
         Limit1 = ZeroPl
         Limit2 = ABS(DBLE(ck)/kfermi-1.d0)

c     If ck = kFermi, HLInt3 = 0
         IF((ABS(DBLE(ck)-kFermi).lt.ZeroPl).or.
     &        (DBLE(Limit2).le.DBLE(Limit1))) THEN
            HLInt3 = 0.d0
c     If ck < kFermi, HLint3 = Integral { ln[((ck+q)**2-E-Wq)/((ck-q)**2-E-Wq)] }
         ELSEIF(DBLE(ck).lt.kFermi) THEN
            Limit2 = 1.d0 - DBLE(ck)/kFermi
            
c     Find singularities in r3
            iFcn = 3         
            CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
c     Calculate integral
            HLInt3 = cgratr(r3,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &           NSing,XSing,Error,NCalls,MaxNR)
            DO i2 = 1, NSing
               XSing(i2) = (1.d0,0)*XSing(i2)
            END DO
         
c     Else ck > kFermi, HLint3 = Integral { ln[((ck+q)**2-E+Wq)/((ck-q)**2-E+Wq)] }
         ELSE
            Limit2 = DBLE(ck)/kFermi - 1.d0
            
c     Find singularities in r2
            iFcn = 2
            CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
            
c     Calculate integral
            HLInt3 = cgratr(r2,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &           NSing,XSing,Error,NCalls,MaxNR)
            DO i2 = 1, NSing
               XSing(i2) = (1.d0,0)*XSing(i2)
            END DO
         END IF
                           
         IF(i1.eq.1) THEN
            Sigma1 = - Amp*Wi*(Wi-coni*Gamma)/(2.d0*pi*EFermi*ck)*
     &           (HLInt1 + HLInt2 + HLInt3)
         ELSE
            Sigma1 = Sigma1 - Amp*Beta*
     &           Wi*(coni*Gamma)/(pi*EFermi*ck)*
     &           (HLInt1 + HLInt2 + HLInt3)
         END IF
      END DO
      
      RETURN
      END

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      FUNCTION dSigma(ck,Energy,Wi,Gamma,Amp,kFermi,EFermi)
c     Written by Josh Kas
c     Function dSigma calculates dSigma(ck,Energy)/dE from H.L.
c     electron gas model.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c     Input:
c     ck     - complex momentum
c     Energy - Energy
c     Wi     - Plasmon pole energy
c     Gamma  - Broadening of plasmon pole.
c     Amp    - Amplitude of plasmon pole.
c     kFermi - Fermi momentum
c     EFermi - Fermi energy
c              This is used when calculating dSigma/dE
      DOUBLE PRECISION Wi, Gamma, Amp, kFermi, EFermi
      COMPLEX*16 ck, Energy
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output:
c     Sigma(ck,Energy)
      COMPLEX*16 dSigma
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
c     Wp     - Plasmon frequency, for broadened poles, Wp is not the
c              same as Wi.
c     Beta   - g_i for the negative weight pole at zero. 
c              Adding the negative weight pole at zero corrects the
c              diverging sum rule for epsilon^-1. This is irrelevant
c              for unbroadened poles.
c     NSing  - Number of singularities of integrand (used in cgratr)
c     NCalls - Number of fcn calls used in cgratr
c     MaxNR  - Max number of regions used in cgratr
c     DPPar  - Array of double precision parameters passed to cgratr
c              to be used in the functions r1, r2, and r3
c     CPar   - Array of complex parameters passed to cgratr
c              to be used in the functions r1, r2, and r3
c     Limit1 - Lower limit of integration
c     Limit2 - Upper limit of integration
c     HLInt1 - Integral of dr2 (derivative of first integral in eq. 13 of H.L.)
c     HLInt2 - Integral of dr1 (derivative second integral in eq. 13 of H.L.)
c     HLInt3 - Integral of dr1 or dr3 (derivative of 3rd or 4th integral)
c     XSing  - Array of singularities of integrand (used by cgratr)      
      INTEGER NSing, NCalls, MaxNR
      DOUBLE PRECISION DPPar(10), Wp, Beta
      COMPLEX*16 CPar(10), Limit1, Limit2, HLInt1, HLInt2, HLInt3,
     &     XSing(20)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc      
c     Loop Variables:
      INTEGER i1, i2
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc      
c     Parameters:
c     ZeroPl - lower bound Limit1
c     Inf    - Upper bound of Limit2
c     AbsErr - absolute error used by cgratr
c     RelErr - Relative error used by cgratr
c     Error  - used for error codes by cgratr
      DOUBLE PRECISION ZeroPl, Inf, AbsErr, RelErr, Error
      PARAMETER(ZeroPl = 1.d-5, Inf = 1.d2)
      PARAMETER(AbsErr = 1.d-5, RelErr = 1.d-4)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Externals:
c     cgratr      - integration routine
c     dr1,dr2,dr3 - functions to integrate
c     HFExc       - Calculates Hartree Fock exchange
      COMPLEX*16 cgratr, dr1, dr2, dr3, HFExc
      EXTERNAL cgratr, dr1, dr2, dr3, HFExc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc            
c     Initialization:
      NSing  = 0
      NCalls = 0
      MaxNR  = 0
c     DPPar is array of dp parameters to evaluate functions in cgratr.
c     Everything is in dimensionless units.
c     1. xwg
      DPPar(1) = Wi/EFermi
c     2. xgam
      DPPar(2) = Gamma/EFermi
c     3. xe
      DPPar(3) = Energy/EFermi
c     4. xeg
      DPPar(4) = 0.d0
c     CPar is array of complex parameters to evaluate functions in cgratr.
c     ck in dimensionless units.
      CPar(1) = ck/kFermi
c     2. ce (complex energy)
      CPar(2) = Energy/EFermi + coni*DPPar(2)
      
c     Josh - This is a possible fix for functions that overlap zero by a large
c     amount so that Wp does not equal Wi. 
c     Wp= pi*Wi/2 + Wi*ArcTan[Wi/Gamma] - Gamma*Log[Beta] + Gamma*Log[Gamma] - 
c               1/2*Gamma*Log[Wi**2 + Gamma**2]
c      Beta = 1.d0*Gamma*SQRT(2.d0/(Wi**2+Gamma**2))
c      Beta  = 0.9d0*Gamma*Gamma/(Wi**2+Gamma**2)
c      Wp =  2*Gamma*LOG(Gamma/Beta) + 2*ATAN2(Wi,Gamma) -
c     &     Gamma*LOG(Gamma**2 + Wi**2)
c      Wp = SQRT(Wi*Wp)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      DO i1 = 1, 1
         IF(i1.eq.2) THEN
            DPPar(1) = 0.d0
            DPPar(2) = 0.9d0*Gamma/EFermi
         END IF         
         
c     Calculate derivatives of integrals in eq. 13 of H.L.      
c     1)
c     Integral d/dE{ ln[((ck+q)**2-E+Wq)/((ck-q)**2-E+Wq)] }
c     from ck + kFermi to Inf.      
         Limit1 = ck/kFermi+1.d0
         Limit2 = Inf
c     Find singularities in dr2
         iFcn = 2
         CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
         
c     Calculate integral
         HLInt1 = cgratr(dr2,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &        NSing, XSing,Error,NCalls,MaxNR)
         DO i2 = 1, NSing
            XSing(i2) = (1.d0,0)*XSing(i2)
         END DO
         
c     2)
c     Integral d/dE{ ln[(kFermi**2-E-Wq)/(kFermi**2-E+Wq)*
c     ((ck+q)**2-E+Wq)/((ck-q)**2-E-Wq)] }
c     From ck - kFermi to ck + kFermi
         Limit1 = MAX(ABS(DBLE(ck)/kFermi-1.d0), ZeroPl)
         Limit2 = ck/kFermi+1.d0
         
c     Find singularities in dr1
         iFcn = 1
         CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
         HLInt2 = cgratr(dr1,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &        NSing, XSing,Error,NCalls,MaxNR)
         DO i2 = 1, NSing
            XSing(i2) = (1.d0,0)*XSing(i2)
         END DO
         
c     3)
c     Theta(kFermi-Re(ck)) *
c     Integral { ln[((ck+q)**2-E-Wq)/((ck-q)**2-E-Wq)] +
c     Theta(Re(ck)-kFermi) *
c     Integral { ln[((ck+q)**2-E+Wq)/((ck-q)**2-E+Wq)]
c     (Integrals from 0 to kFermi - k and 0 to k - kFermi)
         Limit1 = ZeroPl
         Limit2 = ABS(DBLE(ck)/kfermi-1.d0)
         
c     If ck = kFermi, HLInt3 = 0      
         IF((ABS(DBLE(ck)-kFermi).lt.ZeroPl).or.
     &        (DBLE(Limit2).le.DBLE(Limit1))) THEN         
            HLInt3 = 0.d0
c     If ck < kFermi, HLint3 = Integral d/dE{ ln[((ck+q)**2-E-Wq)/((ck-q)**2-E-Wq)] }          
         ELSEIF(DBLE(ck).lt.kFermi) THEN
            Limit2 = 1.d0 - DBLE(ck)/kFermi
            
c     Find singularities in r3        
            iFcn = 3
            CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
            
c     Calculate integral         
            HLInt3 = cgratr(dr3,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &           NSing,XSing,Error,NCalls,MaxNR)
            DO i2 = 1, NSing
               XSing(i2) = (1.d0,0)*XSing(i2)
            END DO
c     Else ck > kFermi, HLint3 = Integral d/dE{ ln[((ck+q)**2-E+Wq)/((ck-q)**2-E+Wq)] }         
         ELSE
            Limit2 = DBLE(ck)/kFermi - 1.d0
            
c     Find singularities in r2         
            iFcn = 2
            CALL FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
            
c     Calculate integral         
            HLInt3 = cgratr(dr2,DPPar,CPar,Limit1,Limit2,AbsErr,RelErr,
     &           NSing,XSing,Error,NCalls,MaxNR)
            DO i2 = 1, NSing
               XSing(i2) = (1.d0,0)*XSing(i2)
            END DO
         END IF

         IF(i1.eq.1) THEN
            dSigma = - Amp*Wi*(Wi-coni*Gamma)/(2.d0*pi*EFermi*ck)*
     &           (HLInt1 + HLInt2 + HLInt3)
         ELSE
            dSigma = dSigma - Amp*Beta*
     &           Wi*(coni*Gamma)/(pi*EFermi*ck)*
     &           (HLInt1 + HLInt2 + HLInt3)
         END IF
      END DO
      
      RETURN
      END      

      FUNCTION HFExc(ckIn, EFermi, kFermi)
c     returns dirac-hara hartree-fock exchange
c     ck - complex momentum in units of kFermi
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      COMPLEX*16 ckIn, ck, HFExc, c
      DOUBLE PRECISION EFermi, kFermi
      ck = ckIn/kFermi
      c=-2.d0*EFermi/(pi*kFermi)
      IF(ABS(ck-1.d0).le.0.00001d0) THEN
         HFExc = c
      ELSE
         HFExc = c*(1.d0+(1.d0/ck-ck)* log( (1.d0+ck)/(ck-1.d0) )/2.d0)
      END IF
      RETURN
      END
      
c****************************************************************************
c     the following function routines are used for evaluating integals and
c     their derivatives.
c****************************************************************************
      complex*16 function r1(q,dppar,cpar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      
c     Input:
      double precision dppar(4)
c     dppar contains:
c     xe, xeg, xwg, xgam
      complex*16 cpar(2)

c     Local Variables:
      complex*16 fq,fqq,fiq,a1,a2,a3,a4,t1,t2,q,ck,xe
      external fq

      ck=CPar(1)
c     3. xe
      xe = CPar(2)
c     4. xeg
      xeg = DPPar(4)
c     print*, 'call fq(q),ck', q, ck
      fqq=fq(q,dppar)
c     print*,'fqq=', fqq
      fiq=1./(q*fqq)
      a1=1.d0-xeg-xe-fqq - coni*1.d-10
      a2=(ck+q)**2-xe+fqq - coni*1.d-10
      a3=(ck-q)**2-xe-fqq - coni*1.d-10
      a4=1.d0+xeg-xe+fqq - coni*1.d-10
      t1=(a1*a2)
      t2=(a3*a4)
c     print*,'a1,a2,a3,a4,t1,t2',a1,a2,a3,a4,t1,t2
c      t1=t1/t2
      r1=fiq*(log(a1)+log(a2)-log(a3)-log(a4))
c     Test with r=E
c      r1=xe
c     print*,'r1 return to cgratr', r1
      return
      end
c****************************************************************************
      complex*16 function dr1(q,dppar,cpar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      
c     Input:
      double precision dppar(4)
c     dppar contains:
c     xe, xeg, xwg, xgam
      complex*16 cpar(2)

c     Local Variables:
      complex*16 fq,fqq,fiq,a1,a2,a3,a4,t1,t2,q,ck,xe
      external fq

      ck=CPar(1)
c     3. xe
      xe = CPar(2)
c     4. xeg
      xeg = DPPar(4)
c     print*, 'call fq(q),ck', q, ck
      fqq=fq(q,dppar)
c     print*,'fqq=', fqq
      fiq=1./(q*fqq)
      a1=1.d0-xeg-xe-fqq - coni*1.d-10
      a2=(ck+q)**2-xe+fqq - coni*1.d-10
      a3=(ck-q)**2-xe-fqq - coni*1.d-10
      a4=1.d0+xeg-xe+fqq - coni*1.d-10
c     print*,'a1,a2,a3,a4,t1,t2',a1,a2,a3,a4,t1,t2
c      t1=t1/t2
      dr1 = -fiq*(1.d0/a1+1.d0/a2-1.d0/a3-1.d0/a4)
c     Test with r=E
c      dr1=1.d0
c      write(51,*) dble(q), dble(dr1)
c     print*,'r1 return to cgratr', r1
      return
      end
c**********************************************************************
      complex*16 function r2(q,dppar,cpar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      
c     Input:
      double precision dppar(4)
c     dppar contains:
c     xe, xeg, xwg, xgam
      complex*16 cpar(2)

c     Local Variables:
      complex*16 fqq,fq,fiq,a1,a2,q,ck,xe
      ck = CPar(1)
c     3. xe
      xe = CPar(2)
c     4. xeg
c      xeg = DPPar(4)
      
      fqq=fq(q,dppar)
      fiq=1.d0/(q*fqq)
      a1=((ck+q)**2-xe+fqq) - coni*1.d-10
      a2=((ck-q)**2-xe+fqq) - coni*1.d-10
      r2=fiq*(log(a1)-log(a2))
c     Test with r=E
c      r2=xe      
30    return
      end
c**********************************************************************
      complex*16 function dr2(q,dppar,cpar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      
c     Input:
      double precision dppar(4)
c     dppar contains:
c     xe, xeg, xwg, xgam
      complex*16 cpar(2)

c     Local Variables:
      complex*16 fqq,fq,fiq,a1,a2,q,ck,xe
      ck = CPar(1)
c     3. xe
      xe = CPar(2)
c     4. xeg
c      xeg = DPPar(4)
      
      fqq=fq(q,dppar)
      fiq=1.d0/(q*fqq)
      a1=((ck+q)**2-xe+fqq) - coni*1.d-10
      a2=((ck-q)**2-xe+fqq) - coni*1.d-10
      dr2=-fiq*(1.d0/a1-1.d0/a2)
c     Test with r=E
c      dr2=1.d0      
c      write(52,*) dble(q), dble(dr2)
30    return
      end  
c**********************************************************************
      complex*16 function r3(q,dppar,cpar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     Input:
      double precision dppar(4)
c     dppar contains:
c     xe, xeg, xwg, xgam
      complex*16 cpar(2)

c     Local Variables:
      complex*16 fqq,fq,fiq,a1,a2,q,ck,xe
      ck = CPar(1)
c     3. xe
      xe = CPar(2)
c     4. xeg
c      xeg = DPPar(4)
c     valid only for k<kf, q<kf-k ?
      fqq=fq(q,dppar)
      fiq=1.d0/(q*fqq)
      a1=( (ck+q)**2-xe-fqq) - coni*1.d-10
      a2=( (ck-q)**2-xe-fqq) - coni*1.d-10
      r3=fiq*(log(a1) - log(a2))
c     Test with r=E
c      r3=xe      
30    return
      end
c**********************************************************************
      complex*16 function dr3(q,dppar,cpar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

c     Input:
      double precision dppar(4)
c     dppar contains:
c     xe, xeg, xwg, xgam
      complex*16 cpar(2)

c     Local Variables:
      complex*16 fqq,fq,fiq,a1,a2,q,ck,xe
      ck = CPar(1)
c     3. xe
      xe = CPar(2)
c     4. xeg
c      xeg = DPPar(4)
c     valid only for k<kf, q<kf-k ?
      fqq=fq(q,dppar)
      fiq=1.d0/(q*fqq)
      a1=( (ck+q)**2-xe-fqq) - coni*1.d-10
      a2=( (ck-q)**2-xe-fqq) - coni*1.d-10
      dr3=-fiq*(1.d0/a1-1.d0/a2)
c     Test with r=E
c      dr3=1.d0
c      write(53,*) dble(q), dble(dr2)
30    return
      end     
c**********************************************************************
      complex*16 function fq(q,dppar)
      implicit double precision (a-h,o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      complex*16 q
      double precision dppar(4)

c     1. xwg
      xwg = DPPar(1)
c     2. xgam
      xgam = DPPar(2)
      
c     Here I am going to change the dispersion relation to 
c     wq = wp + 1/2 * q**2 
c     This makes calculation of broadened poles easier. 
c      fq = xwg-coni*xgam + q**2
      
c     fq(q)=w1(q)=sqrt(w1**2+((omega(q)-omega_p)/omega_f)**2)
c     omega(q)**2=omega_p**2+omega_g**2(q)
c     fq(q)=xwg+a2*q**2+a4*q**4    xwg=(w1/ef)**2
c     electron gas parameters xwg=wp**2 a2=4/3, a4=1
c     uncomment the following 4 lines to use the old dispersion relation.
      a2=4.d0/3.d0
      a4=1.d0
      fq=(xwg-coni*xgam)**2 + a2*q*q + a4*q**4
      fq=sqrt(fq)
      return
      end

      FUNCTION Intgrl(func, a, b, NPts, DpPar, CPar)
c     Function Integ integrates func by trapezoidal rule from a to b
c     using NPts steps size.
      COMPLEX*16 Intgrl, a, b, CPar(10)
      DOUBLE PRECISION DpPar(10)
      INTEGER NPts
      COMPLEX*16 func
      EXTERNAL func

      INTEGER i1
      COMPLEX*16 dx, sum, y1, y2, x1, x2


      sum = 0.d0
      dx = (b-a)/DBLE(NPts-1)
      
      x1 = a
      y1 = func(x1, DpPar, CPar)
      
      DO i1 = 1, NPts
         x2 = a + i*dx
         y2 = func(x2, DpPar, CPar)
         sum = sum + (y1+y2)
         y1 = y2
         x1 = x2
      END DO

      Intgrl = sum*dx/2.d0

      RETURN
      END
               
c*********************************************************************
c   This is Steve White's rewrite of Mike Teter's integration routine.  
c   Modified by J. Rehr for complex integration.
c   The following is a listing of the arguments in the initial function 
c   statement:
c     fn    -- routine requires external function statement in MAIN
c     xmin  -- lower limit
c     xmax  -- upper limit
c     abr   -- absolute tolerable error
c     rlr   -- relative tolerable error
c     nsing -- number of singularities or regions requiring 
c     special attention
c     xsing -- array of locations of singularities or endpoints
c     of special regions
c     error -- output for routine error messages
c     numcal-- the number of times fn was called
c     maxns -- the maximum number of regions being considered simultaneously
c     function cgratr(fn,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)
c     fn declared double precision
c     double precision function cgratr(fn,xmin,xmax,abr,rlr,
c     fn declared complex*16
      
      complex*16 function cgratr(fn,dppar,cpar,xmin,xmax,abr,rlr,
     &     nsing,xsing,error,numcal,maxns)
      implicit double precision (a-h,o-z)
      parameter (mx=1500)
      integer nsing
      complex*16 fn,value,valu,fval(3,mx),xmax,xmin,del,del1
      complex*16 xleft(mx), xsing(20), cpar(10)
      double precision dppar(10)
      external fn
c     dimension xleft(mx),fval(3,mx),dx(3),wt(3)
      dimension wt9(9),dx(3),wt(3)
c     dimension xsing(20)
      logical atsing
      save dx,wt,wt9
      data dx/0.1127016653792583  ,0.5  ,0.8872983346207417  /
      data wt/0.277777777777777778  ,0.4444444444444444444  ,
     1     0.2777777777777777778  /
      data wt9/0.0616938806304841571  ,0.108384229110206161  ,
     1     0.0398463603260281088  ,0.175209035316976464  ,
     2     0.229732989232610220  ,0.175209035316976464  ,
     3     0.0398463603260281088  ,0.108384229110206161  ,
     4     0.0616938806304841571  /
c     nstack is the number of different intervals into which the 
c     integration region is currently divided. The number of regions can
c     grow if more accuracy is needed by dividing the right-most region
c     into three regions. The number of regions shrinks when the integral
c     over the right-most region is accurate enough, in which case that
c     integral is added to the total (stored in cgratr) and the region
c     is removed from consideration (and a new region is the right-most).
      nstack=nsing+1
      maxns = nstack
      error=0.  
      cgratr=0.  
c     The array xleft stores the boundary points of the regions.
c     The singular points just govern the initial placement of the regions.
      xleft(1)=xmin
      xleft(nsing+2)=xmax
      if(nsing.gt.0) then
         do 9 j=1,nsing
            xleft(j+1)=xsing(j)
 9       continue
      endif
c     For each region, calculate the function and store at three selected points.
      do 1 jj=1,nstack
         del=xleft(jj+1)-xleft(jj)
c     print*, 'fn call j= ,'
         do 1 j=1,3
c     print*, 'fn call in cgratr j= ',j
            fval(j,jj)=fn(xleft(jj)+del*dx(j),dppar,cpar)
 1    continue
c     print*, 'output of fn call, fval(j,jj)',fval(j,jj)
      numcal = nstack * 3
 6    continue
      if(nstack+3.ge.mx) then
         write(*,*) ' TOO MANY REGIONS'
         stop 0006
      endif
c     Divide the rightmost region into three subregions.  
      del=xleft(nstack+1)-xleft(nstack)
      xleft(nstack+3)=xleft(nstack+1)
      xleft(nstack+1)=xleft(nstack)+del*dx(1)*2.
      xleft(nstack+2)=xleft(nstack+3)-del*dx(1)*2.
c     The three data points already found for the region become the 
c     middle data points (number 2 in first index of fval) for each region.
      fval(2,nstack+2)=fval(3,nstack)
      fval(2,nstack+1)=fval(2,nstack)
      fval(2,nstack)=fval(1,nstack)
c     Now do the integral over the right-most region in two different ways-
c     a three point integral (valu) over each of the three subregions 
c     and a more accurate nine-point integral (value) over whole region.
c     valu is used only for the error estimate.
      icount=0
      value=0.  
      valu=0.  
      do 3 j=nstack,nstack+2
         del1=xleft(j+1)-xleft(j)
c     print*, 'fn call 2'
         fval(1,j)=fn(xleft(j)+dx(1)*del1,dppar,cpar)
         fval(3,j)=fn(xleft(j)+dx(3)*del1,dppar,cpar)
c     print*, 'fn call 2'
         numcal = numcal + 2
         do 5 k=1,3
            icount=icount+1
            value=value+wt9(icount)*fval(k,j)*del
            valu=valu+fval(k,j)*wt(k)*del1
 5       continue
 3    continue
      dif=abs(value-valu)
c     If the following condition is true, add in this integral to the total,
c     and reduce the number of regions under consideration.
      frac = del / (xmax - xmin)
      atsing = .false.
      if(frac .le. 1.0e-8) atsing = .true.
      if(dif .le. abr*frac .or. dif.le.rlr*abs(value) .or. 
     1     (atsing .and. 
     2     (frac .le. 1.0e-15 .or. dif .le. abr*0.1  ))) then
c     The following commented out line is Teeter's old error criterion.
c     if(dif.le.abr.or.dif.le.rlr*abs(value))then
         cgratr=cgratr+value
         error=error+abs(dif)
         nstack=nstack-1
c     If no more regions, we are done.
         if(nstack.le.0) return
      else
c     If the integration is insufficiently accurate, make each of the 
c     three subregions of the right-most region into regions.
c     On next pass the right-most of these is the new current region.
         nstack=nstack+2
         maxns = max(maxns,nstack)
      endif
      go to 6
      end
      SUBROUTINE CSigZ(Energy, Mu, Rs, ReSig, ImSig, ZTot, WpScl, Gamma,
     &     AmpFac)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Written by Josh Kas
c     This subroutine calculates the self energy Sigma(k(Energy),Energy)
c     based on an electron gas model of epsilon^-1.
c      
c     Solve: k0**2 = 2*Energy - 2*Mu -
c                    2*(Sigma(k0,Energy)-Sigma(kFermi,EFermi))
c            
c     Steps:
c
c            1. k0**2  = 2*(Energy-Mu) + SigmaF (SigmaF is self energy at fermi level).
c            2. Sigma0 = Sigma(k0,Energy)
c            3. Find derivative w.r.t. E dSgdE
c            4. k1**2  = 
c                  k0**2 - 2*(Sigma0-SigmaF)/(1-dSgdE)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c     Parameters:
c     MxPole - Maximum number of poles
      INTEGER MxPole
      PARAMETER(MxPole=1000)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input:
c     Energy - Energy at which to evaluate Sigma
c     Mu     - Fermi energy as calculated by FEFF.
c     Rs     - R sub s (sphere of radius Rs holds charge e)
c     WpScl  - Scale Wp in interstitial by WpScl
c     Gamma  - Use broadening Gamma when calculating Sigma
c     AmpFac - Use amplitude AmpFac for plasmon pole.
      DOUBLE PRECISION Rs, WpScl(MxPole), Gamma(MxPole),
     &     AmpFac(MxPole), Mu
      COMPLEX*16 Energy
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output:
c     ReSig  - Re[Sigma(k,e)]
c     ImSig  - Im[Sigma(k,e)]
c     ZTot   - Renormalization factor Z = 1/(1-dSgdE)
c     Note: Atomic units are used.
      DOUBLE PRECISION ReSig, ImSig
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
c     kFermi - Fermi momentum calculated from Rs via electron gas
c              approximation.
c     EFermi - Fermi energy = kFermi^2/2
c     Wp     - Electron gas plasmon frequency.
c     Gam    - broadening for broadened pole.
c     ckF    - complex variable to store kFermi
c     ck0    - complex momentum
c     SigmaF - Self energy at the fermi energy and fermi momentum
c              Does not include the Hartree Fock part.
c     Sigma0 - Single pole self energy evaluated at
c              Wp = Wp(ipole)/Wp(R_Interstitial)*Wp(Rs)
c     dSgdE  - Derivative of sigma w.r.t. Energy
c     ZTot   - Renormalization factor Z = 1/(1-dSgdE)
c     RelEn  - Energy relative to the fermi energy from FEFF      
c              Relen = Energy - Mu + EFermi
c     SigTot - Total many pole deltaSigma = Sigma(E,k(E))-Sigma(EF,kF)
c     DelHF  - Sigma_HartreeFock(k) - Sigma_HartreeFock(kF)
      DOUBLE PRECISION kFermi, EFermi, Wp, Gam
      COMPLEX*16 ckF, ck0, SigmaF, Sigma0, dSgdE, ZTot, RelEn, RelEnP,
     &     SigTot, DelHF, SigmaP
c     Loop variables
      INTEGER i1, i2

c     Parameters:
      DOUBLE PRECISION DPZero
      PARAMETER(DPZero = 0.d0)
      INTEGER MxIter
      PARAMETER(MxIter = 1)

c     Externals:
c     Sigma1 - calculates the energy dependent part of self energy
c              for a single pole.
c     dSigma - calculates derivative of self energy w.r.t energy.
c     HFExt  - calculates Hartree Fock exchange
      COMPLEX*16 Sigma1, dSigma, HFExc
      EXTERNAL Sigma1, dSigma, HFExc
      
c     Initialization
      ZTot = 0.d0
      kFermi = fa/Rs
      EFermi = kFermi*kFermi/2.d0
      SigTot=0.d0
      dSgdE = 0.d0
      SigmaF = 0.d0
      Gam = 0.d0

c     Loop1: Start self consistency loop.
c     This does not seem to work, so MxIter = 1
      DO i2 = 1, MxIter

c        Loop2: Loop over poles to get SigmaF
         DO i1 = 1, MxPole
            IF(WpScl(i1).lt.0) GOTO 5
            
c           Wp is in Hartrees            
            Wp = SQRT(3.d0/Rs**3)*WpScl(i1)
c            Gam = Gamma(i1)
            
c           find Sigma_Fermi (SigmaF)
            ckF = kFermi*1.00001d0
            RelEn = EFermi
            SigmaF = SigmaF + Sigma1(ckF,RelEn,Wp,Gam,AmpFac(i1),
     &           kFermi, EFermi)
         END DO
c        End Loop2
 5       CONTINUE
         
         dsgdE = 0.d0
c        Loop3: Loop over poles         
         DO i1 = 1, MxPole
            IF(WpScl(i1).lt.0) GOTO 10
c           Wp is in Hartrees
            Wp = SQRT(3.d0/Rs**3)*WpScl(i1)
c            Gam = Gamma(i1)
c           Start with ck0=Sqrt[Re(Energy)-Mu+EFermi]
            RelEn = DBLE(Energy) - Mu + EFermi
            ck0 = SQRT(2.d0*DBLE(RelEn))
            
c           Find Sigma0 = Sigma(ck0,E); ck0=SQRT(2*(Energy-Mu))
            Sigma0 = Sigma1(ck0,RelEn,Wp,Gam,AmpFac(i1),kFermi,
     &           EFermi)
                  
            RelEnP = RelEn*0.001d0
            SigmaP = Sigma1(ck0,RelEnP,Wp,Gam,AmpFac(i1),kFermi,
     &           EFermi)

c            write(71,*) DBLE(RelEn-EFermi), DBLE(dSgdE), DIMAG(dSgDE)
            dSgdE = dSgdE + (SigmaP - Sigma0)/(RelEnP-RelEn)
c            dSgdE = dSgdE + 
c     &          dSigma(ck0,RelEn,Wp,Gam,AmpFac(i1),kFermi,EFermi)
c           Uncomment the following line to print derivative            
c            write(72,*) DBLE(RelEn-EFermi), DBLE(dSgdE2), DIMAG(dSgDE2)         

c           SigTot is sum of poles
            SigTot = SigTot + Sigma0
            
c        End Loop3: loop over poles.            
         END DO         
 10      CONTINUE
         
c     End Loop1: self-consistency loop      
      END DO


c     Add Hartree Fock part of delta Sigma.
      DelHF = HFExc(ck0,EFermi,kFermi) - HFExc(ckF,EFermi,kFermi)
      SigTot = SigTot - SigmaF + DelHF

c     Form ZTot and return Re and Im parts of Sigma.
      ZTot = 1.d0/(1.d0-dSgdE)
c      ZTot = 1.d0
      SigTot = ZTot*(SigTot)
      
      ReSig = DBLE(SigTot)
      ImSig = DIMAG(SigTot)
      
      RETURN
      END

      SUBROUTINE FndSng(Limit1, Limit2, NSing, XSing, DPPar, CPar, iFcn)
c     Josh Kas
c     This subroutine finds the singularities in the integrands of eq. 13
c     in
c     Single-particle Spectrum of the Degenerate Electron Gas
c     II. Numerical Results for Electrons Coupled to Plasmons
c     Phys. kondens. Materie, Bd. 6 (1967)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc      
c     In practice this routine only solves for the singularities of one
c     of the three integrands, then checks to see that the singularity
c     is within the limits of integration, and throws out singularities
c     that are not.
c     In units of the Fermi energy the equations to solve are:
c     1) +/- k*q**3 + 2*(3*k**2 - E - 2/3)*q**2 +/- 4*k*(k**2 - E)*q +
c                     [(k**2 - E)**2 - Wp**2] = 0 
c     2) q**4 + 4/3*q**2 + Wp**2 - (1 - E)**2 = 0
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc      
c     Input:
c     Limit1 - Lower limit of integration
c     Limit2 - Upper limit of integration
c     CPar   - Array of complex parameters passed to function
c              CPar(1) = ck/kFermi
c              CPar(2) = Energy/EFermi + i*Gamma/EFermi
c     DPPar  - Array of double precision parameters passed to function
c              DPPar(1) = Wp/EFermi
c              DPPar(2) = Gamma/EFermi
c              DPPar(3) = Energy/EFermi
c              DPPar(4) = xeg (gap energy)
c     iFcn   - Integer denoting which function is the integrand
c              iFcn = 1: solve eqs 1 and 2 for q
c              iFcn = 2: solve eq 1 for q      
      COMPLEX*16 Limit1, Limit2, CPar(10)
      DOUBLE PRECISION DPPar(10)
      INTEGER iFcn
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output:
c     XSing  - Array of singularities
c     NSing  - Number of singularities
      COMPLEX*16 XSing(20)
      INTEGER NSing
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables:
c     Coef   - Coefficients of q**n of eq. to solve.
c              eq = Coef(1)*q**n + Coef(2)*q**(n-1)...
c     Sol(4) - Array of solutions to the equation.
c     XSing2 - Temp XSing      
c     Test   - Used to test solution of equation.
c     Zero   - Tolerance for testing solution to eqs.
c     NSol   - Number of solutions to eq.
c     Order  - Used to order singulaties from smallest to largest
      COMPLEX*16 Coef(4), Sol(4), XSing2(4)
      DOUBLE PRECISION Test, Zero
      INTEGER NSol, Order(100)
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Loop variables
      INTEGER i1, i2
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     Initialization
      NSing = 0
      Zero=1.d-4

c     Solve eq 1 for q with + sign
      Coef(1) = 4.d0*CPar(1)
      Coef(2) = 2.d0*(3.d0*CPar(1)**2 - DPPar(3) - 2.d0/3.d0)
      Coef(3) = 4.d0*CPar(1)*(CPar(1)**2 - DPPar(3))
      Coef(4) = (CPar(1)**2 - DPPar(3))**2 - DPPar(1)**2
      
      CALL CCubic(Coef, Sol, NSol)
      
c     Test solutions. If Sol is a solution and it is real
c     and it lies between Limit1 and Limit2, add it to list
c     of singularities.         
      DO i1 = 1, NSol
         Test = ABS((CPar(1)+Sol(i1))**2 - DPPar(3) +
     &        SQRT(Sol(i1)**4 + 4.d0/3.d0*Sol(i1)**2 + DPPar(1)**2))
         IF(Test.lt.Zero) THEN               
            IF((DBLE(Sol(i1)).ge.DBLE(Limit1)).and.
     &           (DBLE(Sol(i1)).le.DBLE(Limit2)).and.
     &           (ABS(DIMAG(Sol(i1))).le.Zero)) THEN               
               NSing = NSing + 1
               XSing(NSing) = DBLE(Sol(i1))
            END IF
         END IF
      END DO
      
c     Now solve eq. 1 for q with - sign
      Coef(1) = -Coef(1)
      Coef(3) = -Coef(3)
      
      CALL CCubic(Coef, Sol, NSol)
      
c     Test solutions as before.
      DO i1 = 1, NSol
         Test = ABS((CPar(1)-Sol(i1))**2 - DPPar(3) -
     &        SQRT(Sol(i1)**4 + 4.d0/3.d0*Sol(i1)**2 + DPPar(1)**2))
         IF(Test.lt.Zero) THEN
            IF((DBLE(Sol(i1)).ge.DBLE(Limit1)).and.
     &           (DBLE(Sol(i1)).le.DBLE(Limit2)).and.
     &           (ABS(DIMAG(Sol(i1))).le.Zero)) THEN
               NSing = NSing + 1
               XSing(NSing) = DBLE(Sol(i1))
            END IF
         END IF
      END DO

c     If iFcn = 1 (Solving for singularities of r1(q))
      IF(iFcn.eq.1) THEN         
c        Solve eq. 2 for q
         Coef(1) = 1.d0
         Coef(2) = 4.d0/3.d0
         Coef(3) = DPPar(1)**2

         CALL CQdrtc(Coef,Sol,NSol)
         DO i1 = 1, NSol
            XSing2(2*i1-1) =  DBLE(SQRT(Sol(i1)))
            XSing2(2*i1)   = -DBLE(SQRT(Sol(i1)))
         END DO

c        Test Solutions
         DO i1 = 1, 2*NSol
            IF((DBLE(XSing2(i1)).ge.DBLE(Limit1)).and.
     &           (DBLE(XSing2(i1)).le.DBLE(Limit2)).and.
     &              (ABS(DIMAG(Sol(i1))).le.Zero)) THEN
               NSing = NSing + 1
               XSing(NSing) = XSing2(i1)
            END IF
         END DO
      END IF
      
c     Sort singularities
      CALL QSORTI(Order,NSing,Xsing)
      DO i1 = 1, NSing
         XSing2(i1) = XSing(i1)
      END DO
      DO i1 = 1, NSing
         XSing(i1) = XSing2(Order(i1))
      END DO

      RETURN
      END
c///////////////////////////////////////////////////////////////////////
c Distribution:  FEFF_MATH 1.0
c Copyright (c) [2002] University of Washington
c 
c This software was prepared in part with US Government Funding under
c DOE contract DE-FG03-97ER45623.

c Redistribution and use of this Distribution in source and binary
c formats, with or without modification is permitted, provided the 
c following conditions are met:
c 
c Redistributions must retain the above notices and the following list
c of conditions and disclaimer;
c 
c Modified formats carry the marking
c     "Based on or developed using Distribution: FEFF_MATH 1.0
c      FEFF_MATH 1.0 Copyright (c) [2002] University of Washington"
c 
c Recipient acknowledges the right of the University of Washington to
c prepare uses of this Distribution and its modifications that may be
c substantially similar or functionally equivalent to
c Recipient-prepared modifications.
c
c Recipient and anyone obtaining access to the Distribution through
c recipient's actions accept all risk associated with possession and
c use of the Distribution.
c
c THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
c WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
c MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
c IN NO EVENT SHALL THE UNIVERSITY OF WASHINGTON OR CONTRIBUTORS TO THE
c DISTRIBUTION BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
c EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
c PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
c REVENUE; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
c LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
c NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
c SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      subroutine bcoef(kinit, ipol, ptz, le2, ltrace, ispin, angks,
     1                 kind, lind, bmat)
c     written by alexei ankudinov; march 2000
c     calculate bmat: the energy independent sum over polarization and
c     angular momenta indices
c     bmat = \sum_{p,p', all m_j} <LS|J><J|R|J1><J1|\alpha_p exp(i kz)|I>
c                    ptz(p,p') 
c            <I|\alpha_p'^* exp(-i kz) J2><J2|R'|J'><J'|L'S'>
c     where R is rotation from spin vector to x-ray k-vector
c     and R' is rotation back
c     see Eq.10 and 11 in Ankudinov,Rehr, Phys.Rev.B (accepted),
c     Theory of solid state contribution to the x-ray elastic scattering
c     aditional rotation matrices are needed when x-ray k-vector
c     is not along the spin-axis (see rotations in rdinp)

c     more precisely it is
c     bmat(l1 l1' j l ml ms; l2 l2' j' l' ml' ms') =
c        (-)**(j-j'+l2'+1) i**(l'-l) \sum_{p,p',mi,m1,mj,m2,mj'}
c        <LS|J>   r^j_{m1,mj}(angks)   3j( j l1 i ; -m1 p mi)
c        (-p)**(l1+l1'+1) ptz(p,p') (-p')**(l2+l2'+1) 
c        3j( j' l2 i ; -m2  p' mi)   r^j'_{m2,mj'}(angks)   <J'|L'S'>
c     where l1 l1' are set by the multipole moment(E1-l1=1,l1'=0;
c     E2-l1=2,l1'=1; M1-l1=1,l1'=1; etc.;
c     j and l define quantum number kappa and for each multipole moment
c     Only few final kappa's are allowed and  it is convinient
c     to denote (l1 l1' j l) by one index 'k'
c     thus  k=1-8 to include both E1 and E2 transitions;
c     ml and ms are projections of orbital and spin moments.

c     bmat  is used to calculate absorption fine structure (chi) via
c       chi = \sum_{k ms,k' ms'}  rkk(k,ms)  rkk(k',ms')
c       \sum_{ml,ml'}  bmat(k ml ms; k' ml' ms')  G_(l' ml' ms';l ml ms)
c     where sum over spins can be moved from first sum to second for
c     spin independent systems. The above expression is suitable for FMS
c     and for MS expansion on can use Eq.15 in RA paper to obtain
c     expression for the termination   matrix
c     T_{lam1 ms,lamN ms'} = \sum_{k k'} rkk(k,ms) rkk(k',ms')
c       \sum_{ml,ml'}  bmat(k ml ms; k' ml' ms') gam(l,lam1,rho1,ms)
c        gamtl(l',lamN,rhoN,ms')
c     Notice that for spin-dependent systems the scattering F matrices
c     in RA paper also should have additional spin indices. In genfmt
c     we currently neglect spin-flip processes which simplifies
c     calculations with MS expansion. (T and F are diagonal in ms,ms')
       
c     This subroutine is written for general spin-dependent asymmetric
c     system and arbitrary polarization tenzor. The symmetry of the 
c     system and polarization tenzor can be used
c     to speed up FMS or MS calculations in appropriate subroutines.
c     (see comments in subroutines mpprmp, fmstot)

c     input:
c       kinit - kappa for initial orbital
c       ipol - polarization type measurement
c       ptz  - polarization tensor (needed only for ipol=1 case)
c       le2  - sets which multipole moments to include (see mkptz)
c       ltrace- .true. for xsect.f, where need to perform trace over ml
c       angks - angle between k-vector and spin-vector 

c     output
c       lind  - orb.mom.(kappa)  needed in fmstot only (for indexing)
c       bmat  - energy independent matrix to calculate absorption 
c       in many cases bmat is diagonal due to the choice of xyz frame,
c       but for general case full 16*(2*lx+1)*16*(2*lx+1) matrix is kept

      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 coni
      parameter (coni = (0,1))

c     need only parameter lx to set max orb momentum
      complex*16 ptz, bmat, pmat, tmat
      dimension ptz(-1:1,-1:1),  bmat(-lx:lx,0:1,8, -lx:lx,0:1,8)
c       to include all possible dipole and quadrupole transitions 
c       final kp, and kpp have 8 possibilities
      logical ltrace

c     local staff
      dimension  t3j( 8, 0:1, -lx:lx+1), x3j(8, -1:1, -lx:lx+1)
c     qmat = <J2|R'|J'><J'|L'S'> - diagonal in kappa index
      dimension qmat( -lx:lx+1, -lx:lx, 0:1, 8)
c     pmat = <J1|\alpha_j exp(i kz)|I> ptz <I|\alpha_k^* exp(-i kz)|J2>
      dimension pmat( -lx:lx+1, 8, -lx:lx+1, 8)
c     tmat = pmat*qmat ; bmat = qmat^T*tmat
      dimension tmat( -lx:lx+1, 8, -lx:lx, 0:1, 8)
c     total and orbital momenta for 8 possible final kappa
      dimension jind(8), lind(8), kind(8)

      external cwig3j

      do 10 i6 = 1, 8
      do 10 i5 = 0 ,1
      do 10 i4 = -lx,lx
      do 10 i3 = 1, 8
      do 10 i2 = 0 ,1
      do 10 i1 = -lx,lx
         bmat( i1, i2, i3, i4, i5, i6) = 0
  10  continue

c     3 dipole transitions
      do 20 k=-1,1
         kap=kinit+k
         if (k.eq.0) kap=-kap
         jkap = abs(kap)
         lkap = kap
         if (kap.le.0) lkap = abs(kap) -1
c        check that orbital momentum does not exceed max allowed
         if (lkap .gt. lx) then
c          set final j and l to unphysical values
           jkap = 0
           lkap = -1 
           kap = 0
         endif
         jind(k+2) = jkap
         lind(k+2) = lkap
         kind(k+2) = kap
  20  continue

c     include 5 quadrupole or 3 mag.dipole  transitions
      do 120 k=-2,2
         jkap = abs(kinit) + k
         if (jkap.le.0) jkap = 0
         kap= jkap
         if (kinit.lt.0 .and. abs(k).ne.1) kap=-jkap
         if (kinit.gt.0 .and. abs(k).eq.1) kap=-jkap
         lkap = kap
         if(kap.le.0) lkap = - kap - 1
         if (lkap.gt.lx .or. le2.eq.0
     1                  .or. (le2.eq.1 .and. abs(k).eq.2)) then
c           set unphysical jkap and lkap to make shorter calculations
            jkap = 0
            lkap = -1
            kap = 0
         endif
         jind(k+6) = jkap
         lind(k+6) = lkap
         kind(k+6) = kap
 120  continue

      if (ipol.eq.0) then
c       polarization average case; bmat is diagonal and simple
        do 100 k = 1, 8
        do 100 ms = 0 ,1
        do 100 ml = -lind(k), lind(k)
c         i2 = (2*l1+1) , where l1 is defined by multipole moment
          i2 = 3
          if (le2.eq.2 .and. k.gt.3) i2 = 5
          bmat(ml,ms,k, ml,ms,k) = 0.5d0 / (2*lind(k)+1.d0) / i2
          if (k.le.3) bmat(ml,ms,k, ml,ms,k) = - bmat(ml,ms,k, ml,ms,k)
 100    continue
      else
c       more complicated bmat for linear(ipol=1) and circular(ipol=2)
c       polarizations
c       Put 3j factors in x3j and t3j. t3j are multiplied by
c       sqrt(2*j'+1) for  further convinience.
        do 30  mp=-lx,lx+1
        do 30  ms=0,1
        do 30  k1=1,8
  30    t3j(k1,ms,mp) = 0.0d0
        do 40  mp=-lx,lx+1
        do 40  ms=-1,1
        do 40  k1=1,8
  40      x3j(k1,ms,mp) = 0.0d0

        do 70  k1 = 1,8
        do 70  mp = -jind(k1)+1,jind(k1)
          do 50 ms=0,1
            j1 = 2 * lind(k1)
            j2 = 1
            j3 = 2 * jind(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)
            if (mod( (j2-j1-m1-m2)/2 , 2) .ne.0) 
     1          t3j(k1,ms,mp) = - t3j(k1,ms,mp)
c           t3j(m0,i)    are Clebsch-Gordon coefficients
  50      continue
          do 60 i=-1,1
            j1 = 2 * jind(k1) - 1
            j2 = 2
            if (k1.gt.3 .and. le2.eq.2) j2 = 4
            j3 = 2 * abs(kinit) - 1
            m1 = -2*mp + 1
            m2 = 2*i
            x3j(k1,i,mp)= cwig3j(j1,j2,j3,m1,m2,2)
  60      continue
  70    continue

c       calculate qmat
        do 220 i=1,8
        do 220 ms=0,1
        do 220 ml= -lind(i), lind(i)
        do 220 mj= -jind(i)+1, jind(i)
          mp = ml+ms
          jj = 2*jind(i) - 1
          mmj = 2*mj - 1
          mmp = 2*mp - 1
          value = rotwig(angks, jj, mmj, mmp, 2)
          qmat(mj,ml,ms,i) = value * t3j(i,ms,mp)
 220    continue

c       calculate pmat
        do 240 i2 = 1,8
        do 240 m2 = -jind(i2)+1, jind(i2)
        do 240 i1 = 1,8
        do 240 m1 = -jind(i1)+1, jind(i1)
          pmat(m1,i1,m2,i2) = 0
          if (abs(m2-m1).le.2) then
            do 230 j=-1,1
            do 230 i=-1,1
c             check that initial moment is the same
              if (m1-i.eq.m2-j) then
                is = 1
c               (-p) factors for M1 transitions
                if (le2.eq.1 .and. i.gt.0 .and. i1.gt.3) is = -is
                if (le2.eq.1 .and. j.gt.0 .and. i2.gt.3) is = -is
                pmat(m1,i1,m2,i2) = pmat(m1,i1,m2,i2) +
     1          is * x3j(i1,i,m1) * ptz(i,j) * x3j(i2,j,m2)
              endif
 230        continue
c           multiply by (-)^(j-j'+l2'+1) i**(l'-l) factor
c           additional (-) is from Eq.10 (-2*ck)
            is = 1
            if (mod(jind(i1)-jind(i2), 2) .ne.0) is = -is
            if (i2.le.3) is = -is
            pmat(m1,i1,m2,i2) = pmat(m1,i1,m2,i2) * is
     1           * coni**(lind(i2)-lind(i1))
          endif
 240    continue

c       calculate tmat = pmat*qmat
        do 270 i1=1,8
        do 270 ms=0,1
        do 270 ml=-lind(i1), lind(i1)
        do 270 i2=1,8
        do 270 mj=-jind(i2)+1, jind(i2)
          tmat(mj,i2, ml,ms,i1) = 0
          do 260 mp = -jind(i1)+1, jind(i1)
            tmat(mj,i2, ml,ms,i1) = tmat(mj,i2, ml,ms,i1)+
     1           pmat(mj,i2,mp,i1) * qmat(mp,ml,ms,i1)
 260      continue
 270    continue
         
c       calculate bmat = qmat^T * tmat
        do 300 i1=1,8
        do 300 ms1=0,1
        do 300 ml1=-lind(i1), lind(i1)
        do 300 i2=1,8
        do 300 ms2=0,1
        do 300 ml2=-lind(i2), lind(i2)
          bmat(ml2,ms2,i2, ml1,ms1,i1) = 0
          do 280 mj=-jind(i2)+1, jind(i2)
            bmat(ml2,ms2,i2, ml1,ms1,i1) = bmat(ml2,ms2,i2, ml1,ms1,i1)+
     1      qmat(mj,ml2,ms2,i2) * tmat(mj,i2,ml1,ms1,i1) 
 280      continue
 300    continue
c       end of ipol=1,2 cases
      endif 

      if (ltrace) then
c       need to trace bmat over ml for xsect.f
        do 390 i1 = 1, 8
        do 390 ms1 = 0,1
        do 390 i2 = 1, 8
        do 390 ms2 = 0,1
          if (lind(i1).ne.lind(i2) .or. ms1.ne.ms2) then
               bmat(0,ms2,i2, 0,ms1,i1) = 0
          else
             do 360 ml = 1, lind(i1)
               bmat(0,ms1,i2, 0,ms1,i1) =  bmat(0,ms1,i2, 0,ms1,i1) +
     1         bmat(-ml,ms1,i2, -ml,ms1,i1) + bmat(ml,ms1,i2, ml,ms1,i1)
 360         continue
          endif
 390    continue
      endif

      if (ispin .eq. 0) then
c       G(Ls,L's') is spin diagonal; trace over spin
        do 480 i1 = 1, 8
        do 480 i2 = 1, 8
        do 480 ml1 = -lind(i1), lind(i1)
        do 480 ml2 = -lind(i2), lind(i2)
           bmat(ml2,0,i2, ml1,0,i1) =   bmat(ml2,0,i2, ml1,0,i1) +
     1                                  bmat(ml2,1,i2, ml1,1,i1)
 480    continue
      elseif (ispin.eq.2 .or. (ispin.eq.1 .and. nspx.eq.1)) then
c       move spin up part into the position of spin-down
        do 490 i1 = 1, 8
        do 490 i2 = 1, 8
        do 490 ml1 = -lind(i1), lind(i1)
        do 490 ml2 = -lind(i2), lind(i2)
           bmat(ml2,0,i2, ml1,0,i1) =   bmat(ml2,1,i2, ml1,1,i1)
 490    continue

      endif

      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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      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.d0, xcut1 = 7.51d0, xcut2 = 5.01d0)

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

      lmaxp1 = ltot+2

      if (dble(x) .lt. xcut .and. abs(dimag(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 .and. abs(dimag(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 .and. abs(dimag(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 lxx = 3,lmaxp1
            lp1 = lmaxp1+1-lxx
            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 besjh (x, lbmax, jl, hl)

c-----------------------------------------------------------------------
c
c     purpose:  to calculate the spherical bessel functions jl and hl
c               for l = 0 to lbmax (no offset)
c
c     arguments:
c       x = argument of jl and nl
c       lbmax
c       jl = jl bessel function (abramowitz conventions)
c       hl = hl^+ bessel function (messiah conventions) for Im x >=0
c       hl = hl^- bessel function (messiah conventions) for Im x < 0
c       jl and hl must be dimensioned 
c            complex*16 jl(0:lbmax), hl(0:lbmax), 
c
c     notes:  jl and hl 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     rewritten for jl and hl by a.l. ankudinov feb 2000
c
c-----------------------------------------------------------------------

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      complex*16 x
      complex*16 jl(0:lbmax), nl(ltot+2)
      complex*16 hl(0:lbmax)
      complex*16 cjl(ltot+2), sjl(ltot+2)

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

      parameter (xcut = 1.d0, xcut1 = 7.51d0, xcut2 = 5.01d0)
      complex*16 coni
      parameter (coni=(0,1))

      if (dble(x) .lt. 0)  stop 'Re(x) is .lt. zero in besjh'

      lmax = min(lbmax, ltot+1)
      lmaxp1 = lmax + 1

      if (dble(x) .lt. xcut .and. abs(dimag(x)) .lt. xcut)  then
c        case Re(x) < 1, just use series expansion
         do 10 ll = 0,lmax
            ifl = 0
            call bjnser (x,ll,xjl,xnl,ifl)
            jl(ll) = xjl
            hl(ll) = -xnl + coni*xjl
   10    continue

      elseif (dble(x) .lt. xcut1 .and. abs(dimag(x)) .lt. xcut1)  then

c        case 1 <= Re(x) < 7.5

         call bjnser (x,lmax,xjl,xnl,1)
         jl(lmax) = xjl

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

         if (dble(x) .lt. xcut2 .and. abs(dimag(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 lxx = 3,lmaxp1
            lp1 = lmaxp1+1-lxx
            l = lp1-1
            tlxp3 = 2*l + 3
            jl(l) = tlxp3 * jl(l+1) / x  -  jl(l+2)
   60    continue

         do 65 il = 1, lmaxp1
            l = il - 1
            hl(l) = -nl(il) + coni*jl(l)
   65    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 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)
   90    continue
         asx = sin(x)
         acx = cos(x)
         if (dimag(x).ge. 0.d0) then
           epx = exp(coni*x)
         else 
           epx = exp(-coni*x)
         endif
         do 110 ll = 0,lmax
            lp1 = ll + 1
            jl(ll) = asx*sjl(lp1)+acx*cjl(lp1)
            if (dimag(x).ge. 0.d0) then
              hl(ll) = (sjl(lp1)+coni*cjl(lp1)) * epx
            else
              hl(ll) = (sjl(lp1)-coni*cjl(lp1)) * epx
            endif
  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 = 160, tol = 1.e-15)

      if (l .lt. 0) then
         call wlog(' l .lt. 0 in bjnser')
         stop 'bjnser 1'
      endif
      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 conv(omega,xsec,ne1,vicorr)
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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension  omega(nex)
      complex*16 xsec(nex), xsec0(nex), xsecdx

      complex*16 conv1
      external conv1

      do 100 ie = 1,ne1
         xsec0(ie) = 0.0d0
         omega0 = omega(ie)
c        Add one more point to correct for the finite grid
c        at large energies. Use linear interpolation.
         dx = max( omega(ne1) - omega(ne1-1), 50*vicorr)
         xlast = omega(ne1)+dx
         dx = dx / ( omega(ne1) - omega(ne1-1))
         xsecdx = xsec(ne1)+ (xsec(ne1)-xsec(ne1-1)) * dx

c        first interval
         do 50  i = 1, ne1-1
            xsec0(ie) = xsec0(ie) +
     1      conv1(omega(i),omega(i+1),xsec(i),xsec(i+1),omega0,vicorr)
  50     continue
c        last interval
         xsec0(ie) = xsec0(ie) +
     1   conv1(omega(ne1),xlast,xsec(ne1),xsecdx,omega0,vicorr)
         xsec0(ie) = xsec0(ie) /real(pi)
  100 continue
      do 200 ie = 1, ne1
  200 xsec(ie) = xsec0(ie)

      return
      end

      complex*16 function conv1(x1,x2,y1,y2,x0,xloss)
c     convolution of function 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  y1, y2, t, coni,dum, a, b
      parameter (coni = (0.0,1.0))

      d = (x2-x1) / 2.0
      a = dble(y2-y1) / 2.0
      b = dble(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)

      d = (x2-x1) / 2.0
      a = dimag(y2-y1) / 2.0
      b = dimag(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 = conv1 + coni* 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
      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 csomm2 (dr,dp,dpas,da,rnrm,np)
c Modified to use complex p and q.  SIZ 4/91
c Modified to use double simpson integration ALA 3/97
c integration by the method of simpson of dp*dr from 
c 0 to r=rnrm  with proper end corrections
c dpas=exponential step;
c for r in the neighborhood of zero dp=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      complex*16  dp(*),da,dc

      d1=dble(da)+1
      da=0.0
      db=0.0
c      np-2=inrm -point of grid just below rnrm
      a1=log(rnrm/dr(np-2)) / dpas
      a2=a1**2/8.0d0
      a3=a1**3/12.0d0
      do 70 i=1,np
         if (i.eq.1) then
            dc=dp(i) *dr(i)*9.0d0/24.0d0
         elseif (i.eq.2) then
            dc=dp(i) *dr(i)*28.0d0/24.0d0
         elseif (i.eq.3) then
            dc=dp(i)*dr(i)*23.0d0/24.0d0
         elseif (i.eq.np-3) then
            dc=dp(i)*dr(i)*(25.0d0/24.0d0-a2+a3)
         elseif (i.eq.np-2) then
            dc=dp(i)*dr(i)*(0.5d0+a1-3*a2-a3)
         elseif (i.eq.np-1) then
            dc=dp(i)*dr(i)*(-1.0d0/24.0d0+5*a2-a3)
         elseif (i.eq.np) then
            dc=dp(i)*dr(i)*(-a2+a3)
         else
c           like trapesoidal rule
            dc=dp(i)*dr(i)
         endif
         da=da+dc
   70 continue
      da=dpas*da

c     add initial point (r=0) correction
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=dr(1)/db
      dd=(dr(1))*(1.0+1.0/(dd*(d1+1.0)))/d1
      da=da+dd*dp(1)-db*dp(2)
      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 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
      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
      double precision function rotwig (beta, jj, m1, m2, ient)
c     uses Wigner formula (Messiah eq.C.72) to calculate rotation matrix
c     for integers  (ient=1)  or semiintegers (ient=2)
c     other arguments (except beta) should be multiplied by ient
 
      implicit double precision (a-h,o-z)
      parameter (idim = 58)
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

      if (((ient-1)*(ient-2)).ne.0) stop ' Illegal ient in rotwig.'

      if (ini.eq.1) then
c       initialisation of the log's of the factorials
        ini=0
        al(1)=0.0d 00
        do 11 i=1,idim
           b=i
 11        al(i+1)=al(i)+ log(b)
      endif
      rotwig = 0.d0

      if ( m1.ge.0 .and. abs(m1).ge.abs(m2)) then
         m1p = m1 
         m2p = m2
         betap = beta
         isign = 1
      elseif (m2.ge.0 .and. abs(m2).ge.abs(m1)) then
         m1p = m2
         m2p = m1
         betap = - beta
         isign = 1
      elseif (m1.le.0 .and. abs(m1).ge.abs(m2)) then
         m1p = - m1
         m2p = - m2
         betap = beta
         isign = (-1)**( (m1-m2)/ient ) 
      else
         m1p = - m2
         m2p = - m1
         betap = - beta
         isign = (-1)**( (m2-m1)/ient ) 
      endif

      temp = 0.d0
      zeta = cos ( betap / 2.d0 )
      eta  = sin ( betap / 2.d0 )
      do 100 it = m1p - m2p, jj - m2p, ient
        m(1) = 1 + (jj+m1p) / ient
        m(2) = 1 + (jj-m1p) / ient
        m(3) = 1 + (jj+m2p) / ient
        m(4) = 1 + (jj-m2p) / ient
        m(5) = 1 + (jj+m1p-it) / ient
        m(6) = 1 + (jj-m2p-it) / ient
        m(7) = 1 + it / ient
        m(8) = 1 + (m2p-m1p+it) / ient
        m(9)  = (2*jj+m1p-m2p-2*it) / ient 
        m(10) = (2*it-m1p+m2p) / ient 
        factor = 0.d0
        do 110 i = 1,4
  110     factor = factor + al(m(i))/2.d0 - al(m(i+4))
c       special cases to resolve 0.d0**0 problem (a.ankudinov, may 2001)
        if (m(10).eq.0 .and. m(9).eq.0) then
          temp = temp + (-1)**(it/ient)*exp(factor)
        elseif (m(10).eq.0) then
          temp = temp + (-1)**(it/ient)*zeta**m(9)*exp(factor)
        elseif (m(9).eq.0) then
          temp = temp + (-1)**(it/ient)*eta**m(10)*exp(factor)
        else
c         general expression
          temp = temp+ (-1)**(it/ient)*zeta**m(9)*eta**m(10)*exp(factor)
        endif
  100 continue

      rotwig = isign * temp
     
      return
      end
      subroutine phamp (rmt, pu, qu, ck, jl, nl, jlp, nlp, ikap,
     1                  ph, amp)
c     calculate phase shift at mt radius
c     needs to calculate atan of complex variable (coded below)
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      external besjn, atan2c

      complex*16 pu, qu, ck,  jl, nl, jlp, nlp, ph, amp
      complex*16 xkr, a, b, factor

c     initialize staff
      xkr = ck*rmt
      isign=1
      if (ikap.lt.0) isign = -1
      a = ck*alphfs
      factor = isign*a/(1+sqrt(1+a**2))

c     find a and b that pu = rmt*(a*jl+b*nl), qu=factor*rmt*(a*jlp+b*nlp)
      a = isign*ck*xkr* (pu*nlp - qu*nl/factor)
      b = isign*ck*xkr* (qu*jl/factor - pu*jlp)

c     pu =  amp * rmt * (jl*cos(ph) - nl*sin(ph))
c     qu =  amp * rmt * (jlp*cos(ph) - nlp*sin(ph)) * factor
c     tan(ph) = - b/a
      b = -b
      call atan2c ( a, b, amp, ph)

      return
      end
      subroutine atancc(temp, phx)
c     phx=atan(temp), for complex numbers
      implicit double precision (a-h, o-z)
      complex*16 temp, phx

      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) / (xx**2 + (yy-1)**2)
      beta = log(beta) / 4
      phx = dcmplx (alph, beta)

      return
      end

      subroutine atan2c(a, b, ampl, phx)
c     for complex a, b find complex ampl, phx such that:
c     a= ampl*cos(phx)  and  b= ampl*sin(phx)
c     phx=atan(b/a)
      implicit double precision (a-h, o-z)
      parameter (pi = 3.14159 26535 89793 23846 26433d0)
      complex*16 a, b, ampl, phx, temp

      aa = abs(a)
      bb = abs(b)
      if (aa+bb.eq. 0) then
         ampl=0.d0
         phx =0.d0
      elseif ( aa.gt.bb) then
         temp = b/a
         call atancc ( temp, phx)
         ampl = a / cos(phx)
      else
         temp = a/b
         call atancc ( temp, phx)
         phx = pi / 2 - phx
         ampl = b/sin(phx)
      endif

      if (dble(ampl).lt. 0.d0) then
         ampl = -ampl
         phx = phx + pi
      endif

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

c     purpose:  to calculate the spherical bessel functions jl and nl
c               for l = 0 to 6  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

         elseif (l .eq. 6)  then
            jl = ( 10395/z**7 - 4725/z**5 + 210/z**3 - 1/z )*sinz + 
     1              ( -10395/z**6 + 1155/z**4 - 21/z**2 )*cosz
            nl = (-10395/z**7 + 4725/z**5 - 210/z**3 + 1/z )*cosz + 
     1              ( -10395/z**6 + 1155/z**4 - 21/z**2 )*sinz

         else
            stop 'exjlnl, l out of range'
         endif
      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     adapted  from numerical recipies in fortran by Press et al.

      implicit double precision (a-h,o-z)
      integer n, nmax
      parameter (nmax=4)
      dimension xa(nmax), ya(nmax), c(nmax), d (nmax)

      ns = 1
      dif = abs (x-xa(1))
      do 10 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)
  10  continue
      y = ya(ns)
      ns = ns-1
      do 30 m=1,n-1
         do 20 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
  20     continue
         if (2*ns .lt. n-m) then
            dy = c(ns+1)
         else
            dy = d(ns)
            ns = ns-1
         endif
         y = y + dy
  30  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 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 somm2 (dr,dp,dpas,da,rnrm,m,np)
c Modified to use complex p and q.  SIZ 4/91
c Modified to use double simpson integration ALA 3/97
c integration by the method of simpson of dp*dr from 
c 0 to r=rnrm  with proper end corrections
c dpas=exponential step;
c for r in the neighborhood of zero dp=cte*r**da
c **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      dimension  dp(*)

      mm = m + 1
      d1=dble(da)+mm
      da=0.0
      db=0.0
c      np-2=inrm -point of grid just below rnrm
      a1=log(rnrm/dr(np-2)) / dpas
      a2=a1**2/8.0d0
      a3=a1**3/12.0d0
      do 70 i=1,np
         if (i.eq.1) then
            dc=dp(i) *dr(i)**mm*9.0d0/24.0d0
         elseif (i.eq.2) then
            dc=dp(i) *dr(i)**mm*28.0d0/24.0d0
         elseif (i.eq.3) then
            dc=dp(i)*dr(i)**mm*23.0d0/24.0d0
         elseif (i.eq.np-3) then
            dc=dp(i)*dr(i)**mm*(25.0d0/24.0d0-a2+a3)
         elseif (i.eq.np-2) then
            dc=dp(i)*dr(i)**mm*(0.5d0+a1-3*a2-a3)
         elseif (i.eq.np-1) then
            dc=dp(i)*dr(i)**mm*(-1.0d0/24.0d0+5*a2-a3)
         elseif (i.eq.np) then
            dc=dp(i)*dr(i)**mm*(-a2+a3)
         else
c           like trapesoidal rule
            dc=dp(i)*dr(i)**mm
         endif
         da=da+dc
   70 continue
      da=dpas*da

c     add initial point (r=0) correction
      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)-db*dp(2)
      return
      end
      subroutine strap (x, y, n, sum)

c     Trapeziodal integration of y(x), result in sum
c     SINGLE PRECISION
c     modified by ala to handle cases for E<Efermi
c     sum only positive numbers

      dimension x(n), y(n)

      sum = y(1) * abs(x(2) - x(1))
      do 10  i = 2, n-1
         sum = sum + y(i) * abs(x(i+1) - x(i-1))
   10 continue
      sum = sum + y(n) * abs(x(n) - x(n-1))
      sum = sum/2

      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)
      integer  u, m, n
      double precision x, xx(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


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)
      integer  u, m, n
      double precision x
      real xx(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
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, dy
      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     adapted  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(nmax), ya(nmax), c(nmax), d (nmax)

      ns = 1
      dif = abs (x-xa(1))
      do 10 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)
  10  continue
      y = ya(ns)
      ns = ns-1
      do 30 m=1,n-1
         do 20 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) stop 'failure in polint'
            den = w/den
            d(i) = hp*den
            c(i) = ho*den
  20     continue
         if (2*ns .lt. n-m) then
            dy = c(ns+1)
         else
            dy = d(ns)
            ns = ns-1
         endif
         y = y + dy
  30  continue

      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 CQdrtc(Coef,Sol,NSol)
c     Combutes the zeros of a quadratic polynomial
ccccccccccccccccccccccccccccccccccccccccccccccccc            
c     Input
c     Coef - array of coefficients
      COMPLEX*16 Coef(3)
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output
c     Sol  - Array of solutions
c     NSol - # of solutions (only one if Coef(1) = 0 etc.)
c     NSol = -1 means a and b are zero
      COMPLEX*16 Sol(2)
      INTEGER NSol
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables
      COMPLEX*16 q, Sqrt
      DOUBLE PRECISION Sgn

      IF(Coef(1).eq.0.d0) THEN
         IF(Coef(2).eq.0.d0) THEN
            NSol = -1
            RETURN
         ELSE
            NSol = 1
            Sol(1) = -Coef(3)/Coef(2)
         END IF
      ELSE
         NSol = 2
         Root = Sqrt(Coef(2)**2-4.d0*Coef(1)*Coef(3))
         Sgn  = SIGN(DBLE(CONJG(Coef(2))*Root),1.d0)
         q    = -0.5d0*(Coef(2) + Sgn*Root)
         
         Sol(1) = q/Coef(1)
         Sol(2) = Coef(3)/q
      END IF

      RETURN
      END


      SUBROUTINE CCubic(Coef,Sol,NSol)
c     Combutes the zeros of a cubic polynomial
ccccccccccccccccccccccccccccccccccccccccccccccccc            
c     Input
c     Coef - array of coefficients
      COMPLEX*16 Coef(4)
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output
c     Sol  - Array of solutions
c     NSol - # of solutions (only one if Coef(1) = 0 etc.)
c     NSol = -1 means a, b, and c are zero
      COMPLEX*16 Sol(4)
      INTEGER NSol
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables
      COMPLEX*16 P1, P2, Q, R, Coef2(3), a, b, c
      DOUBLE PRECISION Sgn, Theta
c     PARAMETERS
      COMPLEX*16 I
      PARAMETER(I = (0.d0, 1.d0))
      DOUBLE PRECISION Pi
      PARAMETER(Pi = 3.141592653589793238462643d0)

      IF(Coef(1).eq.0.d0) THEN
         Coef2(1) = Coef(2)
         Coef2(2) = Coef(3)
         Coef2(3) = Coef(4)         
         CALL CQdrtc(Coef2,Sol,NSol)
      ELSE
         a = Coef(2)/Coef(1)
         b = Coef(3)/Coef(1)
         c = Coef(4)/Coef(1)
         NSol = 3
         Q = (a**2 - 3.d0*b)/9.d0
         R = (2.d0*a**3 - 9.d0*a*b + 27.d0*c)/54.d0

         IF(((DIMAG(Q).eq.0.d0).and.(DIMAG(R).eq.0.d0)).and.
     &        (DIMAG(R**2).lt.DIMAG(Q**3))) THEN
            Theta = ACOS (DBLE(R/SQRT(Q**3)))
            Sol(1) = -2*SQRT(Q)*Cos(Theta/3.d0) - a/3.d0
            Sol(2) = -2*SQRT(Q)*Cos((Theta+2.d0*Pi)/3.d0) - a/3.d0
            Sol(3) = -2*SQRT(Q)*Cos((Theta-2.d0*Pi)/3.d0) - a/3.d0
         ELSE
            Sgn = SIGN(1.d0, DBLE(CONJG(R)*SQRT(R**2-Q**3)))
            P1 = -(R + Sgn*SQRT(R**2-Q**3))**(1.d0/3.d0)
            IF(P1.eq.0.d0) THEN
               P2 = 0.d0
            ELSE
               P2 = Q/P1
            END IF
            Sol(1) = (P1 + P2) - a/3.d0
            Sol(2) = -0.5d0*(P1 + P2) - a/3.d0 +
     &           I*SQRT(3.d0)/2.d0*(P1-P2)
            Sol(3) = -0.5d0*(P1 + P2) - a/3.d0 -
     &           I*SQRT(3.d0)/2.d0*(P1-P2)
         END IF
      END IF

      RETURN
      END
      
      subroutine cgetrf( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The
!                factorization has been completed, but the factor U
!                is exactly singular, and division by zero will occur
!                if it is used to solve a system of equations.
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           CGEMM, CGETF2, CLASWP, CTRSM, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'CGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL CGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL CGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )                            &
     &         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL CLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,     &
     &                      IPIV, 1 )
!
!              Compute block row of U.
!
             CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,   &
     &                   N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),   &
     &                     LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                CALL CGEMM( 'No transpose', 'No transpose', M-J-JB+1,   &
     &                       N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,     &
     &                       A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),   &
     &                       LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of CGETRF
!
      END

      SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is
!               used to solve a system of equations.
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE, ZERO
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),                    &
     &                   ZERO = ( 0.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            ICAMAX
      EXTERNAL           ICAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           CGERU, CSCAL, CSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + ICAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J )                                               &
     &         CALL CSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M )                                                &
     &         CALL CSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL CGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),    &
     &                  LDA, A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of CGETF2
!
      END
      SUBROUTINE cgetrs( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  CGETRS solves a system of linear equations
!     A * X = B,  A**T * X = B,  or  A**H * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by CGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) COMPLEX array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by CGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from CGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           CLASWP, CTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.        &
     &    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 )                                       &
     &   RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,  &
     &               ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,    &
     &               NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A**T * X = B  or A**H * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,  &
     &               A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,   &
     &               LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of CGETRS
!
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
!     ..
!
!  Purpose
!  =======
!
!  XERBLA  is an error handler for the LAPACK routines.
!  It is called by an LAPACK routine if an input parameter has an
!  invalid value.  A message is printed and execution stops.
!
!  Installers may consider modifying the STOP statement in order to
!  call system-specific exception-handling facilities.
!
!  Arguments
!  =========
!
!  SRNAME  (input) CHARACTER*6
!          The name of the routine which called XERBLA.
!
!  INFO    (input) INTEGER
!          The position of the invalid parameter in the parameter list
!          of the calling routine.
!
! ==================================================================
!
!     .. Executable Statements ..
!
      WRITE( *, FMT = 9999 )SRNAME, INFO
!
      STOP
!
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ',I2,' had ',  &
     &      'an illegal value' )
!
!     End of XERBLA
!
      END
      subroutine  cswap (n,cx,incx,cy,incy)
!
!     interchanges two vectors.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*),cy(*),ctemp
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        ctemp = cx(ix)
        cx(ix) = cy(iy)
        cy(iy) = ctemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
   20 do 30 i = 1,n
        ctemp = cx(i)
        cx(i) = cy(i)
        cy(i) = ctemp
   30 continue
      return
      end
      subroutine  cscal(n,ca,cx,incx)
!
!     scales a vector by a constant.
!     jack dongarra, linpack,  3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex ca,cx(*)
      integer i,incx,n,nincx
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      nincx = n*incx
      do 10 i = 1,nincx,incx
        cx(i) = ca*cx(i)
   10 continue
      return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
        cx(i) = ca*cx(i)
   30 continue
      return
      end
      SUBROUTINE CGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      COMPLEX            ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  CGERU  performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n
!  element vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the
!           matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - COMPLEX          array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - COMPLEX          array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - COMPLEX          array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as
!           declared in the calling (sub) program. LDA must be
!           at least max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     .. Local Scalars ..
      COMPLEX            TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGERU ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )               &
     &   RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of CGERU .
!
      END
      SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through
!  K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in
!          positions K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
! ==================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IP, IX
!     ..
!     .. External Subroutines ..
      EXTERNAL           CSWAP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1
!     through K2.
!
      IF( INCX.EQ.0 )                                                   &
     &   RETURN
      IF( INCX.GT.0 ) THEN
         IX = K1
      ELSE
         IX = 1 + ( 1-K2 )*INCX
      END IF
      IF( INCX.EQ.1 ) THEN
         DO 10 I = K1, K2
            IP = IPIV( I )
            IF( IP.NE.I )                                               &
     &         CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
   10    CONTINUE
      ELSE IF( INCX.GT.1 ) THEN
         DO 20 I = K1, K2
            IP = IPIV( IX )
            IF( IP.NE.I )                                               &
     &         CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   20    CONTINUE
      ELSE IF( INCX.LT.0 ) THEN
         DO 30 I = K2, K1, -1
            IP = IPIV( IX )
            IF( IP.NE.I )                                               &
     &         CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   30    CONTINUE
      END IF
!
      RETURN
!
!     End of CLASWP
!
      END
      SUBROUTINE CTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,A,LDA,   &
     &                   B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      COMPLEX            ALPHA
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  CTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit,
!  or non-unit,  upper or lower triangular matrix  and  op( A )  is
!  one of
!
!     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the
!           left or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper
!           or lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used
!           in the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must
!           be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N
!           must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry,  ALPHA specifies the scalar  alpha. When alpha
!           is zero then  A is not referenced and  B need not be set
!           before entry.
!           Unchanged on exit.
!

!  A - COMPLEX array of DIMENSION ( LDA, k ), where k is m
!           when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
!           Before entry with UPLO = 'U' or 'u', the leading k by k
!           upper triangular part of the array A must contain the
!           upper triangular matrix and the strictly lower triangular
!           part of A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k
!           by k lower triangular part of the array  A must contain
!           the lower triangular matrix  and the strictly upper
!           triangular part of A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements
!           of A  are not referenced either,  but are assumed to be
!           unity.  Unchanged on exit.

!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as
!           declared in the calling (sub) program.  When
!           SIDE = 'L' or 'l'  then LDA  must be at least
!           max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - COMPLEX          array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array
!           B must contain  the  right-hand  side  matrix  B,  and
!           on exit  is overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as
!           declared in  the  calling  (sub)  program.   LDB  must
!           be  at  least max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOCONJ, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      COMPLEX            TEMP
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOCONJ = LSAME( TRANSA, 'T' )
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.                       &
     &         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.                       &
     &         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.                       &
     &         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B
!           or    B := alpha*inv( conjg( A' ) )*B.
!
            IF( UPPER )THEN
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 110, K = 1, I - 1
                           TEMP = TEMP - A( K, I )*B( K, J )
  110                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 120, K = 1, I - 1
                           TEMP = TEMP - CONJG( A( K, I ) )*B( K, J )
  120                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/CONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  130             CONTINUE
  140          CONTINUE
            ELSE
               DO 180, J = 1, N
                  DO 170, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 150, K = I + 1, M
                           TEMP = TEMP - A( K, I )*B( K, J )
  150                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 160, K = I + 1, M
                           TEMP = TEMP - CONJG( A( K, I ) )*B( K, J )
  160                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/CONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  170             CONTINUE
  180          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 230, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 190, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  190                CONTINUE
                  END IF
                  DO 210, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 220, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  220                CONTINUE
                  END IF
  230          CONTINUE
            ELSE
               DO 280, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 240, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  240                CONTINUE
                  END IF
                  DO 260, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 250, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  250                   CONTINUE
                     END IF
  260             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 270, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  270                CONTINUE
                  END IF
  280          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' )
!           or    B := alpha*B*inv( conjg( A' ) ).
!
            IF( UPPER )THEN
               DO 330, K = N, 1, -1
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/CONJG( A( K, K ) )
                     END IF
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
                  DO 310, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = CONJG( A( J, K ) )
                        END IF
                        DO 300, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  300                   CONTINUE
                     END IF
  310             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 320, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  320                CONTINUE
                  END IF
  330          CONTINUE
            ELSE
               DO 380, K = 1, N
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/CONJG( A( K, K ) )
                     END IF
                     DO 340, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  340                CONTINUE
                  END IF
                  DO 360, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = CONJG( A( J, K ) )
                        END IF
                        DO 350, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  350                   CONTINUE
                     END IF
  360             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 370, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  370                CONTINUE
                  END IF
  380          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of CTRSM .
!
      END
      SUBROUTINE CGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA,B,LDB,  &
     &                   BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      COMPLEX            ALPHA, BETA
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  CGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X'   or   op( X ) = conjg( X' ),
!
!  alpha and beta are scalars, and A, B and C are matrices,
!  with op( A ) an m by k matrix,  op( B )  a  k by n matrix and
!  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be
!           used in the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be
!           used in the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = conjg( B' ).
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the
!           matrix op( A )  and of the  matrix  C.  M  must  be at
!           least  zero. Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the
!           matrix op( B ) and the number of columns of the matrix C.
!           N must be at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the
!           matrix op( A ) and the number of rows of the matrix
!           op( B ). K must be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A   - COMPLEX          array of DIMENSION ( LDA, ka ), where ka is
!        k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!        Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!        part of the array  A  must contain the matrix  A,  otherwise
!        the leading  k by m  part of the array  A  must contain  the
!        matrix A.
!        Unchanged on exit.
!
!  LDA - INTEGER.
!        On entry, LDA specifies the first dimension of A as declared
!        in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!        LDA must be at least  max( 1, m ), otherwise  LDA must be at
!        least  max( 1, k ).
!        Unchanged on exit.
!
!  B   - COMPLEX          array of DIMENSION ( LDB, kb ), where kb is
!        n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!        Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!        part of the array  B  must contain the matrix  B,  otherwise
!        the leading  n by k  part of the array  B  must contain  the
!        matrix B.
!        Unchanged on exit.
!
!  LDB - INTEGER.
!        On entry, LDB specifies the first dimension of B as declared
!        in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!        LDB must be at least  max( 1, k ), otherwise  LDB must be at
!        least  max( 1, n ).
!        Unchanged on exit.
!
!  BETA   - COMPLEX         .
!        On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!        supplied as zero then C need not be set on input.
!        Unchanged on exit.
!
!  C      - COMPLEX          array of DIMENSION ( LDC, n ).
!        Before entry, the leading  m by n  part of the array  C must
!        contain the matrix  C,  except when  beta  is zero, in which
!        case C need not be set on entry.
!        On exit, the array  C  is overwritten by the  m by n  matrix
!        ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!        On entry, LDC specifies the first dimension of C as declared
!        in  the  calling  (sub)  program.   LDC  must  be  at  least
!        max( 1, m ).
!        Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     .. Local Scalars ..
      LOGICAL            CONJA, CONJB, NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      COMPLEX            TEMP
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     ..
!     .. Executable Statements ..
!
!  Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!  conjugated or transposed, set  CONJA and CONJB  as true if  A  and
!  B  respectively are to be  transposed but  not conjugated  and set
!  NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
!  and the number of rows of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      CONJA = LSAME( TRANSA, 'C' )
      CONJB = LSAME( TRANSB, 'C' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.                       &
     &         ( .NOT.CONJA                ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.                       &
     &         ( .NOT.CONJB                ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE )))   &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE IF( CONJA )THEN
!
!           Form  C := alpha*conjg( A' )*B + beta*C.
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 150, J = 1, N
               DO 140, I = 1, M
                  TEMP = ZERO
                  DO 130, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  130             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  140          CONTINUE
  150       CONTINUE
         END IF
      ELSE IF( NOTA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*A*conjg( B' ) + beta*C.
!
            DO 200, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 160, I = 1, M
                     C( I, J ) = ZERO
  160             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 170, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  170             CONTINUE
               END IF
               DO 190, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*CONJG( B( J, L ) )
                     DO 180, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  180                CONTINUE
                  END IF
  190          CONTINUE
  200       CONTINUE
         ELSE
!
!           Form  C := alpha*A*B'          + beta*C
!
            DO 250, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 210, I = 1, M
                     C( I, J ) = ZERO
  210             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 220, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  220             CONTINUE
               END IF
               DO 240, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 230, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  230                CONTINUE
                  END IF
  240          CONTINUE
  250       CONTINUE
         END IF
      ELSE IF( CONJA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*conjg( A' )*conjg( B' ) + beta*C.
!
            DO 280, J = 1, N
               DO 270, I = 1, M
                  TEMP = ZERO
                  DO 260, L = 1, K
                  TEMP = TEMP + CONJG( A( L, I ) )*CONJG( B( J, L ) )
  260             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  270          CONTINUE
  280       CONTINUE
         ELSE
!
!           Form  C := alpha*conjg( A' )*B' + beta*C
!
            DO 310, J = 1, N
               DO 300, I = 1, M
                  TEMP = ZERO
                  DO 290, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*B( J, L )
  290             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  300          CONTINUE
  310       CONTINUE
         END IF
      ELSE
         IF( CONJB )THEN
!
!           Form  C := alpha*A'*conjg( B' ) + beta*C
!
            DO 340, J = 1, N
               DO 330, I = 1, M
                  TEMP = ZERO
                  DO 320, L = 1, K
                     TEMP = TEMP + A( L, I )*CONJG( B( J, L ) )
  320             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  330          CONTINUE
  340       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 370, J = 1, N
               DO 360, I = 1, M
                  TEMP = ZERO
                  DO 350, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  350             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  360          CONTINUE
  370       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of CGEMM .
!
      END

      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,  &
     &                 N4 )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
!     ..
!
!  Purpose
!  =======
!
!  ILAENV is called from the LAPACK routines to choose problem-
!  dependent parameters for the local environment.  See ISPEC for
!  a description of the parameters.
!
!  This version provides a set of parameters which should give good,
!  but not optimal, performance on many of the currently available
!  computers.  Users are encouraged to modify this subroutine to set
!  the tuning parameters for their particular machine using the option
!  and problem size information in the arguments.
!
!  This routine will not function correctly if it is converted to all
!  lower case.  Converting it to all upper case is allowed.
!
!  Arguments
!  =========
!
!  ISPEC   (input) INTEGER
!       Specifies the parameter to be returned as the value of
!       ILAENV.
!       = 1: the optimal blocksize; if this value is 1, an unblocked
!            algorithm will give the best performance.
!       = 2: the minimum block size for which the block routine
!            should be used; if the usable block size is less than
!            this value, an unblocked routine should be used.
!       = 3: the crossover point (in a block routine, for N less
!            than this value, an unblocked routine should be used)
!       = 4: the number of shifts, used in the nonsymmetric
!            eigenvalue routines
!       = 5: the minimum column dimension for blocking to be used;
!            rectangular blocks must have dimension at least k by m,
!            where k is given by ILAENV(2,...) and m by ILAENV(5,...)
!       = 6: the crossover point for the SVD (when reducing an m by n
!            matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
!            this value, a QR factorization is used first to reduce
!            the matrix to a triangular form.)
!       = 7: the number of processors
!       = 8: the crossover point for the multishift QR and QZ methods
!            for nonsymmetric eigenvalue problems.
!
!  NAME    (input) CHARACTER*(*)
!          The name of the calling subroutine, in either upper case or
!          lower case.
!
!  OPTS    (input) CHARACTER*(*)
!          The character options to the subroutine NAME, concatenated
!          into a single character string.  For example, UPLO = 'U',
!          TRANS = 'T', and DIAG = 'N' for a triangular routine would
!          be specified as OPTS = 'UTN'.
!
!  N1      (input) INTEGER
!  N2      (input) INTEGER
!  N3      (input) INTEGER
!  N4      (input) INTEGER
!          Problem dimensions for the subroutine NAME; these may not
!          all be required.
!
! (ILAENV) (output) INTEGER
!          >= 0: the value of the parameter specified by ISPEC
!          < 0:  if ILAENV = -k, the k-th argument had an illegal
!                value.
!
!  Further Details
!  ===============
!
!  The following conventions have been used when calling ILAENV from
!  the LAPACK routines:
!  1)  OPTS is a concatenation of all of the character options to
!      subroutine NAME, in the same order that they appear in the
!      argument list for NAME, even if they are not used in
!      determining the value of the parameter specified by ISPEC.
!  2)  The problem dimensions N1, N2, N3, N4 are specified in the
!      order that they appear in the argument list for NAME.  N1 is
!      used first, N2 second, and so on, and unused problem dimensions
!      are passed a value of -1.
!  3)  The parameter value returned by ILAENV is checked for validity
!      in the calling subroutine.  For example, ILAENV is used to
!      retrieve the optimal blocksize for STRTRI as follows:
!
!      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
!      IF( NB.LE.1 ) NB = MAX( 1, N )
!
!  ==================================================================
!
!     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
!     ..
!     .. Executable Statements ..
!
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
!
!     Invalid value for ISPEC
!
      ILAENV = -1
      RETURN
!
  100 CONTINUE
!
!     Convert NAME to upper case if the first character is lower case.
!
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
!
!        ASCII character set
!
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )                           &
     &            SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
!
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
!
!        EBCDIC character set
!
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.                         &
     &       ( IC.GE.145 .AND. IC.LE.153 ) .OR.                         &
     &       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.                   &
     &             ( IC.GE.145 .AND. IC.LE.153 ) .OR.                   &
     &             ( IC.GE.162 .AND. IC.LE.169 ) )                      &
     &            SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
!
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
!
!        Prime machines:  ASCII+128
!
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )                          &
     &            SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
!
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )                                   &
     &   RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
!
      GO TO ( 110, 200, 300 ) ISPEC
!
  110 CONTINUE
!
!     ISPEC = 1:  block size
!
!     In these examples, separate code is provided for setting NB for
!     real and complex.  We assume that NB will take the same value in
!     single or double precision.
!
      NB = 1
!
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.    &
     &            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
!
  200 CONTINUE
!
!     ISPEC = 2:  minimum block size
!
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.         &
     &       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
!
  300 CONTINUE
!
!     ISPEC = 3:  crossover point
!
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.         &
     &       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
!
  400 CONTINUE
!
!     ISPEC = 4:  number of shifts (used by xHSEQR)
!
      ILAENV = 6
      RETURN
!
  500 CONTINUE
!
!     ISPEC = 5:  minimum column dimension (not used)
!
      ILAENV = 2
      RETURN
!
  600 CONTINUE
!
!     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
!
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
!
  700 CONTINUE
!
!     ISPEC = 7:  number of processors (not used)
!
      ILAENV = 1
      RETURN
!
  800 CONTINUE
!
!     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
!
      ILAENV = 50
      RETURN
!
!     End of ILAENV
!
      END

      integer function icamax(n,cx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*)
      real smax
      integer i,incx,ix,n
      complex zdum
      real cabs1
      cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
!
      icamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      icamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      smax = cabs1(cx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(cabs1(cx(ix)).le.smax) go to 5
         icamax = i
         smax = cabs1(cx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 smax = cabs1(cx(1))
      do 30 i = 2,n
         if(cabs1(cx(i)).le.smax) go to 30
         icamax = i
         smax = cabs1(cx(i))
   30 continue
      return
      end

      LOGICAL          FUNCTION LSAME( CA, CB )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     January 31, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          CA, CB
!     ..
!
!  Purpose
!  =======
!
!  LSAME returns .TRUE. if CA is the same letter as CB regardless of
!  case.
!
!  Arguments
!  =========
!
!  CA      (input) CHARACTER*1
!  CB      (input) CHARACTER*1
!          CA and CB specify the single characters to be compared.
!
! ==================================================================
!
!     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
!     ..
!     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
!     ..
!     .. Executable Statements ..
!
!     Test if the characters are equal
!
      LSAME = CA.EQ.CB
      IF( LSAME )                                                       &
     &   RETURN
!
!     Now test for equivalence if both characters are alphabetic.
!
      ZCODE = ICHAR( 'Z' )
!
!     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
!     machines, on which ICHAR returns a value with bit 8 set.
!     ICHAR('A') on Prime machines returns 193 which is the same as
!     ICHAR('A') on an EBCDIC machine.
!
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
!
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
!
!        ASCII is assumed - ZCODE is the ASCII code of either lower or
!        upper case 'Z'.
!
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
!
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
!
!        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower
!        or upper case 'Z'.
!
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.                         &
     &       INTA.GE.145 .AND. INTA.LE.153 .OR.                         &
     &       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.                         &
     &       INTB.GE.145 .AND. INTB.LE.153 .OR.                         &
     &       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
!
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
!
!        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
!        plus 128 of either lower or upper case 'Z'.
!
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
!
!     RETURN
!
!     End of LSAME
!
      END
!       SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )
! *
! *  -- LAPACK routine (version 2.0) --
! *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
! *     Courant Institute, Argonne National Lab, and Rice University
! *     September 30, 1994
! *
! *     .. Scalar Arguments ..
!       CHARACTER          DIAG, UPLO
!       INTEGER            INFO, LDA, N
! *     ..
! *     .. Array Arguments ..
!       COMPLEX            A( LDA, * )
! *     ..
! *
! *  Purpose
! *  =======
! *
! *  CTRTRI computes the inverse of a complex upper or lower
! *  triangular matrix A.
! *
! *  This is the Level 3 BLAS version of the algorithm.
! *
! *  Arguments
! *  =========
! *
! *  UPLO    (input) CHARACTER*1
! *          = 'U':  A is upper triangular;
! *          = 'L':  A is lower triangular.
! *
! *  DIAG    (input) CHARACTER*1
! *          = 'N':  A is non-unit triangular;
! *          = 'U':  A is unit triangular.
! *
! *  N       (input) INTEGER
! *          The order of the matrix A.  N >= 0.
! *
! *  A       (input/output) COMPLEX array, dimension (LDA,N)
! *       On entry, the triangular matrix A.  If UPLO = 'U', the
! *       leading N-by-N upper triangular part of the array A
! *       contains the upper triangular matrix, and the strictly lower
! *       triangular part of A is not referenced.  If UPLO = 'L', the
! *       leading N-by-N lower triangular part of the array A contains
! *       the lower triangular matrix, and the strictly upper
! *       triangular part of A is not referenced.  If DIAG = 'U', the
! *       diagonal elements of A are also not referenced and are
! *       assumed to be 1.
! *       On exit, the (triangular) inverse of the original matrix, in
! *       the same storage format.
! *
! *  LDA     (input) INTEGER
! *          The leading dimension of the array A.  LDA >= max(1,N).
! *
! *  INFO    (output) INTEGER
! *       = 0: successful exit
! *       < 0: if INFO = -i, the i-th argument had an illegal value
! *       > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
! *            matrix is singular and its inverse can not be computed.
! *
! *  ================================================================
! *
! *     .. Parameters ..
!       COMPLEX            ONE, ZERO
!       PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
!      $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
! *     ..
! *     .. Local Scalars ..
!       LOGICAL            NOUNIT, UPPER
!       INTEGER            J, JB, NB, NN
! *     ..
! *     .. External Functions ..
!       LOGICAL            LSAME
!       INTEGER            ILAENV
!       EXTERNAL           LSAME, ILAENV
! *     ..
! *     .. External Subroutines ..
!       EXTERNAL           CTRMM, CTRSM, CTRTI2, XERBLA
! *     ..
! *     .. Intrinsic Functions ..
!       INTRINSIC          MAX, MIN
! *     ..
! *     .. Executable Statements ..
! *
! *     Test the input parameters.
! *
!       INFO = 0
!       UPPER = LSAME( UPLO, 'U' )
!       NOUNIT = LSAME( DIAG, 'N' )
!       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
!          INFO = -1
!       ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
!          INFO = -2
!       ELSE IF( N.LT.0 ) THEN
!          INFO = -3
!       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
!          INFO = -5
!       END IF
!       IF( INFO.NE.0 ) THEN
!          CALL XERBLA( 'CTRTRI', -INFO )
!          RETURN
!       END IF
! *
! *     Quick return if possible
! *
!       IF( N.EQ.0 )
!      $   RETURN
! *
! *     Check for singularity if non-unit.
! *
!       IF( NOUNIT ) THEN
!          DO 10 INFO = 1, N
!             IF( A( INFO, INFO ).EQ.ZERO )
!      $         RETURN
!    10    CONTINUE
!          INFO = 0
!       END IF
! *
! *     Determine the block size for this environment.
! *
!       NB = ILAENV( 1, 'CTRTRI', UPLO // DIAG, N, -1, -1, -1 )
!       IF( NB.LE.1 .OR. NB.GE.N ) THEN
! *
! *        Use unblocked code
! *
!          CALL CTRTI2( UPLO, DIAG, N, A, LDA, INFO )
!       ELSE
! *
! *        Use blocked code
! *
!          IF( UPPER ) THEN
! *
! *           Compute inverse of upper triangular matrix
! *
!             DO 20 J = 1, N, NB
!                JB = MIN( NB, N-J+1 )
! *
! *              Compute rows 1:j-1 of current block column
! *
!             CALL CTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
!      $                  JB, ONE, A, LDA, A( 1, J ), LDA )
!             CALL CTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
!      $                  JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
! *
! *              Compute inverse of current diagonal block
! *
!             CALL CTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
!    20       CONTINUE
!          ELSE
! *
! *           Compute inverse of lower triangular matrix
! *
!             NN = ( ( N-1 ) / NB )*NB + 1
!             DO 30 J = NN, 1, -NB
!                JB = MIN( NB, N-J+1 )
!                IF( J+JB.LE.N ) THEN
! *
! *                 Compute rows j+jb:n of current block column
! *
!                CALL CTRMM( 'Left', 'Lower', 'No transpose', DIAG,
!      $                     N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
!      $                     A( J+JB, J ), LDA )
!                CALL CTRSM( 'Right', 'Lower', 'No transpose', DIAG,
!      $                     N-J-JB+1, JB, -ONE, A( J, J ), LDA,
!      $                     A( J+JB, J ), LDA )
!                END IF
! *
! *              Compute inverse of current diagonal block
! *
!             CALL CTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
!    30       CONTINUE
!          END IF
!       END IF
! *
!       RETURN
! *
! *     End of CTRTRI
! *
!       END
      SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CTRTI2 computes the inverse of a complex upper or lower triangular
!  matrix.
!
!  This is the Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower
!          triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!       On entry, the triangular matrix A.  If UPLO = 'U', the
!       leading n by n upper triangular part of the array A contains
!       the upper triangular matrix, and the strictly lower
!       triangular part of A is not referenced.  If UPLO = 'L', the
!       leading n by n lower triangular part of the array A contains
!       the lower triangular matrix, and the strictly upper
!       triangular part of A is not referenced.  If DIAG = 'U', the
!       diagonal elements of A are also not referenced and are
!       assumed to be 1.
!
!       On exit, the (triangular) inverse of the original matrix, in
!       the same storage format.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      COMPLEX            AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           CSCAL, CTRMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTRTI2', -INFO )
         RETURN
      END IF
!
      IF( UPPER ) THEN
!
!        Compute inverse of upper triangular matrix.
!
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
!
!           Compute elements 1:j-1 of j-th column.
!
            CALL CTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,     &
     &                  A( 1, J ), 1 )
            CALL CSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
!
!        Compute inverse of lower triangular matrix.
!
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
!
!              Compute elements j+1:n of j-th column.
!
               CALL CTRMV( 'Lower', 'No transpose', DIAG, N-J,          &
     &                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL CSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of CTRTI2
!
      END
      SUBROUTINE CTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  CTRMV  performs one of the matrix-vector operations
!
!     x := A*x,   or   x := A'*x,   or   x := conjg( A' )*x,
!
!  where x is an n element vector and  A is an n by n unit, or
!  non-unit, upper or lower triangular matrix.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   x := A*x.
!
!              TRANS = 'T' or 't'   x := A'*x.
!
!              TRANS = 'C' or 'c'   x := conjg( A' )*x.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  A      - COMPLEX          array of DIMENSION ( LDA, n ).
!        Before entry with  UPLO = 'U' or 'u', the leading n by n
!        upper triangular part of the array A must contain the upper
!        triangular matrix and the strictly lower triangular part of
!        A is not referenced.
!        Before entry with UPLO = 'L' or 'l', the leading n by n
!        lower triangular part of the array A must contain the lower
!        triangular matrix and the strictly upper triangular part of
!        A is not referenced.
!        Note that when  DIAG = 'U' or 'u', the diagonal elements of
!        A are not referenced either, but are assumed to be unity.
!        Unchanged on exit.
!
!  LDA    - INTEGER.
!        On entry, LDA specifies the first dimension of A as declared
!        in the calling (sub) program. LDA must be at least
!        max( 1, n ).
!        Unchanged on exit.
!
!  X      - COMPLEX          array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x. On exit, X is overwritten with the
!           tranformed vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     .. Local Scalars ..
      COMPLEX            TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOCONJ, NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.                            &
     &         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'T' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.                            &
     &         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CTRMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
      NOCONJ = LSAME( TRANS, 'T' )
      NOUNIT = LSAME( DIAG , 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x := A*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*A( I, J )
   10                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( J ) = X( J )*A( J, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, I = 1, J - 1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*A( I, J )
   50                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( J ) = X( J )*A( J, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, I = N, J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := A'*x  or  x := conjg( A' )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 110, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 90, I = J - 1, 1, -1
                        TEMP = TEMP + A( I, J )*X( I )
   90                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 100, I = J - 1, 1, -1
                        TEMP = TEMP + CONJG( A( I, J ) )*X( I )
  100                CONTINUE
                  END IF
                  X( J ) = TEMP
  110          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 140, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 120, I = J - 1, 1, -1
                        IX   = IX   - INCX
                        TEMP = TEMP + A( I, J )*X( IX )
  120                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 130, I = J - 1, 1, -1
                        IX   = IX   - INCX
                        TEMP = TEMP + CONJG( A( I, J ) )*X( IX )
  130                CONTINUE
                  END IF
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  140          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 170, J = 1, N
                  TEMP = X( J )
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 150, I = J + 1, N
                        TEMP = TEMP + A( I, J )*X( I )
  150                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 160, I = J + 1, N
                        TEMP = TEMP + CONJG( A( I, J ) )*X( I )
  160                CONTINUE
                  END IF
                  X( J ) = TEMP
  170          CONTINUE
            ELSE
               JX = KX
               DO 200, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 180, I = J + 1, N
                        IX   = IX   + INCX
                        TEMP = TEMP + A( I, J )*X( IX )
  180                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 190, I = J + 1, N
                        IX   = IX   + INCX
                        TEMP = TEMP + CONJG( A( I, J ) )*X( IX )
  190                CONTINUE
                  END IF
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  200          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of CTRMV .
!
      END
      subroutine caxpy(n,ca,cx,incx,cy,incy)
!
!     constant times a vector plus a vector.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*),cy(*),ca
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if (abs(real(ca)) + abs(aimag(ca)) .eq. 0.0 ) return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        cy(iy) = cy(iy) + ca*cx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
        cy(i) = cy(i) + ca*cx(i)
   30 continue
      return
      end
      subroutine  ccopy(n,cx,incx,cy,incy)
!
!     copies a vector, x, to a vector, y.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*),cy(*)
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        cy(iy) = cx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
        cy(i) = cx(i)
   30 continue
      return
      end

      SUBROUTINE CGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,           &
     &                   BETA, Y, INCY )
!     .. Scalar Arguments ..
      COMPLEX            ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  CGEMV  performs one of the matrix-vector operations
!
!     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,   or
!
!     y := alpha*conjg( A' )*x + beta*y,
!
!  where alpha and beta are scalars, x and y are vectors and A is an
!  m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
!
!              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
!
!              TRANS = 'C' or 'c'   y := alpha*conjg( A' )*x + beta*y.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - COMPLEX          array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!  X      - COMPLEX          array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!           Before entry, the incremented array X must contain the
!           vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - COMPLEX         .
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - COMPLEX          array of DIMENSION at least
!           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!           Before entry with BETA non-zero, the incremented array Y
!           must contain the vector y. On exit, Y is overwritten by the
!           updated vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     .. Local Scalars ..
      COMPLEX            TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
      LOGICAL            NOCONJ
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'T' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGEMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )                   &
     &   RETURN
!
      NOCONJ = LSAME( TRANS, 'T' )
!
!     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
!     up the start points in  X  and  Y.
!
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )                                               &
     &   RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  y := alpha*A*x + y.
!
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y := alpha*A'*x + y  or  y := alpha*conjg( A' )*x + y.
!
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 110, J = 1, N
               TEMP = ZERO
               IF( NOCONJ )THEN
                  DO 90, I = 1, M
                     TEMP = TEMP + A( I, J )*X( I )
   90             CONTINUE
               ELSE
                  DO 100, I = 1, M
                     TEMP = TEMP + CONJG( A( I, J ) )*X( I )
  100             CONTINUE
               END IF
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  110       CONTINUE
         ELSE
            DO 140, J = 1, N
               TEMP = ZERO
               IX   = KX
               IF( NOCONJ )THEN
                  DO 120, I = 1, M
                     TEMP = TEMP + A( I, J )*X( IX )
                     IX   = IX   + INCX
  120             CONTINUE
               ELSE
                  DO 130, I = 1, M
                     TEMP = TEMP + CONJG( A( I, J ) )*X( IX )
                     IX   = IX   + INCX
  130             CONTINUE
               END IF
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  140       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of CGEMV .
!
      END
      double precision function dcabs1(z)
      double complex z,zz
      double precision t(2)
      equivalence (zz,t(1))
      zz = z
      dcabs1 = dabs(t(1)) + dabs(t(2))
      return
      end
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,&
     &                   BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X',
!
!  alpha and beta are scalars, and A, B and C are matrices, with op( A )
!  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = A'.
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = B'.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the  matrix
!           op( A )  and of the  matrix  C.  M  must  be at least  zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the matrix
!           op( B ) and the number of columns of the matrix C. N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the matrix
!           op( A ) and the number of rows of the matrix op( B ). K must
!           be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by m  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!           least  max( 1, k ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
!           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!           part of the array  B  must contain the matrix  B,  otherwise
!           the leading  n by k  part of the array  B  must contain  the
!           matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!           LDB must be at least  max( 1, k ), otherwise  LDB must be at
!           least  max( 1, n ).
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!           Unchanged on exit.
!
!  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
!           Before entry, the leading  m by n  part of the array  C must
!           contain the matrix  C,  except when  beta  is zero, in which
!           case C need not be set on entry.
!           On exit, the array  C  is overwritten by the  m by n  matrix
!           ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
!     and  columns of  A  and the  number of  rows  of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
     &   RETURN
!
!     And if  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B' + beta*C
!
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DGEMM .
!
      END
      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DGER   performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n element
!  vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )               &
     &   RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of DGER  .
!
      END
      subroutine  dscal(n,da,dx,incx)
!
!     scales a vector by a constant.
!     uses unrolled loops for increment equal to one.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      subroutine  dswap (n,dx,incx,dy,incy)
!
!     interchanges two vectors.
!     uses unrolled loops for increments equal one.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
!
!
!       clean-up loop
!
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, &
     &                   B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
!  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!
!     op( A ) = A   or   op( A ) = A'.
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the left
!           or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = A'.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit triangular
!           as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must be at
!           least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!           zero then  A is not referenced and  B need not be set before
!           entry.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
!           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
!           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
!           upper triangular part of the array  A must contain the upper
!           triangular matrix  and the strictly lower triangular part of
!           A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
!           lower triangular part of the array  A must contain the lower
!           triangular matrix  and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
!           A  are not referenced either,  but are assumed to be  unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array  B must
!           contain  the  right-hand  side  matrix  B,  and  on exit  is
!           overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.                       &
     &         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.                       &
     &         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.                       &
     &         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B.
!
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' ).
!
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTRSM .
!
      END
      integer function idamax(n,dx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dmax
      integer i,incx,ix,n
!
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      integer function izamax(n,zx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, 1/15/85.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*)
      double precision smax
      integer i,incx,ix,n
      double precision dcabs1
!
      izamax = 0
      if( n.lt.1 .or. incx.le.0 )return
      izamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      smax = dcabs1(zx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dcabs1(zx(ix)).le.smax) go to 5
         izamax = i
         smax = dcabs1(zx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 smax = dcabs1(zx(1))
      do 30 i = 2,n
         if(dcabs1(zx(i)).le.smax) go to 30
         izamax = i
         smax = dcabs1(zx(i))
   30 continue
      return
      end
      subroutine  zcopy(n,zx,incx,zy,incy)
!
!     copies a vector, x, to a vector, y.
!     jack dongarra, linpack, 4/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*),zy(*)
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        zy(iy) = zx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
        zy(i) = zx(i)
   30 continue
      return
      end
      SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,&
     &                   BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      COMPLEX*16         ALPHA, BETA
!     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X'   or   op( X ) = conjg( X' ),
!
!  alpha and beta are scalars, and A, B and C are matrices, with op( A )
!  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = conjg( B' ).
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the  matrix
!           op( A )  and of the  matrix  C.  M  must  be at least  zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the matrix
!           op( B ) and the number of columns of the matrix C. N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the matrix
!           op( A ) and the number of rows of the matrix op( B ). K must
!           be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX*16      .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - COMPLEX*16       array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by m  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!           least  max( 1, k ).
!           Unchanged on exit.
!
!  B      - COMPLEX*16       array of DIMENSION ( LDB, kb ), where kb is
!           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!           part of the array  B  must contain the matrix  B,  otherwise
!           the leading  n by k  part of the array  B  must contain  the
!           matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!           LDB must be at least  max( 1, k ), otherwise  LDB must be at
!           least  max( 1, n ).
!           Unchanged on exit.
!
!  BETA   - COMPLEX*16      .
!           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!           Unchanged on exit.
!
!  C      - COMPLEX*16       array of DIMENSION ( LDC, n ).
!           Before entry, the leading  m by n  part of the array  C must
!           contain the matrix  C,  except when  beta  is zero, in which
!           case C need not be set on entry.
!           On exit, the array  C  is overwritten by the  m by n  matrix
!           ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          DCONJG, MAX
!     .. Local Scalars ..
      LOGICAL            CONJA, CONJB, NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      COMPLEX*16         TEMP
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
      COMPLEX*16         ZERO
      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Executable Statements ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     conjugated or transposed, set  CONJA and CONJB  as true if  A  and
!     B  respectively are to be  transposed but  not conjugated  and set
!     NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
!     and the number of rows of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      CONJA = LSAME( TRANSA, 'C' )
      CONJB = LSAME( TRANSB, 'C' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.                       &
     &         ( .NOT.CONJA                ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.                       &
     &         ( .NOT.CONJB                ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE IF( CONJA )THEN
!
!           Form  C := alpha*conjg( A' )*B + beta*C.
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 150, J = 1, N
               DO 140, I = 1, M
                  TEMP = ZERO
                  DO 130, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  130             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  140          CONTINUE
  150       CONTINUE
         END IF
      ELSE IF( NOTA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*A*conjg( B' ) + beta*C.
!
            DO 200, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 160, I = 1, M
                     C( I, J ) = ZERO
  160             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 170, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  170             CONTINUE
               END IF
               DO 190, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*DCONJG( B( J, L ) )
                     DO 180, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  180                CONTINUE
                  END IF
  190          CONTINUE
  200       CONTINUE
         ELSE
!
!           Form  C := alpha*A*B'          + beta*C
!
            DO 250, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 210, I = 1, M
                     C( I, J ) = ZERO
  210             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 220, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  220             CONTINUE
               END IF
               DO 240, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 230, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  230                CONTINUE
                  END IF
  240          CONTINUE
  250       CONTINUE
         END IF
      ELSE IF( CONJA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*conjg( A' )*conjg( B' ) + beta*C.
!
            DO 280, J = 1, N
               DO 270, I = 1, M
                  TEMP = ZERO
                  DO 260, L = 1, K
                     TEMP = TEMP +                                      &
     &                      DCONJG( A( L, I ) )*DCONJG( B( J, L ) )
  260             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  270          CONTINUE
  280       CONTINUE
         ELSE
!
!           Form  C := alpha*conjg( A' )*B' + beta*C
!
            DO 310, J = 1, N
               DO 300, I = 1, M
                  TEMP = ZERO
                  DO 290, L = 1, K
                     TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L )
  290             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  300          CONTINUE
  310       CONTINUE
         END IF
      ELSE
         IF( CONJB )THEN
!
!           Form  C := alpha*A'*conjg( B' ) + beta*C
!
            DO 340, J = 1, N
               DO 330, I = 1, M
                  TEMP = ZERO
                  DO 320, L = 1, K
                     TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) )
  320             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  330          CONTINUE
  340       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 370, J = 1, N
               DO 360, I = 1, M
                  TEMP = ZERO
                  DO 350, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  350             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  360          CONTINUE
  370       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of ZGEMM .
!
      END
      SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      COMPLEX*16         ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  ZGERU  performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n element
!  vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX*16      .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - COMPLEX*16       array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - COMPLEX*16       array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX*16         ZERO
      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
!     .. Local Scalars ..
      COMPLEX*16         TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZGERU ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )               &
     &   RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of ZGERU .
!
      END
      subroutine  zscal(n,za,zx,incx)
!
!     scales a vector by a constant.
!     jack dongarra, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex za,zx(*)
      integer i,incx,ix,n
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      do 10 i = 1,n
        zx(ix) = za*zx(ix)
        ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
        zx(i) = za*zx(i)
   30 continue
      return
      end
      subroutine  zswap (n,zx,incx,zy,incy)
!
!     interchanges two vectors.
!     jack dongarra, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*),zy(*),ztemp
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        ztemp = zx(ix)
        zx(ix) = zy(iy)
        zy(iy) = ztemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
   20 do 30 i = 1,n
        ztemp = zx(i)
        zx(i) = zy(i)
        zy(i) = ztemp
   30 continue
      return
      end
      SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, &
     &                   B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      COMPLEX*16         ALPHA
!     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
!  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!
!     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the left
!           or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit triangular
!           as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must be at
!           least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX*16      .
!           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!           zero then  A is not referenced and  B need not be set before
!           entry.
!           Unchanged on exit.
!
!  A      - COMPLEX*16       array of DIMENSION ( LDA, k ), where k is m
!           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
!           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
!           upper triangular part of the array  A must contain the upper
!           triangular matrix  and the strictly lower triangular part of
!           A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
!           lower triangular part of the array  A must contain the lower
!           triangular matrix  and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
!           A  are not referenced either,  but are assumed to be  unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - COMPLEX*16       array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array  B must
!           contain  the  right-hand  side  matrix  B,  and  on exit  is
!           overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          DCONJG, MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOCONJ, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      COMPLEX*16         TEMP
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
      COMPLEX*16         ZERO
      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOCONJ = LSAME( TRANSA, 'T' )
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.                       &
     &         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.                       &
     &         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.                       &
     &         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B
!           or    B := alpha*inv( conjg( A' ) )*B.
!
            IF( UPPER )THEN
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 110, K = 1, I - 1
                           TEMP = TEMP - A( K, I )*B( K, J )
  110                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 120, K = 1, I - 1
                           TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
  120                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/DCONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  130             CONTINUE
  140          CONTINUE
            ELSE
               DO 180, J = 1, N
                  DO 170, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 150, K = I + 1, M
                           TEMP = TEMP - A( K, I )*B( K, J )
  150                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 160, K = I + 1, M
                           TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
  160                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/DCONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  170             CONTINUE
  180          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 230, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 190, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  190                CONTINUE
                  END IF
                  DO 210, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 220, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  220                CONTINUE
                  END IF
  230          CONTINUE
            ELSE
               DO 280, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 240, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  240                CONTINUE
                  END IF
                  DO 260, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 250, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  250                   CONTINUE
                     END IF
  260             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 270, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  270                CONTINUE
                  END IF
  280          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' )
!           or    B := alpha*B*inv( conjg( A' ) ).
!
            IF( UPPER )THEN
               DO 330, K = N, 1, -1
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/DCONJG( A( K, K ) )
                     END IF
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
                  DO 310, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = DCONJG( A( J, K ) )
                        END IF
                        DO 300, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  300                   CONTINUE
                     END IF
  310             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 320, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  320                CONTINUE
                  END IF
  330          CONTINUE
            ELSE
               DO 380, K = 1, N
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/DCONJG( A( K, K ) )
                     END IF
                     DO 340, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  340                CONTINUE
                  END IF
                  DO 360, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = DCONJG( A( J, K ) )
                        END IF
                        DO 350, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  350                   CONTINUE
                     END IF
  360             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 370, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  370                CONTINUE
                  END IF
  380          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of ZTRSM .
!
      END
      SUBROUTINE CLACON( N, V, X, EST, KASE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            KASE, N
      REAL               EST
!     ..
!     .. Array Arguments ..
      COMPLEX            V( N ), X( N )
!     ..
!
!  Purpose
!  =======
!
!  CLACON estimates the 1-norm of a square, complex matrix A.
!  Reverse communication is used for evaluating matrix-vector products.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The order of the matrix.  N >= 1.
!
!  V      (workspace) COMPLEX array, dimension (N)
!         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
!         (W is not returned).
!
!  X      (input/output) COMPLEX array, dimension (N)
!         On an intermediate return, X should be overwritten by
!               A * X,   if KASE=1,
!               A' * X,  if KASE=2,
!         where A' is the conjugate transpose of A, and CLACON must be
!         re-called with all the other parameters unchanged.
!
!  EST    (output) REAL
!         An estimate (a lower bound) for norm(A).
!
!  KASE   (input/output) INTEGER
!         On the initial call to CLACON, KASE should be 0.
!         On an intermediate return, KASE will be 1 or 2, indicating
!         whether X should be overwritten by A * X  or A' * X.
!         On the final return from CLACON, KASE will again be 0.
!
!  Further Details
!  ======= =======
!
!  Contributed by Nick Higham, University of Manchester.
!  Originally named CONEST, dated March 16, 1988.
!
!  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
!  a real or complex matrix, with applications to condition estimation",
!  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
!
!  Last modified:  April, 1999
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      REAL               ONE, TWO
      PARAMETER          ( ONE = 1.0E0, TWO = 2.0E0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),                    &
     &                   CONE = ( 1.0E0, 0.0E0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ITER, J, JLAST, JUMP
      REAL               ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
!     ..
!     .. External Functions ..
      INTEGER            ICMAX1
      REAL               SCSUM1, SLAMCH
      EXTERNAL           ICMAX1, SCSUM1, SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           CCOPY
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, REAL
!     ..
!     .. Save statement ..
      SAVE
!     ..
!     .. Executable Statements ..
!
      SAFMIN = SLAMCH( 'Safe minimum' )
      IF( KASE.EQ.0 ) THEN
         DO 10 I = 1, N
            X( I ) = CMPLX( ONE / REAL( N ) )
   10    CONTINUE
         KASE = 1
         JUMP = 1
         RETURN
      END IF
!
      GO TO ( 20, 40, 70, 90, 120 )JUMP
!
!     ................ ENTRY   (JUMP = 1)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
!
   20 CONTINUE
      IF( N.EQ.1 ) THEN
         V( 1 ) = X( 1 )
         EST = ABS( V( 1 ) )
!        ... QUIT
         GO TO 130
      END IF
      EST = SCSUM1( N, X, 1 )
!
      DO 30 I = 1, N
         ABSXI = ABS( X( I ) )
         IF( ABSXI.GT.SAFMIN ) THEN
            X( I ) = CMPLX( REAL( X( I ) ) / ABSXI,                     &
     &               AIMAG( X( I ) ) / ABSXI )
         ELSE
            X( I ) = CONE
         END IF
   30 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
!
!     ................ ENTRY   (JUMP = 2)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
!
   40 CONTINUE
      J = ICMAX1( N, X, 1 )
      ITER = 2
!
!     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
!
   50 CONTINUE
      DO 60 I = 1, N
         X( I ) = CZERO
   60 CONTINUE
      X( J ) = CONE
      KASE = 1
      JUMP = 3
      RETURN
!
!     ................ ENTRY   (JUMP = 3)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
   70 CONTINUE
      CALL CCOPY( N, X, 1, V, 1 )
      ESTOLD = EST
      EST = SCSUM1( N, V, 1 )
!
!     TEST FOR CYCLING.
      IF( EST.LE.ESTOLD )                                               &
     &   GO TO 100
!
      DO 80 I = 1, N
         ABSXI = ABS( X( I ) )
         IF( ABSXI.GT.SAFMIN ) THEN
            X( I ) = CMPLX( REAL( X( I ) ) / ABSXI,                     &
     &               AIMAG( X( I ) ) / ABSXI )
         ELSE
            X( I ) = CONE
         END IF
   80 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
!
!     ................ ENTRY   (JUMP = 4)
!     X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
!
   90 CONTINUE
      JLAST = J
      J = ICMAX1( N, X, 1 )
      IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND.                  &
     &    ( ITER.LT.ITMAX ) ) THEN
         ITER = ITER + 1
         GO TO 50
      END IF
!
!     ITERATION COMPLETE.  FINAL STAGE.
!
  100 CONTINUE
      ALTSGN = ONE
      DO 110 I = 1, N
         X( I ) = CMPLX( ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) )
         ALTSGN = -ALTSGN
  110 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
!
!     ................ ENTRY   (JUMP = 5)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
  120 CONTINUE
      TEMP = TWO*( SCSUM1( N, X, 1 ) / REAL( 3*N ) )
      IF( TEMP.GT.EST ) THEN
         CALL CCOPY( N, X, 1, V, 1 )
         EST = TEMP
      END IF
!
  130 CONTINUE
      KASE = 0
      RETURN
!
!     End of CLACON
!
      END
      SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
!  A using partial pivoting with row interchanges.
!
!  This is the unblocked version of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U, because of fill-in resulting from the row
!  interchanges.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),                    &
     &                   ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, JP, JU, KM, KV
!     ..
!     .. External Functions ..
      INTEGER            IZAMAX
      EXTERNAL           IZAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in.
!
      KV = KU + KL
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGBTF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Gaussian elimination with partial pivoting
!
!     Set fill-in elements in columns KU+2 to KV to zero.
!
      DO 20 J = KU + 2, MIN( KV, N )
         DO 10 I = KV - J + 2, KL
            AB( I, J ) = ZERO
   10    CONTINUE
   20 CONTINUE
!
!     JU is the index of the last column affected by the current stage
!     of the factorization.
!
      JU = 1
!
      DO 40 J = 1, MIN( M, N )
!
!        Set fill-in elements in column J+KV to zero.
!
         IF( J+KV.LE.N ) THEN
            DO 30 I = 1, KL
               AB( I, J+KV ) = ZERO
   30       CONTINUE
         END IF
!
!        Find pivot and test for singularity. KM is the number of
!        subdiagonal elements in the current column.
!
         KM = MIN( KL, M-J )
         JP = IZAMAX( KM+1, AB( KV+1, J ), 1 )
         IPIV( J ) = JP + J - 1
         IF( AB( KV+JP, J ).NE.ZERO ) THEN
            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
!
!           Apply interchange to columns J to JU.
!
            IF( JP.NE.1 )                                               &
     &         CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,              &
     &                     AB( KV+1, J ), LDAB-1 )
            IF( KM.GT.0 ) THEN
!
!              Compute multipliers.
!
               CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
!
!              Update trailing submatrix within the band.
!
               IF( JU.GT.J )                                            &
     &            CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1,         &
     &                        AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),   &
     &                        LDAB-1 )
            END IF
         ELSE
!
!           If pivot is zero, set INFO to the index of the pivot
!           unless a zero pivot has already been found.
!
            IF( INFO.EQ.0 )                                             &
     &         INFO = J
         END IF
   40 CONTINUE
      RETURN
!
!     End of ZGBTF2
!
      END
      SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
!  using partial pivoting with row interchanges.
!
!  This is the blocked version of the algorithm, calling Level 3 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U because of fill-in resulting from the row interchanges.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),                    &
     &                   ZERO = ( 0.0D+0, 0.0D+0 ) )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,  &
     &                   JU, K2, KM, KV, NB, NW
      COMPLEX*16         TEMP
!     ..
!     .. Local Arrays ..
      COMPLEX*16         WORK13( LDWORK, NBMAX ),                       &
     &                   WORK31( LDWORK, NBMAX )
!     ..
!     .. External Functions ..
      INTEGER            ILAENV, IZAMAX
      EXTERNAL           ILAENV, IZAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP,   &
     &                   ZSCAL, ZSWAP, ZTRSM
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in
!
      KV = KU + KL
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGBTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment
!
      NB = ILAENV( 1, 'ZGBTRF', ' ', M, N, KL, KU )
!
!     The block size must not exceed the limit set by the size of the
!     local arrays WORK13 and WORK31.
!
      NB = MIN( NB, NBMAX )
!
      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
!
!        Use unblocked code
!
         CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
      ELSE
!
!        Use blocked code
!
!        Zero the superdiagonal elements of the work array WORK13
!
         DO 20 J = 1, NB
            DO 10 I = 1, J - 1
               WORK13( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
!
!        Zero the subdiagonal elements of the work array WORK31
!
         DO 40 J = 1, NB
            DO 30 I = J + 1, NB
               WORK31( I, J ) = ZERO
   30       CONTINUE
   40    CONTINUE
!
!        Gaussian elimination with partial pivoting
!
!        Set fill-in elements in columns KU+2 to KV to zero
!
         DO 60 J = KU + 2, MIN( KV, N )
            DO 50 I = KV - J + 2, KL
               AB( I, J ) = ZERO
   50       CONTINUE
   60    CONTINUE
!
!        JU is the index of the last column affected by the current
!        stage of the factorization
!
         JU = 1
!
         DO 180 J = 1, MIN( M, N ), NB
            JB = MIN( NB, MIN( M, N )-J+1 )
!
!           The active part of the matrix is partitioned
!
!              A11   A12   A13
!              A21   A22   A23
!              A31   A32   A33
!
!           Here A11, A21 and A31 denote the current block of JB columns
!           which is about to be factorized. The number of rows in the
!           partitioning are JB, I2, I3 respectively, and the numbers
!           of columns are JB, J2, J3. The superdiagonal elements of A13
!           and the subdiagonal elements of A31 lie outside the band.
!
            I2 = MIN( KL-JB, M-J-JB+1 )
            I3 = MIN( JB, M-J-KL+1 )
!
!           J2 and J3 are computed after JU has been updated.
!
!           Factorize the current block of JB columns
!
            DO 80 JJ = J, J + JB - 1
!
!              Set fill-in elements in column JJ+KV to zero
!
               IF( JJ+KV.LE.N ) THEN
                  DO 70 I = 1, KL
                     AB( I, JJ+KV ) = ZERO
   70             CONTINUE
               END IF
!
!              Find pivot and test for singularity. KM is the number of
!              subdiagonal elements in the current column.
!
               KM = MIN( KL, M-JJ )
               JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 )
               IPIV( JJ ) = JP + JJ - J
               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
                  IF( JP.NE.1 ) THEN
!
!                    Apply interchange to columns J to J+JB-1
!
                     IF( JP+JJ-1.LT.J+KL ) THEN
!
                        CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,     &
     &                              AB( KV+JP+JJ-J, J ), LDAB-1 )
                     ELSE
!
!                       The interchange affects columns J to JJ-1 of A31
!                       which are stored in the work array WORK31
!
                        CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,   &
     &                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                        CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,    &
     &                              AB( KV+JP, JJ ), LDAB-1 )
                     END IF
                  END IF
!
!                 Compute multipliers
!
                  CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), &
     &                        1 )
!
!                 Update trailing submatrix within the band and within
!                 the current block. JM is the index of the last column
!                 which needs to be updated.
!
                  JM = MIN( JU, J+JB-1 )
                  IF( JM.GT.JJ )                                        &
     &               CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,    &
     &                           AB( KV, JJ+1 ), LDAB-1,                &
     &                           AB( KV+1, JJ+1 ), LDAB-1 )
               ELSE
!
!                 If pivot is zero, set INFO to the index of the pivot
!                 unless a zero pivot has already been found.
!
                  IF( INFO.EQ.0 )                                       &
     &               INFO = JJ
               END IF
!
!              Copy current column of A31 into the work array WORK31
!
               NW = MIN( JJ-J+1, I3 )
               IF( NW.GT.0 )                                            &
     &            CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,            &
     &                        WORK31( 1, JJ-J+1 ), 1 )
   80       CONTINUE
            IF( J+JB.LE.N ) THEN
!
!              Apply the row interchanges to the other blocks.
!
               J2 = MIN( JU-J+1, KV ) - JB
               J3 = MAX( 0, JU-J-KV+1 )
!
!              Use ZLASWP to apply the row interchanges to A12, A22, and
!              A32.
!
               CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,     &
     &                      IPIV( J ), 1 )
!
!              Adjust the pivot indices.
!
               DO 90 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
   90          CONTINUE
!
!              Apply the row interchanges to A13, A23, and A33
!              columnwise.
!
               K2 = J - 1 + JB + J2
               DO 110 I = 1, J3
                  JJ = K2 + I
                  DO 100 II = J + I - 1, J + JB - 1
                     IP = IPIV( II )
                     IF( IP.NE.II ) THEN
                        TEMP = AB( KV+1+II-JJ, JJ )
                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
                        AB( KV+1+IP-JJ, JJ ) = TEMP
                     END IF
  100             CONTINUE
  110          CONTINUE
!
!              Update the relevant part of the trailing submatrix
!
               IF( J2.GT.0 ) THEN
!
!                 Update A12
!
                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',  &
     &                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,       &
     &                        AB( KV+1-JB, J+JB ), LDAB-1 )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A22
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J2,&
     &                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,    &
     &                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,      &
     &                           AB( KV+1, J+JB ), LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Update A32
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J2,&
     &                           JB, -ONE, WORK31, LDWORK,              &
     &                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,      &
     &                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
                  END IF
               END IF
!
               IF( J3.GT.0 ) THEN
!
!                 Copy the lower triangle of A13 into the work array
!                 WORK13
!
                  DO 130 JJ = 1, J3
                     DO 120 II = JJ, JB
                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
  120                CONTINUE
  130             CONTINUE
!
!                 Update A13 in the work array
!
                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',  &
     &                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,       &
     &                        WORK13, LDWORK )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A23
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J3,&
     &                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,    &
     &                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), &
     &                           LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Update A33
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J3,&
     &                           JB, -ONE, WORK31, LDWORK, WORK13,      &
     &                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
                  END IF
!
!                 Copy the lower triangle of A13 back into place
!
                  DO 150 JJ = 1, J3
                     DO 140 II = JJ, JB
                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
  140                CONTINUE
  150             CONTINUE
               END IF
            ELSE
!
!              Adjust the pivot indices.
!
               DO 160 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
  160          CONTINUE
            END IF
!
!           Partially undo the interchanges in the current block to
!           restore the upper triangular form of A31 and copy the upper
!           triangle of A31 back into place
!
            DO 170 JJ = J + JB - 1, J, -1
               JP = IPIV( JJ ) - JJ + 1
               IF( JP.NE.1 ) THEN
!
!                 Apply interchange to columns J to JJ-1
!
                  IF( JP+JJ-1.LT.J+KL ) THEN
!
!                    The interchange does not affect A31
!
                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,      &
     &                           AB( KV+JP+JJ-J, J ), LDAB-1 )
                  ELSE
!
!                    The interchange does affect A31
!
                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,      &
     &                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                  END IF
               END IF
!
!              Copy the current column of A31 back into place
!
               NW = MIN( I3, JJ-J+1 )
               IF( NW.GT.0 )                                            &
     &            CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1,               &
     &                        AB( KV+KL+1-JJ+J, JJ ), 1 )
  170       CONTINUE
  180    CONTINUE
      END IF
!
      RETURN
!
!     End of ZGBTRF
!
      END
      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),                    &
     &                   ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            IZAMAX
      EXTERNAL           IZAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J )                                               &
     &         CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M )                                                &
     &         CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),    &
     &                  LDA, A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of ZGETF2
!
      END
      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!                has been completed, but the factor U is exactly
!                singular, and division by zero will occur if it is used
!                to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL ZGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )                            &
     &         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,     &
     &                      IPIV, 1 )
!
!              Compute block row of U.
!
               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, &
     &                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), &
     &                     LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                  CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, &
     &                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,    &
     &                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),  &
     &                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of ZGETRF
!
      END
      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGETRS solves a system of linear equations
!     A * X = B,  A**T * X = B,  or  A**H * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by ZGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) COMPLEX*16 array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by ZGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZLASWP, ZTRSM
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.        &
     &    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 )                                       &
     &   RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,  &
     &               ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,    &
     &               NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A**T * X = B  or A**H * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,  &
     &               A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,   &
     &               LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of ZGETRS
!
      END
      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ZLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in positions
!          K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
!  Further Details
!  ===============
!
!  Modified by
!   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      COMPLEX*16         TEMP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1 through K2.
!
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
!
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of ZLASWP
!
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J )                                               &
     &         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M )                                                &
     &         CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,&
     &                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of DGETF2
!
      END
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!                has been completed, but the factor U is exactly
!                singular, and division by zero will occur if it is used
!                to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )                            &
     &         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,     &
     &                      IPIV, 1 )
!
!              Compute block row of U.
!
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, &
     &                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), &
     &                     LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, &
     &                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,    &
     &                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),  &
     &                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of DGETRF
!
      END
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRS solves a system of linear equations
!     A * X = B  or  A' * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by DGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A'* X = B  (Transpose)
!          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by DGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASWP, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.        &
     &    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 )                                       &
     &   RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,  &
     &               ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,    &
     &               NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A' * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, &
     &               ONE, A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,&
     &               A, LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of DGETRS
!
      END
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in positions
!          K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
!  Further Details
!  ===============
!
!  Modified by
!   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      DOUBLE PRECISION   TEMP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1 through K2.
!
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
!
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of DLASWP
!
      END
      REAL             FUNCTION SCSUM1( N, CX, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
!     ..
!     .. Array Arguments ..
      COMPLEX            CX( * )
!     ..
!
!  Purpose
!  =======
!
!  SCSUM1 takes the sum of the absolute values of a complex
!  vector and returns a single precision result.
!
!  Based on SCASUM from the Level 1 BLAS.
!  The change is to use the 'genuine' absolute value.
!
!  Contributed by Nick Higham for use with CLACON.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of elements in the vector CX.
!
!  CX      (input) COMPLEX array, dimension (N)
!          The vector whose elements will be summed.
!
!  INCX    (input) INTEGER
!          The spacing between successive values of CX.  INCX > 0.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, NINCX
      REAL               STEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      SCSUM1 = 0.0E0
      STEMP = 0.0E0
      IF( N.LE.0 )                                                      &
     &   RETURN
      IF( INCX.EQ.1 )                                                   &
     &   GO TO 20
!
!     CODE FOR INCREMENT NOT EQUAL TO 1
!
      NINCX = N*INCX
      DO 10 I = 1, NINCX, INCX
!
!        NEXT LINE MODIFIED.
!
         STEMP = STEMP + ABS( CX( I ) )
   10 CONTINUE
      SCSUM1 = STEMP
      RETURN
!
!     CODE FOR INCREMENT EQUAL TO 1
!
   20 CONTINUE
      DO 30 I = 1, N
!
!        NEXT LINE MODIFIED.
!
         STEMP = STEMP + ABS( CX( I ) )
   30 CONTINUE
      SCSUM1 = STEMP
      RETURN
!
!     End of SCSUM1
!
      END
      INTEGER          FUNCTION ICMAX1( N, CX, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
!     ..
!     .. Array Arguments ..
      COMPLEX            CX( * )
!     ..
!
!  Purpose
!  =======
!
!  ICMAX1 finds the index of the element whose real part has maximum
!  absolute value.
!
!  Based on ICAMAX from Level 1 BLAS.
!  The change is to use the 'genuine' absolute value.
!
!  Contributed by Nick Higham for use with CLACON.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of elements in the vector CX.
!
!  CX      (input) COMPLEX array, dimension (N)
!          The vector whose elements will be summed.
!
!  INCX    (input) INTEGER
!          The spacing between successive values of CX.  INCX >= 1.
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IX
      REAL               SMAX
      COMPLEX            ZDUM
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, REAL
!     ..
!     .. Statement Functions ..
      REAL               CABS1
!     ..
!     .. Statement Function definitions ..
!
!     NEXT LINE IS THE ONLY MODIFICATION.
      CABS1( ZDUM ) = ABS( REAL( ZDUM ) )
!     ..
!     .. Executable Statements ..
!
      ICMAX1 = 0
      IF( N.LT.1 )                                                      &
     &   RETURN
      ICMAX1 = 1
      IF( N.EQ.1 )                                                      &
     &   RETURN
      IF( INCX.EQ.1 )                                                   &
     &   GO TO 30
!
!     CODE FOR INCREMENT NOT EQUAL TO 1
!
      IX = 1
      SMAX = CABS1( CX( 1 ) )
      IX = IX + INCX
      DO 20 I = 2, N
         IF( CABS1( CX( IX ) ).LE.SMAX )                                &
     &      GO TO 10
         ICMAX1 = I
         SMAX = CABS1( CX( IX ) )
   10    CONTINUE
         IX = IX + INCX
   20 CONTINUE
      RETURN
!
!     CODE FOR INCREMENT EQUAL TO 1
!
   30 CONTINUE
      SMAX = CABS1( CX( 1 ) )
      DO 40 I = 2, N
         IF( CABS1( CX( I ) ).LE.SMAX )                                 &
     &      GO TO 40
         ICMAX1 = I
         SMAX = CABS1( CX( I ) )
   40 CONTINUE
      RETURN
!
!     End of ICMAX1
!
      END
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1998
!
!     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
!     ..
!
!  Purpose
!  =======
!
!  IEEECK is called from the ILAENV to verify that Infinity and
!  possibly NaN arithmetic is safe (i.e. will not trap).
!
!  Arguments
!  =========
!
!  ISPEC   (input) INTEGER
!          Specifies whether to test just for inifinity arithmetic
!          or whether to test for infinity and NaN arithmetic.
!          = 0: Verify infinity arithmetic only.
!          = 1: Verify infinity and NaN arithmetic.
!
!  ZERO    (input) REAL
!          Must contain the value 0.0
!          This is passed to prevent the compiler from optimizing
!          away this code.
!
!  ONE     (input) REAL
!          Must contain the value 1.0
!          This is passed to prevent the compiler from optimizing
!          away this code.
!
!  RETURN VALUE:  INTEGER
!          = 0:  Arithmetic failed to produce the correct answers
!          = 1:  Arithmetic produced the correct answers
!
!     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,    &
     &                   NEGZRO, NEWZRO, POSINF
!     ..
!     .. Executable Statements ..
      IEEECK = 1
!
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
!
!
!
!     Return if we were only asked to check infinity arithmetic
!
      IF( ISPEC.EQ.0 )                                                  &
     &   RETURN
!
      NAN1 = POSINF + NEGINF
!
      NAN2 = POSINF / NEGINF
!
      NAN3 = POSINF / POSINF
!
      NAN4 = POSINF*ZERO
!
      NAN5 = NEGINF*NEGZRO
!
      NAN6 = NAN5*0.0
!
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      RETURN
      END
      REAL             FUNCTION SLAMCH( CMACH )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992 
!
!     .. Scalar Arguments ..
      CHARACTER          CMACH
!     ..
!
!  Purpose
!  =======
!
!  SLAMCH determines single precision machine parameters.
!
!  Arguments
!  =========
!
!  CMACH   (input) CHARACTER*1
!          Specifies the value to be returned by SLAMCH:
!          = 'E' or 'e',   SLAMCH := eps
!          = 'S' or 's ,   SLAMCH := sfmin
!          = 'B' or 'b',   SLAMCH := base
!          = 'P' or 'p',   SLAMCH := eps*base
!          = 'N' or 'n',   SLAMCH := t
!          = 'R' or 'r',   SLAMCH := rnd
!          = 'M' or 'm',   SLAMCH := emin
!          = 'U' or 'u',   SLAMCH := rmin
!          = 'L' or 'l',   SLAMCH := emax
!          = 'O' or 'o',   SLAMCH := rmax
!
!          where
!
!          eps   = relative machine precision
!          sfmin = safe minimum, such that 1/sfmin does not overflow
!          base  = base of the machine
!          prec  = eps*base
!          t     = number of (base) digits in the mantissa
!          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
!          emin  = minimum exponent before (gradual) underflow
!          rmin  = underflow threshold - base**(emin-1)
!          emax  = largest exponent before overflow
!          rmax  = overflow threshold  - (base**emax)*(1-eps)
!
! =====================================================================
!
!     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      REAL               BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,&
     &                   RND, SFMIN, SMALL, T
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           SLAMC2
!     ..
!     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,   &
     &                   EMAX, RMAX, PREC
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
!
!           Use SMALL plus a bit, to avoid the possibility of rounding
!           causing overflow when computing  1/sfmin.
!
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
!
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
!
      SLAMCH = RMACH
      RETURN
!
!     End of SLAMCH
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
!     ..
!
!  Purpose
!  =======
!
!  SLAMC1 determines the machine parameters given by BETA, T, RND, and
!  IEEE1.
!
!  Arguments
!  =========
!
!  BETA    (output) INTEGER
!          The base of the machine.
!
!  T       (output) INTEGER
!          The number of ( BETA ) digits in the mantissa.
!
!  RND     (output) LOGICAL
!          Specifies whether proper rounding  ( RND = .TRUE. )  or
!          chopping  ( RND = .FALSE. )  occurs in addition. This may not
!          be a reliable guide to the way in which the machine performs
!          its arithmetic.
!
!  IEEE1   (output) LOGICAL
!          Specifies whether rounding appears to be done in the IEEE
!          'round to nearest' style.
!
!  Further Details
!  ===============
!
!  The routine is based on the routine  ENVRON  by Malcolm and
!  incorporates suggestions by Gentleman and Marovich. See
!
!     Malcolm M. A. (1972) Algorithms to reveal properties of
!        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
!
!     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
!        that reveal properties of floating point arithmetic units.
!        Comms. of the ACM, 17, 276-277.
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      REAL               A, B, C, F, ONE, QTR, SAVEC, T1, T2
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
!
!        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
!        IEEE1, T and RND.
!
!        Throughout this routine  we use the function  SLAMC3  to ensure
!        that relevant values are  stored and not held in registers,  or
!        are not affected by optimizers.
!
!        Compute  a = 2.0**m  with the  smallest positive integer m such
!        that
!
!           fl( a + 1.0 ) = a.
!
         A = 1
         C = 1
!
!+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = SLAMC3( A, ONE )
            C = SLAMC3( C, -A )
            GO TO 10
         END IF
!+       END WHILE
!
!        Now compute  b = 2.0**m  with the smallest positive integer m
!        such that
!
!           fl( a + b ) .gt. a.
!
         B = 1
         C = SLAMC3( A, B )
!
!+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = SLAMC3( A, B )
            GO TO 20
         END IF
!+       END WHILE
!
!        Now compute the base.  a and c  are neighbouring floating point
!        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
!        their difference is beta. Adding 0.25 to c is to ensure that it
!        is truncated to beta and not ( beta - 1 ).
!
         QTR = ONE / 4
         SAVEC = C
         C = SLAMC3( C, -A )
         LBETA = C + QTR
!
!        Now determine whether rounding or chopping occurs,  by adding a
!        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
!
         B = LBETA
         F = SLAMC3( B / 2, -B / 100 )
         C = SLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = SLAMC3( B / 2, B / 100 )
         C = SLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )                                &
     &      LRND = .FALSE.
!
!        Try and decide whether rounding is done in the  IEEE  'round to
!        nearest' style. B/2 is half a unit in the last place of the two
!        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
!        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
!        A, but adding B/2 to SAVEC should change SAVEC.
!
         T1 = SLAMC3( B / 2, A )
         T2 = SLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
!
!        Now find  the  mantissa, t.  It should  be the  integer part of
!        log to the base beta of a,  however it is safer to determine  t
!        by powering.  So we find t as the smallest positive integer for
!        which
!
!           fl( beta**t + 1.0 ) = 1.0.
!
         LT = 0
         A = 1
         C = 1
!
!+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = SLAMC3( A, ONE )
            C = SLAMC3( C, -A )
            GO TO 30
         END IF
!+       END WHILE
!
      END IF
!
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
!
!     End of SLAMC1
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      REAL               EPS, RMAX, RMIN
!     ..
!
!  Purpose
!  =======
!
!  SLAMC2 determines the machine parameters specified in its argument
!  list.
!
!  Arguments
!  =========
!
!  BETA    (output) INTEGER
!          The base of the machine.
!
!  T       (output) INTEGER
!          The number of ( BETA ) digits in the mantissa.
!
!  RND     (output) LOGICAL
!          Specifies whether proper rounding  ( RND = .TRUE. )  or
!          chopping  ( RND = .FALSE. )  occurs in addition. This may not
!          be a reliable guide to the way in which the machine performs
!          its arithmetic.
!
!  EPS     (output) REAL
!          The smallest positive number such that
!
!             fl( 1.0 - EPS ) .LT. 1.0,
!
!          where fl denotes the computed value.
!
!  EMIN    (output) INTEGER
!          The minimum exponent before (gradual) underflow occurs.
!
!  RMIN    (output) REAL
!          The smallest normalized number for the machine, given by
!          BASE**( EMIN - 1 ), where  BASE  is the floating point value
!          of BETA.
!
!  EMAX    (output) INTEGER
!          The maximum exponent before overflow occurs.
!
!  RMAX    (output) REAL
!          The largest positive number for the machine, given by
!          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
!          value of BETA.
!
!  Further Details
!  ===============
!
!  The computation of  EPS  is based on a routine PARANOIA by
!  W. Kahan of the University of California at Berkeley.
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,      &
     &                   NGNMIN, NGPMIN
      REAL               A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, &
     &                   SIXTH, SMALL, THIRD, TWO, ZERO
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. External Subroutines ..
      EXTERNAL           SLAMC1, SLAMC4, SLAMC5
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,&
     &                   LRMIN, LT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
!
!        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
!        BETA, T, RND, EPS, EMIN and RMIN.
!
!        Throughout this routine  we use the function  SLAMC3  to ensure
!        that relevant values are stored  and not held in registers,  or
!        are not affected by optimizers.
!
!        SLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
!
         CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
!
!        Start to find EPS.
!
         B = LBETA
         A = B**( -LT )
         LEPS = A
!
!        Try some tricks to see whether or not this is the correct  EPS.
!
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = SLAMC3( B, -HALF )
         THIRD = SLAMC3( SIXTH, SIXTH )
         B = SLAMC3( THIRD, -HALF )
         B = SLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )                                                &
     &      B = LEPS
!
         LEPS = 1
!
!+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = SLAMC3( HALF, -C )
            B = SLAMC3( HALF, C )
            C = SLAMC3( HALF, -B )
            B = SLAMC3( HALF, C )
            GO TO 10
         END IF
!+       END WHILE
!
         IF( A.LT.LEPS )                                                &
     &      LEPS = A
!
!        Computation of EPS complete.
!
!        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
!        Keep dividing  A by BETA until (gradual) underflow occurs. This
!        is detected when we cannot recover the previous A.
!
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = SLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = SLAMC3( ONE, SMALL )
         CALL SLAMC4( NGPMIN, ONE, LBETA )
         CALL SLAMC4( NGNMIN, -ONE, LBETA )
         CALL SLAMC4( GPMIN, A, LBETA )
         CALL SLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
!
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
!            ( Non twos-complement machines, no gradual underflow;
!              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
!            ( Non twos-complement machines, with gradual underflow;
!              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
!            ( Twos-complement machines, no gradual underflow;
!              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.                   &
     &            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
!            ( Twos-complement machines with gradual underflow;
!              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
!         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
!**
! Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
!**
!
!        Assume IEEE arithmetic if we found denormalised  numbers above,
!        or if arithmetic seems to round in the  IEEE style,  determined
!        in routine SLAMC1. A true IEEE machine should have both  things
!        true; however, faulty machines may have one or the other.
!
         IEEE = IEEE .OR. LIEEE1
!
!        Compute  RMIN by successive division by  BETA. We could compute
!        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
!        this computation.
!
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
!
!        Finally, call SLAMC5 to compute EMAX and RMAX.
!
         CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
!
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
!
      RETURN
!
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',        &
     &      '  EMIN = ', I8, /                                          &
     &      ' If, after inspection, the value EMIN looks',              &
     &      ' acceptable please comment out ',                          &
     &      / ' the IF block as marked within the code of routine',     &
     &      ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
!
!     End of SLAMC2
!
      END
!
!***********************************************************************
!
      REAL             FUNCTION SLAMC3( A, B )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      REAL               A, B
!     ..
!
!  Purpose
!  =======
!
!  SLAMC3  is intended to force  A  and  B  to be stored prior to doing
!  the addition of  A  and  B ,  for use in situations where optimizers
!  might hold one of these in a register.
!
!  Arguments
!  =========
!
!  A, B    (input) REAL
!          The values A and B.
!
! =====================================================================
!
!     .. Executable Statements ..
!
      SLAMC3 = A + B
!
      RETURN
!
!     End of SLAMC3
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC4( EMIN, START, BASE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      REAL               START
!     ..
!
!  Purpose
!  =======
!
!  SLAMC4 is a service routine for SLAMC2.
!
!  Arguments
!  =========
!
!  EMIN    (output) EMIN
!          The minimum exponent before (gradual) underflow, computed by
!          setting A = START and dividing by BASE until the previous A
!          can not be recovered.
!
!  START   (input) REAL
!          The starting point for determining EMIN.
!
!  BASE    (input) INTEGER
!          The base of the machine.
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I
      REAL               A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. Executable Statements ..
!
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = SLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
!+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
!    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.         &
     &    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = SLAMC3( A / BASE, ZERO )
         C1 = SLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = SLAMC3( A*RBASE, ZERO )
         C2 = SLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
!+    END WHILE
!
      RETURN
!
!     End of SLAMC4
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      REAL               RMAX
!     ..
!
!  Purpose
!  =======
!
!  SLAMC5 attempts to compute RMAX, the largest machine floating-point
!  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
!  approximately to a power of 2.  It will fail on machines where this
!  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
!  EMAX = 28718).  It will also fail if the value supplied for EMIN is
!  too large (i.e. too close to zero), probably with overflow.
!
!  Arguments
!  =========
!
!  BETA    (input) INTEGER
!          The base of floating-point arithmetic.
!
!  P       (input) INTEGER
!          The number of base BETA digits in the mantissa of a
!          floating-point value.
!
!  EMIN    (input) INTEGER
!          The minimum exponent before (gradual) underflow.
!
!  IEEE    (input) LOGICAL
!          A logical flag specifying whether or not the arithmetic
!          system is thought to comply with the IEEE standard.
!
!  EMAX    (output) INTEGER
!          The largest exponent before overflow
!
!  RMAX    (output) REAL
!          The largest machine floating-point number.
!
! =====================================================================
!
!     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
!     ..
!     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      REAL               OLDY, RECBAS, Y, Z
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MOD
!     ..
!     .. Executable Statements ..
!
!     First compute LEXP and UEXP, two powers of 2 that bound
!     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
!     approximately to the bound that is closest to abs(EMIN).
!     (EMAX is the exponent of the required number RMAX).
!
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
!
!     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
!     than or equal to EMIN. EXBITS is the number of bits needed to
!     store the exponent.
!
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
!
!     EXPSUM is the exponent range, approximately equal to
!     EMAX - EMIN + 1 .
!
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
!
!     NBITS is the total number of bits needed to store a
!     floating-point number.
!
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
!
!        Either there are an odd number of bits used to store a
!        floating-point number, which is unlikely, or some bits are
!        not used in the representation of numbers, which is possible,
!        (e.g. Cray machines) or the mantissa has an implicit bit,
!        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
!        most likely. We have to assume the last alternative.
!        If this is true, then we need to reduce EMAX by one because
!        there must be some way of representing zero in an implicit-bit
!        system. On machines like Cray, we are reducing EMAX by one
!        unnecessarily.
!
         EMAX = EMAX - 1
      END IF
!
      IF( IEEE ) THEN
!
!        Assume we are on an IEEE machine which reserves one exponent
!        for infinity and NaN.
!
         EMAX = EMAX - 1
      END IF
!
!     Now create RMAX, the largest machine number, which should
!     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
!
!     First compute 1.0 - BETA**(-P), being careful that the
!     result is less than 1.0 .
!
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )                                                 &
     &      OLDY = Y
         Y = SLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )                                                    &
     &   Y = OLDY
!
!     Now multiply by BETA**EMAX to get RMAX.
!
      DO 30 I = 1, EMAX
         Y = SLAMC3( Y*BETA, ZERO )
   30 CONTINUE
!
      RMAX = Y
      RETURN
!
!     End of SLAMC5
!
      END
c///////////////////////////////////////////////////////////////////////
c Distribution:  COMMON 1.0
c Copyright (c) [2002] University of Washington
c 
c This software was prepared in part with US Government Funding under
c DOE contract DE-FG03-97ER45623.

c Redistribution and use of this Distribution in source and binary
c formats, with or without modification is permitted, provided the 
c following conditions are met:
c 
c Redistributions must retain the above notices and the following list
c of conditions and disclaimer;
c 
c Modified formats carry the marking
c     "Based on or developed using Distribution: COMMON 1.0
c      COMMON 1.0 Copyright (c) [2002] University of Washington"
c 
c Recipient acknowledges the right of the University of Washington to
c prepare uses of this Distribution and its modifications that may be
c substantially similar or functionally equivalent to
c Recipient-prepared modifications.
c
c Recipient and anyone obtaining access to the Distribution through
c recipient's actions accept all risk associated with possession and
c use of the Distribution.
c
c THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED
c WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
c MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
c IN NO EVENT SHALL THE UNIVERSITY OF WASHINGTON OR CONTRIBUTORS TO THE
c DISTRIBUTION BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
c EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
c PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
c REVENUE; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
c LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
c NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
c SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
      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')
      call par_stop('CHOPEN')
      end
      subroutine fixdsp (dxorg, dxnew, dgc0, dpc0, dgcx, dpcx, jnew)

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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      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 (iph, 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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      dimension dgc(251,30,0:nphx+1), dpc(251,30,0:nphx+1)
      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,iph)) .ge. 1.0d-11 .or. 
     1           abs(dpc(i,iorb,iph)) .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,iph),jmax,3, xnew(j),dgcn(j,iorb))
            call terp(xorg,dpc(1,iorb,iph),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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}


      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,  jriorg, 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 getorb (iz, ihole, xion, iunf, norb, norbco, iorb,
     1                  iholep, nqn, nk, xnel, xnval, xmag)
c     Gets orbital data for chosen element.  Input is:
c       iz - atomic number of desired element,
c       ihole - index of core-hole orbital
c       xion  - ionicity (usually zero)
c     other arguments are output.
c       norb - total number of orbitals
c       norbco - number of core orbitals
c       iorb - index of orbital for making projections (last occupied)
c       iholep - index of core hole orbital in compacted list
c       nqn - principal quantum number for each orbital
c       nk - quantum number kappa for each orbital
c       xnel - occupation for each orbital
c       xnval - valence occupation for each orbital
c       xmag - spin magnetization for each orbital
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 99
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 nqn(30), nk(30), xnel(30), xnval(30), xmag(30)
      dimension kappa (29)
      real iocc, ival, ispn
      dimension iocc (100, 29), ival (100, 29), ispn (100, 29)
      dimension nnum (29), iorb(-4:3)
      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, 99
      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 (ispn( 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 (ispn( 2,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( 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 (ispn( 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 (ispn( 4,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( 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 (ispn( 5,i),i=1,29)  /0,0,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/

c     data (iocc( 6,i),i=1,29)  /2,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
      data (iocc( 6,i),i=1,29)  /2,1,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/
c     data (ival( 6,i),i=1,29)  /0,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
      data (ival( 6,i),i=1,29)  /0,1,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 (ispn( 6,i),i=1,29)  /0,0,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( 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 (ispn( 7,i),i=1,29)  /0,0,0,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 (ispn( 8,i),i=1,29)  /0,0,0,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( 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 (ispn( 9,i),i=1,29)  /0,0,0,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(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,0,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 (ispn(10,i),i=1,29)  /0,0,0,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(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,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 (ispn(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,1,  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(12,i),i=1,29)  /0,0,0,0,1,  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 (ispn(12,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(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 (ispn(13,i),i=1,29)  /0,0,0,0,0,  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 (ispn(14,i),i=1,29)  /0,0,0,0,0,  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(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 (ispn(15,i),i=1,29)  /0,0,0,0,0,  0,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 (ispn(16,i),i=1,29)  /0,0,0,0,0,  0,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(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 (ispn(17,i),i=1,29)  /0,0,0,0,0,  0,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(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 (ispn(18,i),i=1,29)  /0,0,0,0,0,  0,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(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,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 (ispn(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,1,  1,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,  2,4,0,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(20,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(21,i),i=1,29)  /2,2,2,4,2,  2,4,1,0,1,  1,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,  2,4,1,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(21,i),i=1,29)  /0,0,0,0,0,  0,0,1,0,0,  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,1,  1,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,  2,4,2,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(22,i),i=1,29)  /0,0,0,0,0,  0,0,2,0,0,  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,1,  1,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,  2,4,3,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(23,i),i=1,29)  /0,0,0,0,0,  0,0,3,0,0,  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,0,1,  1,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,  2,4,4,0,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(24,i),i=1,29)  /0,0,0,0,0,  0,0,4,0,0,  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,1,  1,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,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,0,  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,1,  1,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,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(26,i),i=1,29)  /0,0,0,0,0,  0,0,2,2,0,  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,1,  1,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,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(27,i),i=1,29)  /0,0,0,0,0,  0,0,0,3,0,  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,1,  1,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,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(28,i),i=1,29)  /0,0,0,0,0,  0,0,0,1,0,  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 (ispn(29,i),i=1,29)  /0,0,0,0,0,  0,0,0,1,0,  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,1,  1,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,1,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(30,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(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,4,6,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(31,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  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,4,6,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(32,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  1,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 (ispn(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,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 (ispn(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,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 (ispn(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,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 (ispn(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,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,2,  2,4,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(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,  2,4,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(38,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(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,  2,4,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,
     1                           0,0,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,  2,4,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,0,0,
     1                           0,0,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,  2,4,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,3,0,0,
     1                           0,0,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,  2,4,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,
     1                           0,0,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 (ispn(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,0,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 (ispn(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,2,0,
     1                           0,0,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 (ispn(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,0,
     1                           0,0,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 (ispn(46,i),i=1,29)  /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,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 (ispn(47,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(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 (ispn(48,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(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,4,6,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,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,4,6,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,1,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,4,6,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,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 (ispn(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,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 (ispn(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,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 (ispn(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,1,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,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ispn(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,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,1,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,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,0,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,1,
     1                           0,2,2,4,1,  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,1,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,
     1                           0,0,0,0,0,  0,0,0,0,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,2,
     1                           0,2,2,4,1,  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,2,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(59,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,0,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,3,
     1                           0,2,2,4,1,  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,3,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(60,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,0,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,4,
     1                           0,2,2,4,1,  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,4,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(61,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,0,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,5,
     1                           0,2,2,4,1,  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,5,
     1                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(62,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,0,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                           0,2,2,4,1,  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                           0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(63,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,0,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,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,0,  0,0,0,0,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                           2,2,2,4,1,  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                           2,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,
     1                           2,0,0,0,0,  0,0,0,0,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                           3,2,2,4,1,  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                           3,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,
     1                           3,0,0,0,0,  0,0,0,0,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                           4,2,2,4,1,  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                           4,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           4,0,0,0,0,  0,0,0,0,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                           5,2,2,4,1,  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                           5,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           3,0,0,0,0,  0,0,0,0,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                           6,2,2,4,1,  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                           6,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           2,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                           7,2,2,4,1,  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                           7,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           1,0,0,0,0,  0,0,0,0,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,6,
     1                           8,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,0,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,6,
     1                           8,0,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,0,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,6,
     1                           8,0,0,0,3,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,0,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,3,  1,0,0,2,0,  0,0,0,0/
c    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,6,
     1                           8,0,0,0,3,  1,0,0,2,0,  0,0,0,0/
c    1                           8,0,0,0,4,  0,0,0,2,0,  0,0,0,0/
      data (ispn(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,0,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 (ispn(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,0,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 (ispn(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,2,  2,0,0,0,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 (ispn(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,0,  3,0,0,0,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 (ispn(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,0,  2,0,0,0,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 (ispn(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,0,  1,0,0,0,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 (ispn(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,0,  0,0,0,1,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,4,  6,0,0,2,1,  0,0,0,0/
      data (ispn(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,0,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,4,  6,0,0,2,2,  0,0,0,0/
      data (ispn(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,0,1,  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,4,  6,0,0,2,2,  1,0,0,0/
      data (ispn(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,0,0,  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,4,  6,0,0,2,2,  2,0,0,0/
      data (ispn(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,0,0,  1,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 (ispn(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,0,0,  1,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 (ispn(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,0,0,  1,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,2,2,  4,0,0,1/
      data (ispn(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,2,  4,0,0,2/
      data (ispn(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,1/

      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,2,  4,1,0,2/
      data (ispn(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,0/

      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,2,  4,2,0,2/
      data (ispn(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,0/

      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,2,  4,1,0,2/
      data (ispn(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,0,0,0/

      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,2,  4,1,0,2/
      data (ispn(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,1.5,0,0,0,  0,0,0,0/

      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,2,  4,1,0,2/
      data (ispn(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,0,0,0/

      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,2,  4,0,0,2/
      data (ispn(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,5,0,0,0,  0,0,0,0/

      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,2,  4,0,0,2/
      data (ispn(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,5,1,0,0,  0,0,0,0/

      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,2,  4,0,0,2/
      data (ispn(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,5,2,0,0,  0,0,0,0/

      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,2,  4,0,0,2/
      data (ispn(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,3,3,0,0,  0,0,0,0/

      data (iocc(98,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,4,2,2,  4,0,0,2/
      data (ival(98,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,4,0,2,  4,0,0,2/
      data (ispn(98,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,1,4,0,0,  0,0,0,0/

      data (iocc(99,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,5,2,2,  4,0,0,2/
      data (ival(99,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,5,0,2,  4,0,0,2/
      data (ispn(99,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,4,0,0,  0,0,0,0/

      data (iocc(100,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,6,2,2,  4,0,0,2/
      data (ival(100,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,6,0,2,  4,0,0,2/
      data (ispn(100,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,3,0,0,  0,0,0,0/

      if (iz .lt. 1  .or.  iz .gt. 99)  then
    8    format(' Atomic number ', i5, ' not available.')
         write(slog,8)  iz
         call wlog(slog)
         call par_stop('GETORB-0')
      endif

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

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

      if (ihole.gt.0) then
         if ( iocc(index,ihole) .lt. 1 ) then
           call wlog(' Cannot remove an electron from this level')
           call par_stop('GETORB-1')
         endif
      endif
      if (ihole.eq.ilast) then 
         if ( iocc(index,ihole)-delion.lt.1) then
           call wlog(' Cannot remove an electron from this level')
           call par_stop('GETORB-1')
        endif
      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).
c     if (delion .ge. 0) then
c        removal of electron charge
c        iion is already found
      if (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 19 i=-4, 3
 19   iorb(i) = 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. iocc(index,i)-delion.gt.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 = norb
               endif
               if (i.eq.iscr .and. ihole.gt.0)  xnel(norb)=xnel(norb)+1
               xnval(norb)= ival(index,i)
               if ((kappa(i).eq.-4 .or. kappa(i).eq.3) .and. iunf.eq.0)
     1           xnval(norb) = 0
               xmag(norb) = ispn(index,i)
               iorb(nk(norb)) = norb
               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
            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)
            call par_stop('GETORB-99')
         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(in Hartrees) as
c          k =  sqrt(2*e)  for e > 0  (above the edge)
c          k = -sqrt(-2*e)  for e < 0  (below the edge)
      getxk = sqrt(abs(2*e))
      if (e .lt. 0)  getxk = - getxk
      return
      end
      subroutine sthead (ntitle, title, nph, iz, rmt, rnrm,
     1                  xion, ihole, ixc,
     2                  vr0, vi0, gamach, xmu, xf, vint, rs,
     2                  nohole, lreal,  rgrd)

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.bin

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

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/vers.h
      character*12 vfeff
c                       123456789012  
      parameter (vfeff='Feff 8.50')
c= ../HEADERS/vers.h}

      dimension xion(0:nphx)
      dimension iz(0:nphx)
      dimension rmt(0:nphx)
      dimension rnrm(0:nphx)

      character*80 title(nheadx), store
      character*16 s1, s2

      character*10 shole(0:29)
      character*8  sout(0:7)
      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     Fills head arrray, n = number of lines used.
c     Does not include line of dashes at the end.

      if (ntitle .ge. 1 ) then
         ii = istrln(title(1)) 
         if (ii.gt.1)  then
            write(store,100)  title(1)(1:), vfeff
         else
            write(store,102)  vfeff
         endif
      else
         write(store,102)   vfeff
      endif
  100 format( a55, t66, a12)
  102 format( t66, a12)
      title(1) = store
      nstor = 1

c     remove empty title lines
      do 120  ititle = 2, ntitle
         ii = istrln ( title (ititle) ) 
         if (ii.le.1)  goto 120
         nstor = nstor+1
         title(nstor) = title (ititle)
  120 continue
      ntitle = nstor

c     add more title lines
      if (xion(0) .ne. 0)  then
         ntitle = ntitle + 1
         write(title(ntitle),130)  iz(0), rmt(0)*bohr,
     1                    rnrm(0)*bohr, xion(0), shole(ihole)
      else
         ntitle = ntitle + 1
         write(title(ntitle),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)
c     if (nohole.ge.0)  then
c        ntitle = ntitle + 1
c        write(title(ntitle),142)
c 142    format ('Calculations done with no core hole.')
c     endif
      if (lreal.ge.1 .or. (abs(rgrd - 0.05) .gt. 1.0e-5)) then
        ntitle = ntitle + 1
        s1 = ' '
        if (lreal.gt.1)  then
c        write(title(ntitle),144)
c 144    format ('Calculations done using only real phase shifts.')
         s1 = 'RPHASES'
        elseif (lreal.eq.1) then
c        ntitle = ntitle + 1
c        write(title(ntitle),145)
c 145    format ('Calculations done using only real self energy.')
         s1 = 'RSIGMA'
        endif
        s2 = '  '
        if (abs(rgrd - 0.05) .gt. 1.0e-5)  then
         write(s2,146)  rgrd
  146    format ('  RGRID', f7.4)
        endif
        ilen = istrln(s1)
        title(ntitle) = s1(1:ilen) // s2
      endif

      do 150  iph = 1, nph
         if (xion(iph) .ne. 0)  then
            ntitle = ntitle + 1
            write(title(ntitle),160)  iph, iz(iph),  rmt(iph)*bohr,
     1           rnrm(iph)*bohr, xion(iph)
         else
            ntitle = ntitle + 1
            write(title(ntitle),170)  iph, iz(iph),  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
         ntitle = ntitle + 1
         write(title(ntitle),180)  gamach*hart, sout(ixc), vi0*hart,
     1                           vr0*hart
      else
         ntitle = ntitle + 1
         write(title(ntitle),190)  gamach*hart, sout(ixc)
      endif
      ntitle = ntitle + 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(title(ntitle),200)  xmu*hart, xf/bohr, vint*hart, rs

      return
      end

      subroutine wthead (io, ntitle, title)
c     Dump title lines to unit io, which must be open. 
      integer io, i, ll
      character*80 title(ntitle)

c     nice for UNIX to use with gnuplot etc.,
      do 310 i = 1, ntitle
         ll = istrln(title(i))
         write(io,300)  title(i)(1:ll)
  300    format (a)
  310 continue

      return
      end
      function itoken (word,flname)
c     chars in word assumed upper case, left justified
c     returns 0 if not a token, otherwise returns token

      character*(*) word
      character*4   w
      character*20 flname
      integer itoken

      w = word(1:4)
      call upper(w)
      
c     Tokens for feff.inp
cccccccccccccccccccccccccccccccccccccccccccccccccccccc
      if (flname(1:8).eq.'feff.inp') then
         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. 'RPAT' .or. 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. 'CRIT')  then
            itoken = 16
         elseif (w .eq. 'NOGE')  then
            itoken = 17
         elseif (w .eq. 'IORD')  then
            itoken = 18
         elseif (w .eq. 'PCRI')  then
            itoken = 19
         elseif (w .eq. 'SIG2')  then
            itoken = 20
         elseif (w .eq. 'XANE')  then
            itoken = 21
         elseif (w .eq. 'CORR')  then
            itoken = 22
         elseif (w .eq. 'AFOL')  then
            itoken = 23
         elseif (w .eq. 'EXAF')  then
            itoken = 24
         elseif (w .eq. 'POLA')  then
            itoken = 25
         elseif (w .eq. 'ELLI')  then
            itoken = 26
         elseif (w .eq. 'RGRI')  then
            itoken = 27
         elseif (w .eq. 'RPHA')  then
            itoken = 28
         elseif (w .eq. 'NSTA')  then
            itoken = 29
         elseif (w .eq. 'NOHO')  then
            itoken = 30
         elseif (w .eq. 'SIG3')  then
            itoken = 31
         elseif (w .eq. 'JUMP')  then
            itoken = 32
         elseif (w .eq. 'MBCO')  then
            itoken = 33
         elseif (w .eq. 'SPIN')  then
            itoken = 34
         elseif (w .eq. 'EDGE')  then
            itoken = 35
         elseif (w .eq. 'SCF ')  then
            itoken = 36
         elseif (w .eq. 'FMS ')  then
            itoken = 37
         elseif (w .eq. 'LDOS')  then
            itoken = 38
         elseif (w .eq. 'INTE')  then
            itoken = 39
         elseif (w .eq. 'CFAV')  then
            itoken = 40
         elseif (w .eq. 'S02 ')  then
            itoken = 41
         elseif (w .eq. 'XES ')  then
            itoken = 42
         elseif (w .eq. 'DANE')  then
            itoken = 43
         elseif (w .eq. 'FPRI')  then
            itoken = 44
         elseif (w .eq. 'RSIG')  then
            itoken = 45
         elseif (w .eq. 'XNCD')  then
            itoken = 46
         elseif (w .eq. 'XMCD')  then
            itoken = 46
         elseif (w .eq. 'MULT')  then
            itoken = 47
         elseif (w .eq. 'UNFR')  then
            itoken = 48
         elseif (w .eq. 'TDLD')  then
            itoken = 49
         elseif (w .eq. 'PMBS')  then
            itoken = 50
         elseif (w .eq. 'PLAS')  then
            itoken = 51
         elseif (w .eq. 'SO2C')  then
            itoken = 52
         elseif (w .eq. 'SELF')  then
            itoken = 53
         elseif (w .eq. 'SFSE')  then
            itoken = 54
         elseif (w .eq. 'RCONV') then
            itoken = 55
         elseif (w .eq. 'ELNE') then !KJ new card for EELS 1-06
            itoken = 56
         elseif (w .eq. 'EXEL') then !KJ new card for EELS 1-06
            itoken = 57
         elseif (w .eq. 'MAGI') then !KJ new card for EELS 1-06
            itoken = 58
         elseif (w .eq. 'ABSO') then !KJ new card 3-06
            itoken = 59    
         elseif (w .eq. 'EGRI')  then !Josh Kas
            itoken = 60
         elseif (w .eq. 'END ')  then
            itoken = -1            
         else
            itoken = 0
         endif
      elseif (flname(1:10).eq.'spring.inp') then
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     These tokens are for spring.inp (input for eq of motion method)
         if (w .eq. 'STRE')  then
            itoken = 1
         elseif (w .eq. 'ANGL')  then
            itoken = 2
         elseif (w .eq. 'VDOS')  then
            itoken = 3
         elseif (w .eq. 'PRDOS') then
            itoken = 4
         elseif (w .eq. 'END ')  then
            itoken = -1            
         else
            itoken = 0
         endif
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      endif
      return
      end


c====================================================================
      integer function nxtunt(iunit)

c  this function returns the value of the next unopened unit number
c  equal to or larger than iunit.  it will return neither unit numbers
c  0, 5, or 6 nor a negative unit number
c $Id: nxtunt.f,v 1.1.1.1 2006/01/12 06:37:42 hebhop Exp $
c $Log: nxtunt.f,v $
c Revision 1.1.1.1  2006/01/12 06:37:42  hebhop
c New version of feff. feff8.5 (Extension of feff8.4)
c Includes:
c 	1) All feff8.4 capabilities.
c 	2) Screened core hole (calculation of W).
c 	3) Multiple pole self energy calculation.
c 	4) Convolution with spectral function.
c New cards and options:
c 	1) NOHOLE 2      (screened hole)
c 	2) PLASMON ipl   (multiple pole self energy)
c 	3) SO2CONV       (convolve output with spectral function)
c 	4) SELF          (print on shell self energy as calculated by Luke)
c 	5) SFSE k0        (print off shell self energy Sigma(k0,e) )
c
c Revision 1.1.1.1  2000/02/11 02:23:58  alex
c Initialize feff82
c
c Revision 1.10  1999/04/02 21:32:47  newville
c cleaned up nxtunt (matt)
c
c Revision 1.9  1999/02/11 20:08:08  alex
c x39 version: dim.h + misc. small changes
c
c Revision 1.8  1998/12/29 23:59:07  alex
c feff8x35 version
c
c Revision 1.7  1998/11/19 03:23:11  alex
c feff8x32 version
c
c Revision 1.6  1998/10/26 14:11:16  ravel
c no comments beyond column 71
c
c Revision 1.5  1998/10/18 21:47:51  alex
c feff8x30 version implements Broyden algorithm for self-consistency
c
c Revision 1.4  1998/02/24 18:31:37  ravel
c I should really be more careful.  This is the last commitment done
c      cright.
c
c Revision 1.1.1.1  1997/04/27 20:18:03  ravel
c Initial import of xanes sources, version 0.37
c
c Revision 1.1  1996/06/23 16:05:02  bruce
c Initial revision
c

       integer iunit
       logical open

       nxtunt = max(1, iunit) - 1
 10    continue
       nxtunt = nxtunt + 1
       if ((nxtunt.eq.5).or.(nxtunt.eq.6)) nxtunt = 7
       inquire (unit=nxtunt, opened=open)
       if (open) go to 10
       return
c  end integer function nxtunt
       end

c====================================================================
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 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={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      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
         call par_stop('pijump')
      endif

      ph = old + xph(isave)

      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*80 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 rdpot ( ntitle, title, rnrmav, xmu, vint, rhoint,
     1                  emu, s02, erelax, wp, ecv,rs,xf, qtotel, 
     2                  imt, rmt, inrm, rnrm, folp, folpx, xnatph,
     3                  dgc0, dpc0, dgc, dpc, adgc, adpc,
     3                  edens, vclap, vtot, edenvl, vvalgs, dmag, xnval,
     4                  eorb, kappa, iorb, qnrm, xnmues, nohole, ihole,
     5                  inters, totvol, iafolp, xion, iunf, iz, jumprm)
c  opens pot.bin file and reads following information
c  General:
c     ntitle - number of title lines
c     title  - title itself
c     emu    - edge position (x-ray energy for final state at Fermi level)
c  Muffin-tin geometry
c     rmt    - muffin-tin radii
c     imt    - index of radial grid just below muffin-tin radii
c     rnrm   - Norman radii
c     inrm   - index of radial grid just below Norman radii
c     rnrmav - average Norman radius
c     folp   - overlap parameter for rmt
c     folpx  - maximum value for folp
c     xnatph - number of atoms of each potential type
c  Atomic orbitals info (Dirac spinors)
c     dgc0   - upper component for initial orbital
c     dpc0   - lower component for initial orbital
c     dgc    - upper components for all atomic orbitals
c     dpc    - lower components for all atomic orbitals
c     adgc   - development coefficient for upper components
c     adpc   - development coefficient for lower components
c     xnval  - number of valence electrons for each atomic orbital
c              used for core-valence separation and non-local exchange
c     eorb  - atomic enrgy of each orbital for the absorber
c  Electron density information 
c     rhoint - interstitial density
c     rs     - r_s estimate from rhoint (4/3 r_s**3 * rhoint = 1)
c     xf     - estimate of momentum at Fermi level from rhoint
c     edens  - total electron density
c     edenvl - density from valence electrons
c     dmag   - density for spin-up minus density for spin-down
c     qtotel - total charge of a cluster
c     qnrm   - charge accumulated inside Norman sphere as result of SCF
c     xnmues - occupation numbers of valence orbitals from SCF procedure
c  Potential information
c     xmu    - Fermi level position
c     ecv    - core-valence separation energy
c     vint   - muffin-tin zero energy (interstitial potential)
c     vclap  - Coulomb potential
c     vtot   - vclap + xc potential from edens
c     vvalgs - vclap + xc potential from edenvl (EXCHANGE 5 model)
c  Specific data for convolution with excitation spectrum (see mbconv)
c     s02    - many body reduction factor S_0^2 
c     erelax - estimate of relaxation energy = efrozen - emu, where
c              efrozen is edge position estimate from Koopmans theorem
c     wp     - estimate of plasmon frequency from rhoint

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension imt(0:nphx), rmt(0:nphx), inrm(0:nphx),  rnrm(0:nphx)
      dimension folp(0:nphx), folpx(0:nphx), dgc0(251), dpc0(251)
      dimension dgc(251, 30, 0:nphx), dpc(251, 30, 0:nphx)
      dimension adgc(10, 30, 0:nphx), adpc(10, 30, 0:nphx)
      dimension edens(251, 0:nphx), vclap(251, 0:nphx)
      dimension vtot(251, 0:nphx), edenvl(251, 0:nphx)
      dimension vvalgs(251, 0:nphx), dmag(251, 0:nphx)
      dimension xnval(30,0:nphx), qnrm(0:nphx), xnmues(0:lx,0:nphx)
      dimension eorb(30), kappa(30)
      dimension iorb(-4:3,0:nphx), iz(0:nphx), xion(0:nphx)
      dimension xnatph(0:nphx)

      character*80 title(nheadx)

      dimension dum(13)

  10  format(a)
   20 format (bn, i15)

      open (unit=3, file='pot.bin', status='old')
      read(3,30) ntitle, nph, npadx, nohole, ihole, inters, iafolp,
     1            jumprm, iunf
  30  format(9(1x,i4))
c     nph and npadx are not passed to calling subroutine
      do 133  i  = 1, ntitle
         read(3,10) title(i)
         call triml(title(i))
  133 continue
c     Misc double precision stuff from pot.bin
      call rdpadd(3, npadx, dum(1), 13)
      rnrmav = dum(1)
      xmu    = dum(2)
      vint   = dum(3)
      rhoint = dum(4)
      emu    = dum(5)
      s02    = dum(6)
      erelax = dum(7)
      wp     = dum(8)
      ecv    = dum(9)
      rs     = dum(10)
      xf     = dum(11)
      qtotel = dum(12)
      totvol = dum(13)

c     read imt
      read (3, 40) (imt(i),i=0,nph)
  40  format(20(1x,i4))
      call rdpadd(3, npadx, rmt(0), nph+1)
c     read inrm
      read (3, 40) (inrm(i),i=0,nph)
      read (3, 40) (iz(i),i=0,nph)
      read (3, 40) (kappa(i),i=1,30)
      call rdpadd(3, npadx, rnrm(0), nph+1)
      call rdpadd(3, npadx, folp(0), nph+1)
      call rdpadd(3, npadx, folpx(0), nph+1)
      call rdpadd(3, npadx, xnatph(0), nph+1)
      call rdpadd(3, npadx, xion(0), nph+1)
      call rdpadd(3, npadx, dgc0(1), 251)
      call rdpadd(3, npadx, dpc0(1), 251)
      call rdpadd(3, npadx, dgc(1,1,0), 251*30*(nph+1) )
      call rdpadd(3, npadx, dpc(1,1,0), 251*30*(nph+1) )
      call rdpadd(3, npadx, adgc(1,1,0), 10*30*(nph+1) )
      call rdpadd(3, npadx, adpc(1,1,0), 10*30*(nph+1) )
      call rdpadd(3, npadx, edens(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, vclap(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, vtot(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, edenvl(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, vvalgs(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, dmag(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, xnval(1,0), 30*(nph+1) )
      call rdpadd(3, npadx, eorb(1), 30)
      do 50 iph=0,nph
 50   read (3, 60) (iorb(i,iph),i=-4,3)
 60   format(8(1x,i2))
      call rdpadd(3, npadx, qnrm(0), nph+1 )
      nn = (lx+1)*(nph+1)
      call rdpadd(3, npadx, xnmues(0,0), nn )
      close (unit=3)

      return
      end
      subroutine rdxsph ( ne, ne1, ne3, nph, ihole, rnrmav,xmu,edge,
     1               ik0, em, eref, iz, potlbl, ph, rkk, lmax, lmaxp1)
      implicit double precision (a-h, o-z)
c     reads file 'phase.bin' 
c  Energy grid information
c     em   - complex energy grid
c     eref - V_int + i*gamach/2 + self-energy correction
c     ne   - total number of points in complex energy grid
c     ne1  - number of points on main horizontal axis
c     ne2  - number of points on vertical vertical axis ne2=ne-ne1-ne3
c     ne3  - number of points on auxilary horizontal axis (need for f')
c     xmu  - Fermi energy
c     edge - x-ray frequency for final state at Fermi level
c     ik0  - grid point index at Fermi level
c  Potential type information
c     nph - number of potential types
c     iz  - charge of nuclei (atomic number)
c     potlbl - label for each potential type
c     lmax - max orb momentum for each potential type
c     ihole - index of core-hole orbital for absorber (iph=0)
c     rnrmav - average Norman radius (used in headers only)
c  Main output of xsect and phases module (except that in xsect.bin)
c     ph  - complex scattering phase shifts
c     rkk - complex multipole matrix elements

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      character*6  potlbl
      dimension  potlbl(0:nphx)

      complex*16 ph(nex,-ltot:ltot,nspx,0:nphx), eref(nex,nspx), em(nex)
      complex*16 rkk(nex,8,nspx)
      dimension lmax0(0:nphx), lmax(nex,0:nphx)
      dimension iz(0:nphx)
c     kinit, linit, ilinit,  - initial state kappa and ang. mom.
c     lmaxp1  -largest lmax in problem + 1

c     phmin is min value to use for |phase shift|
      parameter (phmin = 1.0d-7)

c     Local staff
c     use temp to write ph, rkk, since ne < nex
      complex*16 temp(nex*(2*ltot+1))
      dimension dum(3)

      open (unit=1, file='phase.bin', status='old', iostat=ios)
      call chopen (ios, 'phase.bin', 'rdxsph')

      read(1,10) nsp, ne, ne1, ne3, nph, ihole, ik0, npadx
  10  format (8(1x,i4))

      call rdpadd(1, npadx, dum(1), 3)
      rnrmav = dum(1)
      xmu    = dum(2)
      edge   = dum(3)

      call rdpadx(1, npadx, em(1), ne)
c     call rdpadx(1, npadx, eref(1), ne)
      call rdpadx (1, npadx, temp(1), ne*nsp)
      ii = 0
      do 60 isp = 1, nsp
      do 60 ie=1, ne
        ii = ii + 1
        eref (ie, isp) = temp(ii)
  60  continue

      do 80  iph = 0, nph
         read(1, 20)  lmax0(iph), iz(iph), potlbl(iph)
  20     format(2(1x,i3), 1x, a6)

         do 75 isp = 1,nsp 
            ii = ne * (2*lmax0(iph)+1)
            call rdpadx (1, npadx, temp(1), ii )
            ii = 0
            do 70  ie = 1, ne
            do 70  ll = -lmax0(iph), lmax0(iph)
               ii = ii+ 1
               ph(ie,ll,isp,iph) = temp(ii)
   70       continue
   75    continue
   80 continue

      call rdpadx (1, npadx, temp(1), ne*8*nsp)
      ii = 0
      do 90 isp = 1,nsp 
      do 90 kdif = 1, 8
      do 90 ie=1, ne
        ii = ii + 1
        rkk (ie, kdif, isp) = temp(ii)
  90  continue

      close (unit=1)

c     make additional data for output
      lmaxp1 = 0
      do 180  iph = 0, nph
      do 180  ie = 1, ne
c        Set lmax to include only non-zero phases
         do 160  il =  lmax0(iph), 0, -1
            lmax(ie,iph) = il
            if (abs(sin(ph(ie, il, 1, iph))) .gt. phmin .or.
     3          abs(sin(ph(ie, il,nsp,iph))) .gt. phmin)  goto 161
  160    continue
  161    continue
         if (lmax(ie,iph)+1 .gt. lmaxp1)  lmaxp1 = lmax(ie,iph)+1
  180 continue

      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
         call par_stop('invalid hole number in setkap')
      endif

      return
      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 UNTAB (STRING)
C REPLACE TABS WITH BLANKS :    TAB IS ASCII DEPENDENT
      INTEGER        ITAB , I, ILEN, ISTRLN
      PARAMETER      (ITAB = 9)
      CHARACTER*(*)  STRING, TAB*1
      EXTERNAL ISTRLN
      TAB  = CHAR(ITAB)
      ILEN = MAX(1, ISTRLN(STRING))
 10   CONTINUE 
        I = INDEX(STRING(:ILEN), TAB ) 
        IF (I .NE. 0) THEN
            STRING(I:I) = ' '
            GO TO 10
        END IF
      RETURN
C END SUBROUTINE UNTAB
      END

      logical function iscomm (line)
c     returns true if line is a comment or blank line, false otherwise
c#mn{ rewritten to allow ";*%#" as comment characters
       character*(*) line
       iscomm = ((line.eq.' ').or.(index(';*%#',line(1:1)).ne.0))
c#mn}
      return
      end
      subroutine str2dp(str,dpval,ierr)
c  return dp number "dpval" from character string "str"
c  if str cannot be a number, ierr < 0 is returned.
      character*(*) str, fmt*15 
      double precision dpval
      integer  ierr , lenmax
      parameter ( lenmax = 40)
      logical  isnum
      external isnum
      ierr = -99
      if (isnum(str)) then
         ierr = 0
         write(fmt, 10) min(lenmax, len(str))
 10      format('(bn,f',i3,'.0)')
         read(str, fmt, err = 20, iostat=ierr) dpval
      end if    
      if (ierr.gt.0) ierr = -ierr
      return
 20   continue
      ierr = -98
      return
c end subroutine str2dp
      end
      subroutine str2re(str,val,ierr)
c  return real from character string "str"
      character*(*) str 
      double precision dpval
      real     val
      integer  ierr
      call str2dp(str,dpval,ierr)
      if (ierr.eq.0) val = dpval
      return
c end subroutine str2re
      end
      subroutine str2in(str,intg,ierr)
c  return integer from character string "str"
c  returns ierr = 1 if value was clearly non-integer
      character*(*) str 
      double precision val, tenth
      parameter (tenth = 1.d-1)
      integer  ierr, intg
      call str2dp(str,val,ierr)
      if (ierr.eq.0) then
         intg = int(val)
         if ((abs(intg - val) .gt. tenth))  ierr = 1
       end if
      return
c end subroutine str2in
      end
       logical function isnum (string)
c  tests whether a string can be a number. not foolproof!
c  to return true, string must contain:
c    - only characters in  'deDE.+-, 1234567890' (case is checked)
c    - no more than one 'd' or 'e' 
c    - no more than one '.'
c  matt newville
       character*(*)  string,  number*20
c note:  layout and case of *number* is important: do not change!
       parameter (number = 'deDE.,+- 1234567890')
       integer   iexp, idec, i, j, istrln
       external  istrln
       iexp  = 0
       idec  = 0
       isnum = .false. 
       do 100  i = 1, max(1, istrln(string))
          j = index(number,string(i:i))
          if (j.le.0)               go to 200
          if((j.ge.1).and.(j.le.4)) iexp = iexp + 1
          if (j.eq.5)               idec = idec + 1
 100   continue
c  every character in "string" is also in "number".  so, if there are 
c  not more than one exponential and decimal markers, it's a number
       if ((iexp.le.1).and.(idec.le.1)) isnum = .true.
 200   continue
       return
c  end logical function isnum
       end
      subroutine wlog (string)
      character*(*) string

c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

c     This output routine is used 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)

c     Suppress output in sequential loops
      if (par_type .eq. 2) return

      il = istrln (string)
      if (il .eq. 0)  then
         print10
         if (par_type .ne. 3) write(11,10)
      else
         print10, string(1:il)
         if (par_type .ne. 3) 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
      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
c
c PAD library:   Packed Ascii Data 
c   these routines contain code for handling packed-ascii-data  
c   (pad) arrays for writing printable character strings that 
c   represent real or complex scalars and arrays to a file.
c
c routines included in padlib are (dp==double precision):
c   wrpadd     write a dp array as pad character strings
c   wrpadx     write a dp complex array as pad character strings
c   rdpadr     read a pad character array as a real array
c   rdpadd     read a pad character array as a dp  array
c   rdpadc     read a pad character array as a complex array
c   rdpadx     read a pad character array as a dp complex array
c   pad        internal routine to convert dp number to pad string
c   unpad      internal routine to pad string to dp number
c
c routines not included, but required by padlib:
c     triml, istrln, wlog
c
c//////////////////////////////////////////////////////////////////////
c Copyright (c) 1997--2001 Matthew Newville, The University of Chicago
c Copyright (c) 1992--1996 Matthew Newville, University of Washington
c
c Permission to use and redistribute the source code or binary forms of
c this software and its documentation, with or without modification is
c hereby granted provided that the above notice of copyright, these
c terms of use, and the disclaimer of warranty below appear in the
c source code and documentation, and that none of the names of The
c University of Chicago, The University of Washington, or the authors
c appear in advertising or endorsement of works derived from this
c software without specific prior written permission from all parties.
c
c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
c EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
c IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
c CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
c TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
c SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
c//////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
       subroutine wrpadd(iout,npack,array,npts)
c
c write a dp array to a file in packed-ascii-data format
c
c inputs:  [ no outputs / no side effects ]
c   iout   unit to write to (assumed open)
c   npack  number of characters to use (determines precision)
c   array  real array 
c   npts   number of array elements to read
c notes:
c   real number converted to packed-ascii-data string using pad
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer    iout, npack, npts, mxl, js, i
       character  str*128
       double precision array(*), xr
       js  = 0
       str = ' '
       mxl = maxlen - npack + 1
       do 20 i = 1, npts
          js = js+npack
          xr = array(i)
          call pad(xr, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadr, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
c --padlib--
       subroutine wrpadx(iout,npack,array,npts)
c write complex*16 array as pad string
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer    iout, npack, npts, mxl, js, i
       complex*16 array(*)
       character  str*128
       double precision xr, xi
       js = 0
       str  = ' '
       mxl  = maxlen - 2 * npack + 1
       do 20 i = 1, npts
          js = js  + 2 * npack
          xr = dble(array(i))
          xi = dimag(array(i))
          call pad(xr, npack, str(js-2*npack+1:js-npack))
          call pad(xi, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadc, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
c --padlib--
       subroutine wrpadr(iout,npack,array,npts)
c
c write a real array to a file in packed-ascii-data format
c
c inputs:  [ no outputs / no side effects ]
c   iout   unit to write to (assumed open)
c   npack  number of characters to use (determines precision)
c   array  real array 
c   npts   number of array elements to read
c notes:
c   real number converted to packed-ascii-data string using pad
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer    iout, npack, npts, mxl, js, i
       character  str*128
       real    array(*)
       double precision xr
       js  = 0
       str = ' '
       mxl = maxlen - npack + 1
       do 20 i = 1, npts
          js = js+npack
          xr = dble(array(i))
          call pad(xr, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadr, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
c --padlib--
       subroutine wrpadc(iout,npack,array,npts)
c write complex (*8) array as pad string
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer    iout, npack, npts, mxl, js, i
       complex    array(*)
       character  str*128
       double precision xr, xi
       js = 0
       str  = ' '
       mxl  = maxlen - 2 * npack + 1
       do 20 i = 1, npts
          js = js  + 2 * npack
          xr = dble(array(i))
          xi = aimag(array(i))
          call pad(xr, npack, str(js-2*npack+1:js-npack))
          call pad(xi, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadc, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
c --padlib--
       subroutine rdpadd(iou,npack,array,npts)
c read dparray from packed-ascii-data file
c arguments:
c   iou    unit to read from (assumed open)                   (in)
c   npack  number of characters to use (determines precision) (in)
c   array  real array                                         (out)
c   npts   number of array elements to read / number read     (in/out)
c notes:
c   packed-ascii-data string converted to real array using  unpad
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer iou, npack, npts, ndline, i, istrln, ipts, iread
       double precision    array(*), unpad , tmp
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadr
       ipts = 0
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i/npack
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts  = ipts + 1
             tmp   = unpad(str(1-npack+i*npack:i*npack),npack)
             array(ipts) = tmp
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end
c --padlib--
       subroutine rdpadr(iou,npack,array,npts)
c read real array from packed-ascii-data file
c arguments:
c   iou    unit to read from (assumed open)                   (in)
c   npack  number of characters to use (determines precision) (in)
c   array  real array                                         (out)
c   npts   number of array elements to read / number read     (in/out)
c notes:
c   packed-ascii-data string converted to real array using  unpad
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer iou, npack, npts, ndline, i, istrln, ipts, iread
       real    array(*)
       double precision unpad , tmp
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadr
       ipts = 0
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i/npack
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts  = ipts + 1
             tmp   = unpad(str(1-npack+i*npack:i*npack),npack)
             array(ipts) = real(tmp)
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end
c --padlib--
       subroutine rdpadc(iou,npack,array,npts)
c read complex array from packed-ascii-data file
c arguments:
c   iou    unit to read from (assumed open)                  (in)
c   npack  number of characters to use (determines precision)(in)
c   array  complex array                                     (out)
c   npts   number of array elements to read / number read    (in/out)
c notes:
c   packed-ascii-data string converted to real array using  unpad
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer iou, npack,npts, ndline, i, istrln, ipts, np, iread
       double precision  unpad, tmpr, tmpi
       complex  array(*)
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadc
       ipts = 0
       np   = 2 * npack
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i / np
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts = ipts + 1
             tmpr = unpad(str(1-np+i*np:-npack+i*np),npack)
             tmpi = unpad(str(1-npack+i*np:i*np),npack)
             array(ipts) = cmplx(tmpr, tmpi)
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end
       subroutine rdpadx(iou,npack,array,npts)
c read complex*16 array from packed-ascii-data file
c arguments:
c   iou    unit to read from (assumed open)                  (in)
c   npack  number of characters to use (determines precision)(in)
c   array  complex array                                     (out)
c   npts   number of array elements to read / number read    (in/out)
c notes:
c   packed-ascii-data string converted to real array using  unpad
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer iou, npack,npts, ndline, i, istrln, ipts, np, iread
       double precision  unpad, tmpr, tmpi
       complex*16  array(*)
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadc
       ipts = 0
       np   = 2 * npack
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i / np
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts = ipts + 1
             tmpr = unpad(str(1-np+i*np:-npack+i*np),npack)
             tmpi = unpad(str(1-npack+i*np:i*np),npack)
             array(ipts) = cmplx(tmpr, tmpi)
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end

c --padlib--
       subroutine pad(xreal,npack,str)
c  convert dp number *xreal* to packed-ascii-data string *str*
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       integer  iexp, itmp, isgn, i, npack, j
       double precision xreal, xwork, xsave,onem, tenth
       parameter (onem  =  0.99999999997d0)
       parameter (tenth =  0.099999999994d0)
       character str*(*)
c
       str      = ' '
       xsave    = min(huge, max(-huge, xreal))
       isgn     = 1
       if (xsave.le.0) isgn = 0
c
       xwork    = dabs( xsave )
       iexp     = 0
       if ((xwork.lt.huge).and.(xwork.gt.tiny))  then
          iexp  =   1 + int(log(xwork) / tenlog  )
       else if (xwork.ge.huge) then
          iexp  = ihuge
          xwork = one
       else if (xwork.le.tiny)  then
          xwork = zero
       end if
c force xwork between ~0.1 and ~1
c note: this causes a loss of precision, but 
c allows backward compatibility
       xwork    = xwork / (ten ** iexp)
 20    continue
       if (xwork.ge.one) then
          xwork = xwork * 0.100000000000000d0
          iexp  = iexp + 1
       else if (xwork.le.tenth) then
          xwork = xwork * ten
          iexp  = iexp - 1
       endif
       if (xwork.ge.one) go to 20

       itmp     = int ( ibas2 * xwork ) 
       str(1:1) = char(iexp  + ioff + ibas2 )
       str(2:2) = char( 2 * itmp + isgn + ioff)
       xwork    = xwork * ibas2 - itmp
       if (npack.gt.2) then
          do 100 i = 3, npack
             itmp     = int( base * xwork + 1.d-9)
             str(i:i) = char(itmp + ioff)
             xwork    = xwork * base - itmp
 100      continue
       end if
       if (xwork.ge.0.5d0) then
          i = itmp + ioff + 1
          if (i.le.126) then
             str(npack:npack)= char(i)
          else 
             j = ichar(str(npack-1:npack-1))
             if (j.lt.126) then
                str(npack-1:npack-1) = char(j+1)
                str(npack:npack)     = char(37)
             endif 
          endif
       endif
       return
       end
c --padlib--
       double precision function unpad(str,npack)
c
c  convert packed-ascii-data string *str* to dp number *unpad*
c={padlib.h
c padlib.h -*-fortran-*-
c  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
c
c= padlib.h}
       double precision sum
       integer   iexp, itmp, isgn, i, npack
       character str*(*)
       unpad = zero
       if (npack.le.2) return
       iexp  =     (ichar(str(1:1)) - ioff   ) - ibas2
       isgn  = mod (ichar(str(2:2)) - ioff, 2) * 2 - 1
       itmp  =     (ichar(str(2:2)) - ioff   ) / 2
       sum   = dble(itmp/(base*base))
c       do 100 i = 3, npack
c          sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
c 100   continue
       do 100 i = npack, 3, -1
          sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
 100   continue
       unpad = 2 * isgn * ibase * sum * (ten ** iexp)
cc       print*, sum, iexp,unpad
       return
       end
c --padlib--
c end of pad library
c ----------
       integer function iread(lun,string)
c
c generalized internal read:
c    read a string the next line of an opened file 
c    unit, returning the real length of string
c 
c inputs:   
c   lun     opened file unit number
c outputs:
c   string  string read from file
c returns:
c   iread   useful length of string, as found from 
c                  sending string to 'sclean' to 
c                  remove non-printable characters
c                   and then istrln  
c           or
c              -1   on 'end-of-file'
c              -2   on 'error'
c
c copyright (c) 1999  Matthew Newville
       implicit none
       character*(*) string
       integer    lun, istrln
       external   istrln
       string = ' '
 10    format(a)
       read(lun, 10, end = 40, err = 50) string
       call sclean(string)
       iread = istrln(string)
       return
 40    continue 
       string = ' '
       iread = -1
       return
 50    continue 
       string = ' '
       iread = -2
       return
       end
       subroutine sclean(str) 
c
c  clean a string, especially for strings passed between 
c  different file systems, or from C functions:
c
c   1. characters in the range char(0), or char(10)...char(15) 
c      are interpreted as end-of-line characters, so that all
c      remaining characters are explicitly blanked.
c   2. all other characters below char(31) (including tab) are
c      replaced by a single blank
c
c  this is mostly useful when getting a string generated by a C 
c  function and for handling dos/unix/max line-endings.
c
c copyright (c) 1999  Matthew Newville
       character*(*) str, blank*1
       parameter (blank = ' ')
       integer i,j,is
       do 20 i = 1, len(str)
          is = ichar(str(i:i))
          if ((is.eq.0) .or. ((is.ge.10) .and. (is.le.15))) then
             do 10 j= i, len(str)
                str(j:j) = blank
 10          continue
             return
          elseif (is.le.31)  then
             str(i:i)  = blank
          end if
 20    continue 
       return
c end subroutine sclean
       end

      SUBROUTINE rdcmt(iUnt,Cmt)
      INTEGER iUnt, i1
      CHARACTER(300) line
      CHARACTER(4) Cmt
      CHARACTER TmpCmt(4), ch
      LOGICAL CmtLin

      CmtLin = .true.
      DO i1 = 1, 4
         TmpCmt(i1) = Cmt(i1:i1)
      END DO
 5    CONTINUE
      READ(iUnt,*,END=10) ch
      DO i1 = 1, 4
         IF(ch.eq.TmpCmt(i1)) goto 5
      END DO
      
      BACKSPACE(iUnt)
      
 10   CONTINUE
      
      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.
c     output gamach is in eV

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

      dimension zh(8,16), gamh(8,16)

      dimension zk(8), gamkp(8)
      parameter (ryd  = 13.605 698d0)
      parameter (hart = 2*ryd)
      character*512 slog


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  zh   / 0.99,  10.0, 20.0, 40.0, 50.0, 60.0, 80.0, 95.1,
     2              0.99, 18.0, 22.0, 35.0, 50.0, 52.0, 75.0,  95.1,
     3              0.99,  17.0, 28.0, 31.0, 45.0, 60.0,  80.0, 95.1,
     4              0.99,  17.0, 28.0, 31.0, 45.0, 60.0,  80.0, 95.1,
     5              0.99,  20.0, 28.0, 30.0, 36.0, 53.0,  80.0, 95.1,
     6              0.99,  20.0, 22.0, 30.0, 40.0, 68.0,  80.0, 95.1,
     7              0.99,  20.0, 22.0, 30.0, 40.0, 68.0,  80.0, 95.1,
     8              0.99,  36.0, 40.0, 48.0, 58.0, 76.0,  79.0, 95.1,
     9              0.99,  36.0, 40.0, 48.0, 58.0, 76.0,  79.0, 95.1,
     *              0.99,  30.0, 40.0, 47.0, 50.0, 63.0,  80.0, 95.1,
     1              0.99,  40.0, 42.0, 49.0, 54.0, 70.0,  87.0, 95.1,
     2              0.99,  40.0, 42.0, 49.0, 54.0, 70.0,  87.0, 95.1,
     3              0.99,  40.0, 50.0, 55.0, 60.0, 70.0,  81.0, 95.1,
     4              0.99,  40.0, 50.0, 55.0, 60.0, 70.0,  81.0, 95.1,
     5              0.99,  71.0, 73.0, 79.0, 86.0, 90.0,  95.0,100.0,
     6              0.99,  71.0, 73.0, 79.0, 86.0, 90.0,  95.0,100.0/

      data  gamh / 0.02,  0.28, 0.75,  4.8, 10.5, 21.0, 60.0, 105.0,
     2              0.07,  3.9,  3.8,  7.0,  6.0,  3.7,  8.0,  19.0,
     3              0.001, 0.12,  1.4,  0.8,  2.6,  4.1,   6.3, 10.5,
     4              0.001, 0.12, 0.55,  0.7,  2.1,  3.5,   5.4,  9.0,
     5              0.001,  1.0,  2.9,  2.2,  5.5, 10.0,  22.0, 22.0,
     6              0.001,0.001,  0.5,  2.0,  2.6, 11.0,  15.0, 16.0,
     7              0.001,0.001,  0.5,  2.0,  2.6, 11.0,  10.0, 10.0,
     8              0.0006,0.09, 0.07, 0.48,  1.0,  4.0,   2.7,  4.7,
     9              0.0006,0.09, 0.07, 0.48, 0.87,  2.2,   2.5,  4.3,
     *              0.001,0.001,  6.2,  7.0,  3.2, 12.0,  16.0, 13.0,
     1              0.001,0.001,  1.9, 16.0,  2.7, 13.0,  13.0,  8.0,
     2              0.001,0.001,  1.9, 16.0,  2.7, 13.0,  13.0,  8.0,
     3              0.001,0.001, 0.15,  0.1,  0.8,  8.0,   8.0,  5.0,
     4              0.001,0.001, 0.15,  0.1,  0.8,  8.0,   8.0,  5.0,
     5              0.001,0.001, 0.05, 0.22,  0.1, 0.16,   0.5,  0.9,
     6              0.001,0.001, 0.05, 0.22,  0.1, 0.16,   0.5,  0.9/

c     Since feff8 can be called any number of times . ALA

      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. 16)  then
         call wlog(' This version of FEFF will set gamach = 0.1 eV ' //
     1             ' for O1 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. 16)  then
         do 10  i = 1, 8
            gamkp(i) = log10 (gamh(i,ihole))
            zk(i) = zh(i,ihole)
   10    continue
         call terp (zk, gamkp, 8, 1, zz, gamach)
      else
c     include data from the tables later.
c     Now gamach=0.1eV for any O-hole for any element.
         gamach = -1.0
      endif

c     Change from log10 (gamma) to gamma
      gamach = 10.0 ** gamach


      return
      end
      subroutine iniptz(ptz,iptz,modus)
        !KJ This routine rewrites the ptz-matrix.

      implicit none
c     which polarization tensor to create      
      integer iptz
c     two ways of working
      integer modus
c     the polarization tensor
      complex*16 ptz(-1:1,-1:1)

      complex*16 zero,one,coni
      parameter (zero=(0,0),one=(1,0),coni=(0,1))
      integer i,j
      real*8 unity(3,3)



      if (iptz.lt.1.or.iptz.gt.10) then
          call wlog('Inieln sees weird iptz - returns without 
     1      changing ptz - danger of calculating nonsense !!')
      endif


      do i=1,3
      do j=1,3
	unity(i,j)=dble(0)
      enddo
      unity(i,i)=dble(1)/dble(3)
      enddo
      do i=-1,1
      do j=-1,1
        ptz(i,j)=zero
      enddo
      enddo
      

      if (modus.eq.1) then
! work in spherical coordinates

         if(iptz.eq.10) then
        do i=-1,1
	do j=-1,1
	   ptz(i,j)=unity(i+2,j+2)
        enddo
	enddo
         else
            i=(iptz-1)/3+1  ! row index
            j=iptz-3*(i-1)  ! column index
            i=i-2 !shift from 1..3 to -1..1
            j=j-2
            ptz(i,j)=one
         endif  


      elseif(modus.eq.2) then
! work in carthesian coordinates      

      if (iptz.eq.10) then ! orientation averaged spectrum
        do i=-1,1
	do j=-1,1
	   ptz(i,j)=unity(i+2,j+2)
        enddo
	enddo
	
        elseif (iptz.eq.1) then   ! x x*
          ptz(1,1)=one/dble(2)
        ptz(-1,-1)=one/dble(2)
        ptz(-1,1)=-one/dble(2)
        ptz(1,-1)=-one/dble(2)
        elseif (iptz.eq.5) then ! y y*
          ptz(1,1)=one/dble(2)
        ptz(-1,-1)=one/dble(2)
        ptz(-1,1)=one/dble(2)
        ptz(1,-1)=one/dble(2)
         elseif (iptz.eq.9) then ! z z*
        ptz(0,0)=one
        elseif (iptz.eq.2) then ! x y*
          ptz(1,1)=one*coni/dble(2)
        ptz(-1,-1)=-one*coni/dble(2)
        ptz(-1,1)=-one*coni/dble(2)
        ptz(1,-1)=one*coni/dble(2)
        elseif (iptz.eq.4) then ! x* y
          ptz(1,1)=-one*coni/dble(2)
        ptz(-1,-1)=one*coni/dble(2)
        ptz(-1,1)=-one*coni/dble(2)
        ptz(1,-1)=one*coni/dble(2)
        elseif (iptz.eq.3) then ! x z*
          ptz(-1,0)=one/dsqrt(dble(2))
        ptz(1,0)=-one/dsqrt(dble(2))
        elseif (iptz.eq.7) then ! x* z
          ptz(0,-1)=one/dsqrt(dble(2))
        ptz(0,1)=-one/dsqrt(dble(2))
        elseif (iptz.eq.6) then ! y z*
          ptz(-1,0)=-one*coni/dsqrt(dble(2))
        ptz(1,0)=-one*coni/dsqrt(dble(2))
        elseif (iptz.eq.8) then ! y* z
          ptz(0,-1)=one*coni/dsqrt(dble(2))
        ptz(0,1)=one*coni/dsqrt(dble(2))
      endif
      
      
        else
          stop 'alien modus in inieln'
        endif


      return
      end


C From HDK@psuvm.psu.edu Thu Dec  8 15:27:16 MST 1994
C 
C The following was converted from Algol recursive to Fortran iterative
C by a colleague at Penn State (a long time ago - Fortran 66, please
C excuse the GoTo's). The following code also corrects a bug in the
C Quicksort algorithm published in the ACM (see Algorithm 402, CACM,
C Sept. 1970, pp 563-567; also you younger folks who weren't born at
C that time might find interesting the history of the Quicksort
C algorithm beginning with the original published in CACM, July 1961,
C pp 321-322, Algorithm 64). Note that the following algorithm sorts
C integer data; actual data is not moved but sort is affected by sorting
C a companion index array (see leading comments). The data type being
C sorted can be changed by changing one line; see comments after
C declarations and subsequent one regarding comparisons(Fortran
C 77 takes care of character comparisons of course, so that comment
C is merely historical from the days when we had to write character
C compare subprograms, usually in assembler language for a specific
C mainframe platform at that time). But the following algorithm is
C good, still one of the best available.


      SUBROUTINE QSORTI (ORD,N,A)
C
C==============SORTS THE ARRAY A(I),I=1,2,...,N BY PUTTING THE
C   ASCENDING ORDER VECTOR IN ORD.  THAT IS ASCENDING ORDERED A
C   IS A(ORD(I)),I=1,2,...,N; DESCENDING ORDER A IS A(ORD(N-I+1)),
C   I=1,2,...,N .  THIS SORT RUNS IN TIME PROPORTIONAL TO N LOG N .
C
C
C     ACM QUICKSORT - ALGORITHM #402 - IMPLEMENTED IN FORTRAN 66 BY
C                                 WILLIAM H. VERITY, WHV@PSUVM.PSU.EDU
C                                 CENTER FOR ACADEMIC COMPUTING
C                                 THE PENNSYLVANIA STATE UNIVERSITY
C                                 UNIVERSITY PARK, PA.  16802
C
      IMPLICIT INTEGER (A-Z)
C
      DIMENSION ORD(N),POPLST(2,20)
      DOUBLE PRECISION X,XX,Z,ZZ,Y
C
C     TO SORT DIFFERENT INPUT TYPES, CHANGE THE FOLLOWING
C     SPECIFICATION STATEMENTS; FOR EXAMPLE, FOR FORTRAN CHARACTER
C     USE THE FOLLOWING:  CHARACTER *(*) A(N)
C
      DOUBLE PRECISION A(N)
C
      NDEEP=0
      U1=N
      L1=1
      DO 1  I=1,N
    1 ORD(I)=I
    2 IF (U1.LE.L1) THEN
         RETURN
      END IF
C
    3 L=L1
      U=U1
C
C PART
C
    4 P=L
      Q=U
C     FOR CHARACTER SORTS, THE FOLLOWING 3 STATEMENTS WOULD BECOME
C     X = ORD(P)
C     Z = ORD(Q)
C     IF (A(X) .LE. A(Z)) GO TO 2
C
C     WHERE "CLE" IS A LOGICAL FUNCTION WHICH RETURNS "TRUE" IF THE
C     FIRST ARGUMENT IS LESS THAN OR EQUAL TO THE SECOND, BASED ON "LEN"
C     CHARACTERS.
C
      X=A(ORD(P))
      Z=A(ORD(Q))
      IF (X.LE.Z) GO TO 5
      Y=X
      X=Z
      Z=Y
      YP=ORD(P)
      ORD(P)=ORD(Q)
      ORD(Q)=YP
    5 IF (U-L.LE.1) GO TO 15
      XX=X
      IX=P
      ZZ=Z
      IZ=Q
C
C LEFT
C
    6 P=P+1
      IF (P.GE.Q) GO TO 7
      X=A(ORD(P))
      IF (X.GE.XX) GO TO 8
      GO TO 6
    7 P=Q-1
      GO TO 13
C
C RIGHT
C
    8 Q=Q-1
      IF (Q.LE.P) GO TO 9
      Z=A(ORD(Q))
      IF (Z.LE.ZZ) GO TO 10
      GO TO 8
    9 Q=P
      P=P-1
      Z=X
      X=A(ORD(P))
C
C DIST
C
   10 IF (X.LE.Z) GO TO 11
      Y=X
      X=Z
      Z=Y
      IP=ORD(P)
      ORD(P)=ORD(Q)
      ORD(Q)=IP
   11 IF (X.LE.XX) GO TO 12
      XX=X
      IX=P
   12 IF (Z.GE.ZZ) GO TO 6
      ZZ=Z
      IZ=Q
      GO TO 6
C
C OUT
C
   13 CONTINUE
      IF (.NOT.(P.NE.IX.AND.X.NE.XX)) GO TO 14
      IP=ORD(P)
      ORD(P)=ORD(IX)
      ORD(IX)=IP
   14 CONTINUE
      IF (.NOT.(Q.NE.IZ.AND.Z.NE.ZZ)) GO TO 15
      IQ=ORD(Q)
      ORD(Q)=ORD(IZ)
      ORD(IZ)=IQ
   15 CONTINUE
      IF (U-Q.LE.P-L) GO TO 16
      L1=L
      U1=P-1
      L=Q+1
      GO TO 17
   16 U1=U
      L1=Q+1
      U=P-1
   17 CONTINUE
      IF (U1.LE.L1) GO TO 18
C
C START RECURSIVE CALL
C
      NDEEP=NDEEP+1
      POPLST(1,NDEEP)=U
      POPLST(2,NDEEP)=L
      GO TO 3
   18 IF (U.GT.L) GO TO 4
C
C POP BACK UP IN THE RECURSION LIST
C
      IF (NDEEP.EQ.0) GO TO 2
      U=POPLST(1,NDEEP)
      L=POPLST(2,NDEEP)
      NDEEP=NDEEP-1
      GO TO 18
C
C END SORT
C END QSORT
C
      END
c///////////////////////////////////////////////////////////////////////
c PAR Subroutines
c Written by J. Sims, NIST, 2001

c This software was developed at the National Institute of Standards
c and Technology by employees of the Federal Government in the course
c of their official duties. Pursuant to title 17 Section 105 of
c the United States Code this software is not subject to copyright
c protection and is in the public domain. PAR is an experimental
c system. NIST assumes no responsibility whatsoever for its use by
c other parties, and makes no guarantees, expressed or implied, about 
c its quality, reliability, or any other characteristic. We would
c appreciate acknowledgement if the software is used.

c This software can be redistributed and/or modified freely provided
c that any derivative works bear some notice that they are derived from
c it, and any modified versions bear some notice that they have been
c modified.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c  **************************************************
c  Parallel feff8 routines
c  Jim Sims
c  **************************************************

      subroutine par_begin
c  **************************************************
c  Initializations for parallel version(s)
c  **************************************************

c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}

c-- So cvd or dbx can attach to a running process
c     call sleep(30) 

      numprocs = 1
      my_rank = 0
      this_process = my_rank

      par_type = 0
      parallel_run = .false.
c-- The following variable will be used for IO that should only be
c-- done in one process.
      master = (my_rank .eq. 0)

      worker = (.not. master)
      if (worker) par_type = 1

      return
      end

      subroutine par_stop (string)
c  **************************************************
c  Abnormal termination of the parallel session
c  **************************************************
c={../HEADERS/parallel.h
      integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm
      common /timing/ wall_comm, time_comm
      common /parallel/ numprocs, my_rank, this_process, 
     .          master, worker, parallel_run, par_type
c= ../HEADERS/parallel.h}
c     For abnormal exits 
c     If open, close unit = 11
c     Go to the barrier that workers are sitting at
c     Then everyone will call par_end and stop
      logical is_open
      character*(*) string

      inquire(unit=11,opened=is_open)
      if (is_open) then
        call wlog(string)
        close(unit=11)
      else if (string .ne. ' ') then
	print *,string
	print *,'Abnormal termination on processor ',this_process
      endif

      stop ' '
      end

      subroutine par_end
c  **************************************************
c  Terminate the parallel session
c  **************************************************
      return
      end

      subroutine par_barrier
c  **************************************************
c  Calls mpi_barrier
c  **************************************************
      return
      end

      subroutine par_send_int(buf,count,dest,tag)
c  **************************************************
c  Call mpi_send for integer arrays
c  **************************************************
      integer count,dest,tag
      integer buf(*)
      return
      end

      subroutine par_send_cmplx(buf,count,dest,tag)
c  **************************************************
c  Call mpi_send for complex arrays
c  **************************************************
      integer count,dest,tag
      complex buf(*)
      return
      end

      subroutine par_send_dc(buf,count,dest,tag)
c  **************************************************
c  Call mpi_send for double_complex arrays
c  **************************************************
      integer count,dest,tag
      complex*16 buf(*)
      return
      end

      subroutine par_recv_int(buf,count,source,tag)
c  **************************************************
c  Call mpi_recv for integer arrays
c  **************************************************
      integer count,source,tag
      integer buf(*)
      return
      end

      subroutine par_recv_cmplx(buf,count,source,tag)
c  **************************************************
c  Call mpi_recv for complex arrays
c  **************************************************
      integer count,source,tag
      complex buf(*)
      return
      end

      subroutine par_recv_dc(buf,count,source,tag)
c  **************************************************
c  Call mpi_recv for double complex arrays
c  **************************************************
      integer count,source,tag
      complex*16 buf(*)
      return
      end

      subroutine par_bcast_int(buf,count,source)
c  **************************************************
c  Call mpi_bcast for integer arrays
c  **************************************************
      integer count,source
      integer buf(*)
      return
      end

      subroutine par_bcast_cmplx(buf,count,source)
c  **************************************************
c  Call mpi_bcast for complex arrays
c  **************************************************
      integer count,source
      complex buf(*)
      return
      end

      subroutine par_bcast_dc(buf,count,source)
c  **************************************************
c  Call mpi_bcast for double_complex arrays
c  **************************************************
      integer count, source
      complex*16 buf(*)
      return
      end

      subroutine MPE_DECOMP1D( n, num_procs, myid, s, e )
c  ******************************************************
c  A routine for producing a decomposition of a 1-d 
c  array when given a number of processors.  It may 
c  be used in "direct" product decomposition.  The 
c  values returned assume a "global" domain in [1:n]
c  ******************************************************
c  MPE_Decomp1d - Compute a balanced decomposition of
c  a 1-D array
c  ******************************************************
c  Input Parameters:
c  n  - Length of the array
c  num_procs - Number of processors in decomposition
c  myid  - Rank of this processor in the decomposition 
c  (0 <= rank < size)
c  ******************************************************
c  Output Parameters:
c  s,e - Array my_particles are s:e, with the original 
c  array considered as 1:n.  
c  ******************************************************

      integer n, num_procs, myid, s, e
      integer nloc, deficit
 
      nloc  = n / num_procs
      s       = myid * nloc + 1
      deficit = mod(n,num_procs)
      s       = s + min(myid,deficit)
      if (myid .lt. deficit) then
        nloc = nloc + 1
      endif
      e = s + nloc - 1
      if (e .gt. n .or. myid .eq. num_procs-1) e = n

      return
      end

      SUBROUTINE SECONDS( W)
c  ***************************************************
c  SECONDS returns the wall clock times for a process
c  in seconds.
c  ***************************************************
 
      REAL*8      W

      W = 0.0

      RETURN
      END
c///////////////////////////////////////////////////////////////////////
c FEFF PROGRAMS (referred below as a System)
c Copyright (c) 1986-2002, University of Washington.
c 
c END-USER LICENSE 
c 
c A signed End-user License Agreement from the University of Washington
c Office of Technology Transfer is required to use these programs and
c subroutines.
c 
c See the URL: http://leonardo.phys.washington.edu/feff/
c 
c USE RESTRICTIONS:
c 
c 1. The End-user agrees that neither the System, nor any of its
c components shall be used as the basis of a commercial product, and
c that the System shall not be rewritten or otherwise adapted to
c circumvent the need for obtaining additional license rights.
c Components of the System subject to other license agreements are
c excluded from this restriction.
c
c 2. Modification of the System is permitted, e.g., to facilitate
c its performance by the End-user. Use of the System or any of its
c components for any purpose other than that specified in this Agreement
c requires prior approval in writing from the University of Washington.
c
c 3. The license granted hereunder and the licensed System may not be
c assigned, sublicensed, or otherwise transferred by the End-user.  
c
c 4. The End-user shall take reasonable precautions to ensure that
c neither the System nor its components are copied, or transferred out
c side of his/her current academic or government affiliated laboratory
c or disclosed to parties other than the End-user.
c 
c 5. In no event shall the End-user install or provide this System
c on any computer system on which the End-user purchases or sells
c computer-related services.
c 
c 6. Nothing in this agreement shall be construed as conferring rights
c to use in advertising, publicity, or otherwise any trademark or the
c names of the System or the UW.   In published accounts of the use or
c application of FEFF the System should be referred to  by this name,
c with an appropriate literature reference:
c 
c FEFF8: A.L. Ankudinov, B. Ravel, J.J. Rehr, and S.D. Conradson,
c        Phys. Rev. B 58, pp. 7565-7576 (1998).
c
c LIMITATION OF LIABILITY:
c
c 1.   THE UW MAKES NO WARRANTIES , EITHER EXPRESSED OR IMPLIED, AS TO
c THE CONDITION OF THE SYSTEM, ITS MERCHANTABILITY, OR ITS FITNESS FOR
c ANY PARTICULAR PURPOSE.  THE END-USER AGREES TO ACCEPT THE SYSTEM
c 'AS IS' AND IT IS UNDERSTOOD THAT THE UW IS NOT OBLIGATED TO PROVIDE
c MAINTENANCE, IMPROVEMENTS, DEBUGGING OR SUPPORT OF ANY KIND.
c
c 2. THE UW SHALL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL,
c INCIDENTAL OR CONSEQUENTIAL DAMAGES SUFFERED BY THE END-USER OR ANY
c OTHER PARTIES FROM THE USE OF THE SYSTEM.
c
c 3.  The End-user agrees to indemnify the UW for liability resulting
c from the use of the System by End-user. The End-user and the UW each
c agree to hold the other harmless for their own negligence.
c
c TITLE:
c
c 1.  Title patent, copyright and trademark rights to the System are
c retained by the UW. The End-user shall take all reasonable precautions
c to preserve these rights.
c 
c 2.  The UW reserves the right to license or grant any other rights to
c the System to other persons or entities.
c///////////////////////////////////////////////////////////////////////
c License is applicable for routines below, until otherwise specified.
c
c     Josh - added argument iPl to control many pole self energy
      subroutine xsectd (ipr2, dx, x0, ri, ne, ne1, ik0, em, edge,
     1                  ihole, emu, corr, dgc0, dpc0, jnew,
     2                  ixc, lreal, rmt, rnrm, xmu,
     2                  vi0, iPl, gamach,
     3                  vtot, vvalgs, vch, edens, dmag, edenvl,
     4                  dgcn, dpcn, adgc, adpc, xsec, xsnorm, rkk,
     5                  iz, xion, iunf, xnval, 
     5                  ipmbse, ifxc, ibasis, eorb, kappa, iorb, l2lp,
     6                  ipol, ispin, le2, angks, ptz, itdlda)

c     right know the same self-energy is used for calculation
c     of the central atom part (xsec) and dipole m.e. for
c     scattering (rkk). You may want to run xsect separately
c     for xsec and for rkk, if you want to use different self-energy
c     for central and scattering parts.  ala. fix later

      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     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     iPl - Josh: added to control many pole self energy
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, 8)  normalized reduced matrix elements for construction
c                 of termination matrix in genfmt.

c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 ptz, conr
      dimension ptz(-1:1, -1:1)
      parameter (conr = (1,0))

      dimension ri(nrptx), vtot(nrptx), edens(nrptx),dmag(nrptx)
      dimension dgc0(nrptx), dpc0(nrptx), vvalgs(nrptx), edenvl(nrptx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension dgcnp(nrptx,30), dpcnp(nrptx,30)
      dimension adgc(10,30), adpc(10,30), xnval(30), iorb(-4:3)
      dimension eorb(30), kappa(30)
      complex*16 rkk(nex, 8), xsec(nex)
      complex*16 bmat(-lx:lx,0:1,8, -lx:lx,0:1,8)
      dimension kind(8), lind(8)
     
      dimension xp(nrptx), xq(nrptx), vch(nrptx)

c     work space for xcpot
      dimension vxcrmu(nrptx), vxcimu(nrptx), gsrel(nrptx)
      dimension vvxcrm(nrptx), vvxcim(nrptx)

c     work space for fovrg
      complex*16 p(nrptx), q(nrptx), pn(nrptx), qn(nrptx)
c     storage for calculation of cross term (SPIN 1 only)
      complex*16 xrcold(nrptx) , xncold(nrptx)

      complex*16  p2, ck
      complex*16  pu, qu, dum1, factor
      complex*16  xfnorm, xirf
      complex*16  aa, bb, cc, rkk1, rkk0, phold
      complex*16  phx(8), ph0
      complex*16  eref, xm1, xm2, xm3, xm4

      complex*16  v(nrptx), vval(nrptx)
      complex*16  xrc(nrptx), xnc(nrptx)
      character*512 slog
      logical ltrace
c     nesvi:  
      complex*16 xrhoce(nex), xrhopr(nex), chia(nex), cchi(nex)
      dimension omega(nex), bf(0:2, nrptx)

      complex*16 xrhoce1(nex), xsec1(nex)
      dimension emr(nex), sfun(nex)
      dimension chil2(nex), chil3(nex)
      dimension chil4(nex), chil5(nex)
      complex*16 em(nex), emx
      dimension pat(nrptx),qat(nrptx)

      parameter (maxsize = 78)
      dimension jinit(maxsize), minit(maxsize)
      dimension jfin(maxsize), mfin(maxsize)
      dimension kinitm(maxsize), kfinm(maxsize), nph(maxsize)
      dimension chi0r(nex,maxsize, maxsize), ncore(maxsize)
      dimension dipmatl(nex,maxsize), dipmat(nex,maxsize)
      dimension chi0im(nex,maxsize, maxsize)
      complex*16 chi0br(nex)
      complex*16 chi0(nex,maxsize, maxsize)
      dimension refsh(maxsize) 
      dimension dml(maxsize), dmdl(maxsize), chi(maxsize, maxsize)
      dimension phf(maxsize)
      complex*16 wmat(nex, maxsize,maxsize), wm(maxsize,maxsize)
      complex*16 xkmat(nex, maxsize,maxsize), xkm(maxsize,maxsize)
      complex*16 xkmatp( maxsize,maxsize, nex)
      complex*16 dipscf(nex,maxsize), temp
      dimension xsnorml3(nex), xsnorml2(nex)
      dimension xsscfl3(nex), xsscfl2(nex)
      dimension xsnorml5(nex), xsnorml4(nex)
      dimension xsscfl5(nex), xsscfl4(nex)
      dimension gammab(maxsize)
      dimension ckl3(nex), ckl2(nex)
      complex*16 dmlbr(nex), dmdlbr(nex)
      complex*16 xl3br(nex), xl2br(nex)
      complex*16 xl5br(nex), xl4br(nex)

c     Josh - Added iPl switch for PLASMON card
c          - and WpCorr = Wi/Wp, Gamma, AmpFac
c          - to describe Im[eps^-1]
      integer iPl, ipole
      double precision WpCorr(MxPole), Gamma(MxPole), AmpFac(MxPole)
c     Josh END      

      call setkap(ihole, kinit, linit)
      if (kinit.ge.0) then
        call wlog('  Initial state kappa should be negative: ')
        call wlog('  E.g.: HOLE K,L3,M5 and  not HOLE L2, M4, etc.')
        stop
      endif
c  begin   manual input
c     set splitting between 2 edges and their lifetimes
c V
c     deltaso = 8.620 /hart
c     gaml2 = 0.458/hart/2.0
c     gaml3 = 0.275/hart/2.0
      call setgam (iz, ihole, gamach)
      gaml3 = gamach / hart / 2.d0
      if (kinit.lt.-1) then
        iholep = ihole - 1
        call setgam (iz, iholep, gamach)
        gaml2 = gamach / hart / 2.d0
      else
        gaml2 = gaml3
      endif
       
c  Co 
c     deltaso = 15.24 /hart
c     gaml2 = 1.120/hart/2.0
c     gaml3 = 0.480/hart/2.0
c  Ni
c     deltaso = 17.5 /hart
c     gaml2 = 1.40/hart/2.0
c     gaml3 = 0.550/hart/2.0
c Diamond
c     deltaso = 0.00/hart
c     gaml2 = 0.087/hart/2.0
c     gaml3 = 0.087/hart/2.0
c Mg
c     gaml2 = 0.34/hart/2.0
c     gaml3 = 0.34/hart/2.0
c  Xe
c     deltaso = 1.96/hart
c     gaml2 = 0.109/hart/2.0
c     gaml3 = 0.109/hart/2.0
c  W  
c     deltaso = 62.2/hart
c     gaml2 = 3.430/hart/2.0
c     gaml3 = 1.985/hart/2.0
c Ta
c     deltaso = 58.1/hart
c     gaml2 = 3.175/hart/2.0
c     gaml3 = 1.885/hart/2.0

c set basis set size for L+1 and L-1 orbitals
      nlp = 3
      nlm = 0
c set number of completely occupied L+1 and L-1 orbitals
c     want to know how many nodes basis w.f. should have
      nlpoc = 1
      nlmoc = 0
c choose the basis
c       choose ibasis = 0 to use occupied orbitals for the basis
c       ibasis = 1 - read basis orbitals from file
c       ibasis = 2 - calculate them by requireing 0 at r_int
c     ibasis = 2
c end of  manual input for xsectd
      if (ibasis.eq.0) then
c       cannot have more than one orbital for projections
        if (nlp .gt. 0) nlp = 1
        if (nlm .gt. 0) nlm = 1
      endif

c     set number of channels (Number of edges involved times number
c     of final l-channels. E.g. for K-edge nch=1, for L2,3 edges with
c     final d only nch=2, with final d,s in basis set nch=4)
      nch = 2
      if (kinit. eq.-1) then
        nch = 1
        nlm = 0
      endif
      if (nlm.gt.0) nch = 4

c     set matrix indices and size
      call getmat(ihole, linit, nlp, nlm, jinit, minit, kinitm,
     1     jfin, mfin, kfinm, ncore, nph, matsize, kappa, xnval, ibasis)
c      nph(im) - index of orbital to project on within basis set
c          if nph>0 index refer to array dgcn(dpcn), i.e.
c          this is one of the partly filled atomic orbitals
c          if nph<0 index refer to array dgcnp(dpcnp) which
c          are calculated by getwf subroutines and represent
c          completely unoccupied orbitals

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)  call par_stop('jri .gt. nrptx in phase')
c     nesvi: define jnrm
c     test - increase rnrm
c      rnrm = rnrm*5
      inrm = (log(rnrm) + x0) / dx + 1
      jnrm = inrm + 1

c     set the cutoff radius for integrations
       rint = rnrm
c      rint = 2.2d0 / bohr
       iint = (log(rint) + x0) / dx + 1
       jint = iint + 1

c     read in the fine structure
      do ie = 1, ne1
        emr(ie) = dble(em(ie))
      enddo
      call ridxmu(kinit, ne1, emr, chil2, chil3, chil4, chil5, deltaso)
      do 5 im = 1, matsize
         if (kinitm(im) .gt. 0) then  
             refsh(im) = - deltaso   
             gammab(im)= gaml2
         else
             refsh(im) = 0.0
             gammab(im)= gaml3
         endif
    5 continue

c     Josh - if PLASMON card is set, and using HL exc,
c          - read pole information from epsinv.dat
        IF( (iPl.gt.0).and.(ixc.eq.0) ) THEN
           open(file='exc.dat', unit=47, status='old',iostat=ios)
           call chopen (ios, 'exc.dat', 'ffmod2(xsectd)')
           DO ipole = 1, MxPole
              call rdcmt(47,'#*cC')
              read(47,*,END=7) WpCorr(ipole), Gamma(ipole),
     &             AmpFac(ipole)
              Gamma(ipole)  = Gamma(ipole)/hart
              WpCorr(ipole) = (WpCorr(ipole)/hart) /
     &             SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)
           END DO
 7         CONTINUE
           WpCorr(ipole) = -1.d30
           CLOSE(47)
        END IF
        IF(ixc.eq.0) THEN
c     Write wp as calculated from density to sigma.dat
           open(file='mpse.dat', unit=45, status='replace', iostat=ios)
           call chopen (ios, 'sigma.dat', 'ffmod2(xsectd)')
           write(45,*) '# ', 'rs      wp(Hartrees)'
           write(45,*) '# ', (3 / (4*pi*edens(jri+1))) ** third,
     &          SQRT(3.d0/((3 / (4*pi*edens(jri+1))) ** third)**3)*hart
           write(45,'(a)')
     &        '# E-EFermi (eV)   Re[Sigma(E)] (eV)   Im[Sigma(E)] (eV)'
     &        // '   Re[Z]   Im[Z]   Mag[Z]   Phase[Z]   Lambda(E) (/A)'
        END IF
c     Josh END
        
      ixcp  = ixc
c      set atomic orbitals basis set
c      0)  by default the calculated partially occupied orbitals are used
c      1) basis set constructed by having fixed number of nodes
c         ar R_int. Note the user should  specify the energies and
c         check that node is there by plotting fort.78
c      2) natural atomic orbitals can be read from file; see inside
c          subroutine getwf for details

       do 10 jj = 0, nlm+nlp-1
c       manual input for case 1
cc     Xe, nlp=4, nlm=2, nlpoc=0, nlmoc=4
c       temp = 14.8/hart
c       if (jj.eq.1) temp = 31.5/hart
c       if (jj.eq.2) temp = 67.0/hart
c       if (jj.eq.3) temp = 118.0/hart
c       if (jj.eq.4) temp = 25.0/hart
c       if (jj.eq.5) temp = 75.0/hart

cc     tungsten, nlp=5, nlm=0
        temp =  36.5 /hart
        if (jj.eq.1) temp = 110.0/hart
        if (jj.eq.2) temp = 220.0/hart
        if (jj.eq.3) temp = 370.0/hart
        if (jj.eq.4) temp = 550.0/hart

cc     Mg, nlp = 2, nlm=0, nlpoc = 1, nlmoc = 0
c       temp = -5.0/hart
c       if (jj.eq.2) temp = 32.0/hart
c       if (jj.eq.3) temp = 92.0/hart
c       if (jj.eq.4) temp = 160.0/hart
c       temp = 17.0/hart
c       if (jj.eq.1) temp = 103.0/hart

        iph = 0
        ie = 1
        
c       Josh - added arguments: iPl, WpCorr, Gamma, AmpFac
c              for calculation of many pole self energy.        
        call xcpot (iph, ie, ixcp , lreal, ifirst, jri,
     1               temp, xmu,
     2               vtot, vvalgs, edens, dmag, edenvl,
     3               eref, v, vval, iPl, WpCorr, Gamma, AmpFac,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim, rnrm)
        call getwf (ibasis, jj, nlp, nlm, nlpoc, nlmoc, rmt, rint, jri,
     1           jint, temp, eref, dx, x0, ri, v, vval, pat, qat, 
     2           dgcn, dpcn, adgc, adpc, dgcnp, dpcnp, xnval,
     3           iz, ihole, xion, iunf, kinitm, kfinm, nph, matsize)
cc      write out orbitals in fort.78 for visual check of nodes
        do 524 i = 1, jint
  524   write(78,777) ri(i)*bohr, pat(i), qat(i)
  10   continue
c     itest=2
c     if (itest.eq.2) stop

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 15  i = 1, nrptx
         xp(i) = dpc0(i)**2
         xq(i) = dgc0(i)**2
  15  continue
c     nb, xinorm is used for exponent on input to somm
      xinorm = 2*linit + 2
      call somm (ri, xp, xq, dx, xinorm, 0, jnrm)
      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 (lreal.lt.2)  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

c     use ixc for testing
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       ixcp  = 2
c   ALA found that it is better to use ixcp =ixc and real part of 
c   self-energy for atomic xsection. 12/96
      ltrace = .true.
      call bcoef(kinit, ipol, ptz, le2, ltrace, ispin, angks, 
     1           kind, lind, bmat)
c     set spin index to use bmat
      isp = 0
      if (ispin.eq.1) isp = nspx - 1

c     zero rkk and phx
      do 20 ie = 1,nex
      do 20 k1 = 1,8
 20   rkk(ie,k1) = 0
      do 30 k1 = 1,8
 30   phx(k1) = 0

      ifirst = 0

c     define s-function that goes from 0 at E1 to 1 at E2 smoothly
      e1 = 100.d0 / hart
      e2 = 150.d0 / hart
      e12 = (e1+e2) / 2
      de = abs (e2 - e12)
      if (de.lt.0.05/hart) de = 0.05/hart
      do 35 ie = 1, ne1
        xx = (emr(ie) - e12)/de
        if (xx.lt.-1) then
          sfun(ie) = 0
        elseif (xx.ge.1.d0) then
          sfun(ie) = 1.d0
        else
          sfun(ie) = 0.25d0 * ( 2+3*x-xx**3)
        endif
c       reset sfun to  0 for PMBSE only; 
c              or 1 for combined (LF via TDDFT, corehole via PMBSE)
        if (ipmbse.eq.1 .or. ipmbse.eq.3) then
          sfun(ie) = 1.d0
        elseif (ipmbse.eq.2) then
          sfun(ie) = 0.d0
        endif
   35 continue

c     if ( itdlda.eq.1) then
c       do 343 ie = 1, ne1
c         chil2(ie) = 1.d0
c         chil3(ie) = 1.d0
c         chil4(ie) = 1.d0
c         chil5(ie) = 1.d0
c343    continue
c     else
c       do 344 ie = 1, ne1
c         read(15,*) dum, chil3(ie), chil2(ie)
c         if (nch.gt.2) read(16,*) dum, chil5(ie), chil4(ie)
c344    continue
c     endif

c     calculate Im chi0, and matrix elements

      nelast = ne1
      do 400 ie =1, nelast
        iph = 0
        emx = emr(ie)
        
c       Josh - added arguments: iPl, WpCorr, Gamma, AmpFac
c              for calculation of many pole self energy.
        call xcpot (iph, ie, ixcp , lreal, ifirst, jri,
     1               emx, xmu,
     2               vtot, vvalgs, edens, dmag, edenvl,
     3               eref, v, vval, iPl, WpCorr, Gamma, AmpFac,
     4               vxcrmu, vxcimu, gsrel, vvxcrm, vvxcim,rnrm)

cc       set the method to calculate atomic cross section
cc       p2 is (complex momentum)**2 referenced to energy dep xc
         p2 = emr(ie) - eref
         ckl3(ie) = sqrt (2*p2 + (p2*alphfs)**2)
         p2 = emr(ie) - (eref + deltaso)
         ckl2(ie) = sqrt (2*p2 + (p2*alphfs)**2)

        omega(ie) = (emr(ie) - edge) + emu
        omega(ie) = max (omega(ie), 0.1d0 / hart)

        xsnorml3(ie) = 0
        xsnorml2(ie) = 0   
        xsscfl3(ie) = 0
        xsscfl2(ie) = 0
        xsnorml5(ie) = 0
        xsnorml4(ie) = 0   
        xsscfl5(ie) = 0
        xsscfl4(ie) = 0
   
        if (emr(ie).lt.-10.d0) goto 400

    
        call getchi0 (ie, emr(ie), eref, edge, emu, refsh, omega(ie),
     1           ipmbse, ifxc, sfun(ie),
     1           rmt, rint, jri, jint, dx, x0, ri, edens, v, vval, vch,
     2           eorb, kappa, dgcn, dpcn, adgc, adpc,
     3           dgcnp, dpcnp, xnval, iz, ihole, xion, iunf, nlp, nlm,
     5        jinit,minit,kinitm,jfin, mfin, kfinm, ncore, nph, matsize,
     6           dml, dmdl, chi,wm, xkm,xkmatp(1,1,ie),phf) 

        do 112 im = 1, matsize
            dipmatl(ie,im) = dml(im)
            dipmat(ie,im) = dmdl(im)
            do 113 imp = 1, matsize
              if (kinitm(im).gt.0) then
               if (abs(kfinm(im)+1).gt.abs(kinitm(im)+1)) then
c               jinit = linit - 1/2; lfin = linit + 1
                chi0im(ie,im,imp) = chi(im,imp)*chil2(ie)
               else
c               jinit = linit - 1/2; lfin = linit - 1
                chi0im(ie,im,imp) = chi(im,imp)*chil4(ie)
               endif
              else
               if (abs(kfinm(im)+1).gt.abs(kinitm(im)+1)) then
c               jinit = linit + 1/2; lfin = linit + 1
                chi0im(ie,im,imp) = chi(im,imp)*chil3(ie)
               else
c               jinit = linit + 1/2; lfin = linit - 1
                chi0im(ie,im,imp) = chi(im,imp)*chil5(ie)
               endif
              endif
  113       continue
  112   continue


        do 114 imi = 1, matsize
        do 114 imj = 1, matsize
           xkmat(ie,imi,imj) = xkm(imi,imj)
           wmat(ie,imi,imj) = wm(imi,imj)
  114   continue

c       test - write matrix K into file
c       if (ie .eq. 60) then
c        open(unit=3,file='xkmat.dat',status='unknown', iostat=ios)
c        do 471 i=1,matsize
c        do 471 j =1, matsize 
c              write(3,461)  i, j, xkmat(ie,i,j)
c  461         format(i6, 2x, i6,2x,e12.6, 2x, e12.6)      
c  471   continue  
c        close(unit=3)
c      endif
        

  400 continue
c     Josh - Close sigma.dat
      close(45)
c     Josh END

c     multiply by factor 2 in nonrelativistic case
c     do 410 ie =1, ne1
c     do 410 im = 1, matsize
c     do 410 imp = 1, matsize
c           chi0im(ie,im,imp) = 2* chi0im(ie,im,imp)
c 410 continue

c     add broadening to chi0
c     gamma=0.2/hart/2.0
      do 430 im = 1, matsize
      do 430 imp = 1, matsize
        do 420 ie = 1, ne1
          chi0br(ie) = chi0im(ie,im,imp)*conr
  420   continue
                    
        call conv(emr,chi0br,ne1,gammab(im))

        do 425 ie =1, ne1
           chi0im(ie,im,imp) = dble(chi0br(ie))
  425   continue

  430 continue   
 
                
c     calculate real part of chi0 
        print*,'kkchi'
      call kkchi (emu, edge, refsh, kinitm, kfinm, matsize,
     7                  emr, ne, ne1, chi0im, chi0r)
       
      nelast = ne1
      do 510 ie =1, ne1
        do 34 im = 1, matsize
        do 34 imp = 1, matsize
          chi0(ie,im,imp) = (chi0r(ie,im,imp)+ chi0im(ie,im,imp)*coni)
   34   continue
  510 continue
c     change chi0 to Zangwill-Soven response matrix
c     chi^zs = chi^0 * wmat * chi^0
c      use 
      do 540 ie = 1, ne1
        do im = 1, matsize
         do imp = 1, matsize
          xkm(im,imp) = 0
          do imx = 1, matsize
            xkm(im,imp) = xkm(im,imp) + wmat(ie,im,imx)*chi0(ie,imx,imp)
          enddo
         enddo
        enddo

        do im = 1, matsize
         do imp = 1, matsize
          wm(im,imp) = 0
          do imx = 1, matsize
            wm(im,imp) = wm(im,imp) + chi0(ie,im,imx)*xkm(imx,imp)
          enddo
         enddo
        enddo

        do im = 1, matsize
         do imp = 1, matsize
c           chi0(ie,im,imp) = chi0(ie,im,imp) + wm(im,imp)
         enddo
        enddo
  540 continue
               
           
c     calculate screened matrix element
      call dmscf(emr, nelast,nex, matsize, chi0, dipmatl, xkmat, dipscf)    

        im = 5 
      do 511 ie =1, nelast
        write(77, 777)  emr(ie)*hart, 
     1    dble(chi0(ie, 1,1)), dimag(chi0(ie, 1,1)),
     1    dble(chi0(ie,im,im)), dimag(chi0(ie,im,im))
  777   format( 6e12.4)
  511 continue
               

      do 500 ie =1, nelast
cc      test case - test KK transform for a Lorentzian
c       gamma = 2.0
c       ener = emr(ie) - 500.0/hart
c       do 34 im = 1, matsize
c       do 34 imp = 1, matsize
c         chi0im(im,imp) = - ener / (ener**2 + gamma**2)
c         chi0(ie,im,imp) = chi0r(im,imp)*conr + chi0im(im,imp)*coni
c   34  continue

c        -- nonrelativistic
c       prefac = - 8 * pi / 3 * alphfs * omega(ie) *  bohr**2
c        -- relativistic is (for alpha form)
        prefac = - 4 * pi * alpinv / omega(ie) * bohr**2 * 100
c       last factor 100 transforms to Mbarn from A**2

c       prefactor with  - 2*ck   
        prefacl3 = - 2 * dble(ckl3(ie))* prefac
        prefacl2 = - 2 * dble(ckl2(ie))* prefac

c       sum over m.m' 
        do 305 im = 1, matsize
          dipmat(ie,im) = dipmat(ie,im)
          if (kinitm(im) .lt. 0) then
c           single-electron approximation
            if (im.le.15) then
              xsnorml3(ie) =  xsnorml3(ie) + dipmat(ie,im)**2
            else
              xsnorml5(ie) =  xsnorml5(ie) + dipmat(ie,im)**2
            endif
c           including TDLDA effect
            temp = dipmat(ie,im)
            do 555 imp = 1, matsize
            do 555 imx = 1, matsize
  555       temp=temp+xkmatp(im,imp,ie)*chi0(ie,imp,imx)*dipscf(ie,imx)
            if (im.le.15) then
              xsscfl3(ie) =  xsscfl3(ie) + (abs(temp))**2
            else
              xsscfl5(ie) =  xsscfl5(ie) + (abs(temp))**2
            endif
          else
c           single electron approximation
            if (im.le.15) then
              xsnorml2(ie) =  xsnorml2(ie) + dipmat(ie,im)**2
            else
              xsnorml4(ie) =  xsnorml4(ie) + dipmat(ie,im)**2
            endif
c           including TDLDA effect
            temp = dipmat(ie,im)
            do 556 imp = 1, matsize
            do 556 imx = 1, matsize
  556       temp=temp+xkmatp(im,imp,ie)*chi0(ie,imp,imx)*dipscf(ie,imx)
            if (im.le.15) then
              xsscfl2(ie) =  xsscfl2(ie) + (abs(temp))**2
            else
              xsscfl4(ie) =  xsscfl4(ie) + (abs(temp))**2
            endif
          endif
            
  305   continue 

        xsnorml3(ie) = xsnorml3(ie) * prefacl3
        xsscfl3(ie) = xsscfl3(ie) * prefacl3
        if (nch.gt.1) then
          xsnorml2(ie) = xsnorml2(ie) * prefacl2
          xsscfl2(ie) = xsscfl2(ie) * prefacl2
          if (nch.gt.2) then
            xsnorml4(ie) = xsnorml4(ie) * prefacl2
            xsnorml5(ie) = xsnorml5(ie) * prefacl3
            xsscfl5(ie) = xsscfl5(ie) * prefacl3
            xsscfl4(ie) = xsscfl4(ie) * prefacl2
          endif
        endif

 500  continue
cc    end of energy cycle


c     add broadening 
      do 820 ie = 1, ne1
        if (emr(ie) .lt. edge ) then
          xl3br(ie) = 0.0             
          xl5br(ie) = 0.0             
        else
          xl3br(ie) = xsscfl3(ie)*conr
          if (nch.gt.2) xl5br(ie) = xsscfl5(ie)*conr
        endif

        if (nch.gt.1) then
        if (emr(ie) .lt. edge + deltaso ) then
          xl2br(ie) = 0.0             
          if (nch.gt.2) xl4br(ie) = 0.0             
        else
          xl2br(ie) = xsscfl2(ie)*conr
          if (nch.gt.2) xl4br(ie) = xsscfl4(ie)*conr
        endif        
        endif        
  820 continue
                    
      call conv(emr,xl3br,ne1,gaml3)
      if (nch.gt.1) call conv(emr,xl2br,ne1,gaml2)
      if (nch.gt.2) call conv(emr,xl5br,ne1,gaml3)
      if (nch.gt.2) call conv(emr,xl4br,ne1,gaml2)

      do 825 ie =1, ne1
        xsscfl3(ie) = dble(xl3br(ie))
        if (nch.gt.1) xsscfl2(ie) = dble(xl2br(ie))
        if (nch.gt.2) xsscfl5(ie) = dble(xl5br(ie))
        if (nch.gt.2) xsscfl4(ie) = dble(xl4br(ie))
  825 continue

c     add broadening 
      do 821 ie = 1, ne1
        if (emr(ie) .lt. edge) then
          xl3br(ie) = 0.0             
          if (nch.gt.2) xl5br(ie) = 0.0             
        else
          xl3br(ie) = xsnorml3(ie)*conr
          if (nch.gt.2) xl5br(ie) = xsnorml5(ie)*conr
        endif

        if (nch.gt.1) then
        if (emr(ie) .lt. (edge + deltaso)) then
          xl2br(ie) = 0.0             
          if (nch.gt.2) xl4br(ie) = 0.0             
        else
          xl2br(ie) = xsnorml2(ie)*conr
          if (nch.gt.2) xl4br(ie) = xsnorml4(ie)*conr
        endif        
        endif        
  821 continue
                    
      call conv(emr,xl3br,ne1,gaml3)
      if (nch.gt.1) call conv(emr,xl2br,ne1,gaml2)
      if (nch.gt.2) call conv(emr,xl5br,ne1,gaml3)
      if (nch.gt.2) call conv(emr,xl4br,ne1,gaml2)

      do 826 ie =1, ne1
        xsnorml3(ie) = dble(xl3br(ie))
        if (nch.gt.1) xsnorml2(ie) = dble(xl2br(ie))
        if (nch.gt.2) xsnorml5(ie) = dble(xl5br(ie))
        if (nch.gt.2) xsnorml4(ie) = dble(xl4br(ie))
  826 continue

c--------- make final output ---------------------------------------
      open(unit=4,file='xsedge.dat',status='unknown', iostat=ios)
      do 460 ie=1,nelast 
        xsnorml3(ie) = xsnorml3(ie)*chil3(ie)
        if (nch.gt.1) xsnorml2(ie) = xsnorml2(ie)*chil2(ie)
        if (nch.gt.2) xsnorml4(ie) = xsnorml4(ie)*chil4(ie)
        if (nch.gt.2) xsnorml5(ie) = xsnorml5(ie)*chil5(ie)
        xsscfl3(ie) = xsscfl3(ie)*chil3(ie)
        if (nch.gt.1) xsscfl2(ie) = xsscfl2(ie)*chil2(ie)
        if (nch.gt.2) xsscfl4(ie) = xsscfl4(ie)*chil4(ie)
        if (nch.gt.2) xsscfl5(ie) = xsscfl5(ie)*chil5(ie)
  460 continue
      do 470 ie=1,nelast 
        if (nch.gt.2) then
          write(4,465)  dble(emr(ie)+emu) * hart,
     2    dble(xsnorml3(ie)+xsnorml2(ie)+xsnorml5(ie)+xsnorml4(ie)),
     3    dble(xsscfl3(ie) +xsscfl2(ie) +xsscfl5(ie) +xsscfl4(ie) ),
     4    dble(xsnorml3(ie)+xsnorml5(ie)),
     5    dble(xsnorml2(ie)+xsnorml4(ie)),
     6    dble(xsscfl3(ie)+ xsscfl5(ie)),
     7    dble(xsscfl2(ie)+ xsscfl4(ie))
        elseif (nch.gt.1) then
          write(4,465)  dble(emr(ie)+emu) * hart,
     2    dble(xsnorml3(ie)+xsnorml2(ie)),
     3    dble(xsscfl3(ie) +xsscfl2(ie) ),
     4    dble(xsnorml3(ie)),
     5    dble(xsnorml2(ie)),
     6    dble(xsscfl3(ie)),
     7    dble(xsscfl2(ie))
        else
          write(4,465)  dble(emr(ie)+emu) * hart,
     2    dble(xsnorml3(ie)),
     3    dble(xsscfl3(ie)) 
        endif

  465   format(f10.5, 2x, e10.5,2x,e10.5,2x,e10.5,1x,e10.5,1x,e10.5,
     1            1x,e10.5)
  470 continue  
      close(unit=4)

      return
      end
      subroutine dmscf(em, ne, nex, matsize, chi0, dipmat, xkmat,dipscf)

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

      parameter (maxsize = 78)
      complex*16 coni
      parameter (coni = (0,1))
      dimension em(nex)
      complex*16 chi0(nex,maxsize,maxsize), dipscf(nex,maxsize)
      dimension dipmat(nex,maxsize)
      complex*16 xkmat(nex,maxsize,maxsize)
      dimension ipiv(matsize)
      complex amat(matsize,matsize)
      real xxr, xxim
      complex amatinv(matsize,matsize)
      complex rhs(matsize), aminv(matsize,matsize)
      character*1 trans

      do 200 ie = 1, ne
       do 10 i = 1, matsize
       do 10 j = 1, matsize
         amat(i,j) =0

c        Mscf = 1 - K*chi0
         if (i .eq. j) then
           delta = 1
         else 
           delta = 0
         endif
    
c        chi0 is diagonal, so it has only one index j
c        K  = 1 - K*chi0   
         xxr = real(delta)
         xxim = 0
         do 5 k=1,matsize
           xxr = xxr - real( dble(xkmat(ie,i,k) * chi0(ie,k,j)))
           xxim=xxim - real(dimag(xkmat(ie,i,k) * chi0(ie,k,j)))
   5     continue
         amat(i,j)=cmplx(xxr, xxim) 
   10  continue

       do 50 i = 1, matsize
         dipscf(ie,i) = 0
         do 40 j = 1, matsize
c          ddr =  dble(real(amatinv(i,j))) * dipmat(ie,j)
c          ddim = dble(aimag(amatinv(i,j))) * dipmat(ie,j)
           dipscf(ie,i) = dipscf(ie,i) + amatinv(i,j)*dipmat(ie,j)
           amatinv(i,j) = amat(i,j)
   40    continue
   50  continue
      
c      find screened matrix elements by precise matrix inversion 
       call cgetrf(matsize,matsize,amat,matsize,ipiv,info) 
       if (info .lt. 0) call wlog('  *** Error in cgetrf')
  
       do 60 i = 1, matsize
         rhs(i) = dipmat(ie,i)
   60  continue
  
       nrhs = 1
       trans = 'N'
       call cgetrs(trans,matsize,nrhs,amat,matsize,ipiv,
     1              rhs,matsize,info)   
   
       if (info .lt. 0) call wlog('  *** Error in cgetrc')

       do 70 i = 1, matsize
         dipscf(ie,i) = rhs(i)
   70  continue

  200 continue
      
      return
      end
      subroutine getchi0(ie, em, eref, edge, emu, refsh, omega, 
     1           ipmbse, ifxc, sfun,
     1           rmt, rint, jri, jint, dx, x0, ri, edens, v, vval, vch,
     2           eorb, kappa, dgcn, dpcn, adgc, adpc,
     3           dgcnp, dpcnp, xnval, iz, ihole, xion, iunf, nfo, npo,
     5        jinit,minit,kinitm,jfin, mfin, kfinm, ncore, nph, matsize,
     6           dipmatl, dipmat, chi0im, 
     7           wmat, xkmat, xkmatp, phf)
     
     
      implicit double precision (a-h, o-z)


c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 ptz
      dimension ptz(-1:1, -1:1)
      complex*16 xrcold(nrptx) , xncold(nrptx)

      dimension ri(nrptx), edens(nrptx),fxcim(nrptx)
      dimension fxc(nrptx), fxc0(nrptx)
      dimension eorb(30), kappa(30)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension dgcnp(nrptx,30), dpcnp(nrptx,30)
      dimension adgc(10,30), adpc(10,30), xnval(30), iorb(-4:3)
   
      dimension xp(nrptx)

c     work space for xcpot
      dimension vxcrmu(nrptx), vxcimu(nrptx), gsrel(nrptx)
      dimension vvxcrm(nrptx), vvxcim(nrptx)

c     work space for fovrg
      complex*16 p(nrptx), q(nrptx), pn(nrptx), qn(nrptx), fscf(nrptx)
      complex*16 pp(nrptx), qp(nrptx), pnp(nrptx), qnp(nrptx)
c     to pass energy levels and projected DOS
      dimension neg(30), eng(nex,30), rhoj(nex,30)

      complex*16  p2, ck, xkmt, xkmtp
      complex*16  pu, qu, dum1, factor
      complex*16  xfnorm, xirf, xirf1
      complex*16  temp, aa, bb, cc, rkk1, rkk0, phold
      complex*16  phx(8), ph0
      complex*16  xm1, xm2, xm3, xm4
      complex*16 jl,jlp1,nl,nlp1
      complex*16  v(nrptx), vval(nrptx)
      dimension vch(nrptx),  vcx(nrptx)
      complex*16  xrc(nrptx), xnc(nrptx)
      character*512 slog

c     nesvi:  
      complex*16 apsm(10,matsize), aqsm(10,matsize),p2m(matsize)
      parameter (maxsize = 78)
      dimension chi0im(maxsize, maxsize)
      dimension jinit(maxsize), minit(maxsize)
      dimension jfin(maxsize), mfin(maxsize)
      dimension kinitm(maxsize), kfinm(maxsize)
      dimension dipmat(maxsize), dipmatl(maxsize)
      dimension phf(maxsize), pref(maxsize)
      dimension bf(0:2, nrptx)
      dimension refsh(maxsize)
      complex*16 eref
      dimension ncore(maxsize)
      dimension dgc0(nrptx), dpc0(nrptx)
      complex*16 pf(nrptx,matsize), qf(nrptx,maxsize)
      complex*16 ptot(nrptx,matsize), qtot(nrptx,maxsize)
      dimension pc(nrptx,maxsize), qc(nrptx,maxsize) 
      complex*16 wmat(maxsize,maxsize), yvec(nrptx, maxsize)
      complex*16 var(nrptx), xkmat(maxsize,maxsize)
      complex*16 xkmatp(maxsize,maxsize), rabcd, rabcdp
      complex*16 ykgr(nrptx), ykgrex(nrptx) 
      dimension rnorm1(maxsize)
      dimension nph(maxsize)
      dimension pat(nrptx), qat(nrptx)
      dimension ovrl(maxsize) 
      
      do 3 imi = 1, maxsize
      do 3 imj = 1, maxsize
        xkmat(imi,imj) = 0
        xkmatp(imi,imj) = 0
    3 continue

c     remember the bessel functions for multipole matrix elements
      xk0 = omega * alphfs
      ilast = jri+6
      if (ilast.le.jint) ilast = jint + 1
      if (ilast.gt.nrptx) ilast = nrptx
      do 50 i = 1, ilast
        temp = xk0 * ri(i)
        if (abs(temp).lt.1.d0) then
c         use series expansion
          do 40 ll = 0,2
            call bjnser(temp,ll, xirf, dum1,1)
            bf(ll,i) = dble(xirf)
 40       continue
        else
c         use formula
          x = dble(temp)
          sinx = sin(x)
          cosx = cos(x)
          bf(0,i) = sinx/x
          bf(1,i) = sinx/x**2 - cosx/x
          bf(2,i) = sinx*(3/x**3-1/x) - 3*cosx/x**2
        endif

c       also calculate the local exchange term fxc = vxc*r_s**3/r**2
        if (edens(i).le.0) then
          if(mod(i,10).eq.0) then
            write(slog, 149) 'negative dens ', i,iph
  149       format (a, 2i3)
            call wlog(slog)
          endif
          rs = 100
        else
          rs = (4*pi*edens(i)/3)**(-third)
        endif
c       vvbh from Von Barth Hedin paper, 1971
c       see eq.60-61 of Gross&Kohn, Adv. Quant. Chem. 21, p.255(1990).
c       eq.60 fxc = d V_xc / d rho * (2\ell + 1) /(4*pi*r**2)
c       where second factor comes from \delta(r-r')
c       for dipole field \ell=1 
        fxc0(i) = rs**3 / ri(i)**2 / 6 * (-1.22177412/rs -1.512/(30+rs))
cc       below are coefficients in Zangwill/Soven paper
c       fxc0(i) = rs**3 / ri(i)**2 / 6 * (-1.222/rs -0.75924/(11.4+rs))
c       from eq.61 fxc = f_inf * (2\ell + 1) /(4*pi*r**2)
        rsx = rs / 30
        fxc(i) = rs**3 / ri(i)**2 / 6 * (-1.22177412*0.6/rs -1.008*
     1    (1.0/3.0 - rsx/2 + rsx**2- (rsx**3+0.22)*log(1.0+1/rsx) ))

c       choose ifxc=0 for RPA, 1 for Zangwill Soven, 2 for Gross kohn
c       3 for kernel in our paper 4 ZS for diag, GK for off diagonal
        if (ifxc .eq.0) then
          fxc(i) = 0
          fxcim(i) = 0
          fxc0(i) = 0
        elseif (ifxc.eq.1) then
          fxc(i) = fxc0(i)
          fxcim(i) = 0
        elseif (ifxc.eq.2 .or. ifxc.eq.4) then
          cc = 23*pi/15 / ( 4./3.*pi*ri(i)**2)
          gam = 3.6256099082**2/ (4*sqrt(2*pi))
          bxc = gam/cc*(fxc(i)-fxc0(i))
          axc = -cc * bxc**(5./3.)
          bxc = bxc**(4./3.)
          vso = - refsh(1)
          if (ifxc.eq.2) vso = omega
          fxcim(i) = axc*vso / (1+bxc*vso**2)**(5./4.)
          ss = sqrt(1+bxc*vso**2)
          s1 = (1-ss)/2
          s2 = (1+ss)/2
          fxc(i) = fxc(i) + axc/pi/ss**2 *sqrt(8./bxc)*
     1     (2*1.350644 - s2*ellpi(s1) - s1*ellpi(s2))
c         to compare with Gross Kohn paper use line below
c         fxc(i) = fxc(i) * ( 4./3.*pi*ri(i)**2)/rs**3
        elseif (ifxc.eq.3 .or. ifxc.eq.5) then
          fxc(i) = 0
          fxcim(i) = 0
        endif
 50   continue

      do  10 im = 1, maxsize
        do  15 imp = 1, maxsize
 15     chi0im(im,imp) = 0
        dipmatl(im) = 0
        dipmat(im) = 0               
        ovrl(im) = 0
 10   continue
c -------------------- separate into K^zs and K^pm

c------------------------
cc              calculate K^zs(r,r')*\phi_i(r') phi_f(r')

      
      do 29 imj = 1, matsize
c       calculate contribution to K due to core-hole potential
        do 31 ir = 1, nrptx
  31    yvec (ir,imj) = 0
c       v = 1
        nu = 1
        nu2 = 2*nu

        call yzktd (ncore(imj),nu,flps, pf(1,imj),
     1           qf(1,imj), apsm(1,imj), aqsm(1,imj),
     2                 ykgr, 0)

c       ykgr is Y(r) = r * int dr' U(r,r') Psi_k'(r') R_l'(r') 
c       where R_l(r) is pf (qf)
c       Psi_k(r) is dgc0(ncore) (dpc0)
c       Y(B,D,r), where B = k', D = l', see Grant's paper

        do 32 i = 1, ilast
cc          need Yk(r) /r 
c    1         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))*
            yvec(i,imj) =  dble(ykgr(i)) / ri(i) 
c           add xc term here
            if (ifxc.ne.2) then
              yvec(i,imj) = yvec(i,imj) + fxc0(i) * 
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            else
              yvec(i,imj) = yvec(i,imj) + (fxc(i)+coni*fxcim(i)) * 
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            endif
c           multiply by separation function
            yvec(i,imj) = yvec(i,imj) * sfun
  32    continue
              
c         A = k, C = l
c         d^v prefactor (angular part of integral)

          jb2 = jinit(imj)
          mb2 = minit(imj)
          jd2 = jfin(imj)
          md2 = mfin(imj)

          ind2 = 2
c         Grant's condition (7.13)
c         ja+v+jc is odd if Aa = Ac, even otherwise
c         jd+v+jb is odd if Ad = Ab, even otherwise
c         in our case it turns out j+v+j' should be even => v is odd
c         v =1 is the leading term

          dnudb= cwig3j(jd2,nu2,jb2,1,0,2)
          dnudb= dnudb * cwig3j(jd2,nu2,jb2,-md2,(md2-mb2),ind2)
          x2 = (jd2+1) * (jb2+1)
          pref(imj) = (-1)**((md2 + 1)/2.0) * dnudb * sqrt(x2)
  29  continue
c---------------------

c     dipole only
      ks = 1  
cc    calculate screened dipole field
      ww = dble(emu+p2-edge)
      if (ks.eq.1) then
        p2 = em - dble(eref) + coni*1.d-8
        p2f = edge - dble(eref)
        if (ie.eq.1) call correorb(iz, ihole, rmt, jri, dx,ri,
     1               p2f,edge, v, dgcn, dpcn, adgc, adpc,
     2               eorb, neg, eng, rhoj, kappa, norbp)
c       print*,'ie=', ie
        call phiscf (ifxc, rmt, ilast, jri, p2, p2f, emu, dx,
     1              ri, v, edens, dgcn, dpcn, adgc, adpc,
     2              iz, ihole, neg, eng, rhoj,kappa, norbp, fscf,
     3              yvec, maxsize, matsize, sfun)
        do imi = 1, matsize
           do imj = 1, matsize
             do i = 1,ilast
               var(i) = yvec(i,imj)*
     1         dble(pc(i,imi)*pf(i,imi) + qc(i,imi)*qf(i,imi))
             enddo
c            integrate over r
             rabcd = 0
             do i = 2, ilast
               rabcd=rabcd + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
             enddo
             wmat(imi,imj) = rabcd * pref(imi) * pref(imj)
           enddo
        enddo
        wse = dble(p2-eng(1,ihole))
c     endif
      else
        do 159 i = 1, nrptx 
  159   fscf(i) = 1.d0
        do imi = 1, matsize
          do imj = 1, matsize
            wmat(imi,imj) = 0
          enddo
        enddo
        wse = ww
      endif
      ww = sqrt(wse/ww)

      idim = matsize
cc    change idim here to remove some channels
c     idim = 60
      do 20 im = 1, idim
        kinit = kinitm(im)
        kfin = kfinm(im)
        kdif = kfin - kinit

        lfin = kfin
        if (kfin.le.0) lfin = abs(kfin) - 1


c       p2 is (complex momentum)**2 referenced to energy dep xc

c       if the initial state is p1/2(L2) edge, then subtract spin-orbit
c       splitting, because em
c       is linked to p3/2 energy origin
        p2 = em - (dble(eref) - refsh(im))      
        ck = sqrt (2*p2 + (p2*alphfs)**2)
        xkmt = rmt * ck
        p2m(im) = p2 

        if (dble(p2).le.0.d0) goto 20
        if (dble(p2).le.dble(v(jri+1))) goto 20

      
c       check that orbital momentum does not exceed max allowed
c       if (lfin .gt. lx) then
cc        set final j and l to unphysical values
c         lfin = -1 
c       endif
       
c       if (ltolm1.eq.0 .and. ((kinit.lt.0 .and. ind.ge.3) .or.
c     1          (kinit.gt.0 .and. ind.ne.3)) ) goto 300

        ikap = kfin

        irr = -1
        ncycle = 0
        ic3 = 0
c       set ilast larger than jri for better interpolation for pu
c       also need 5 points after jri for irregular solution

        p2 = p2 + coni*0.0001/hart
        call dfovrg (ncycle, ikap, rmt, ilast, jri, p2, dx,
     1               ri, v,vval, dgcn, dpcn, adgc, adpc,
     1               xnval, pu, qu, p, q,
     1               iz, ihole, xion, iunf, irr, ic3)

        ilp = lfin - 1
        if (ikap .lt. 0) ilp = lfin + 1
        call exjlnl (xkmt, lfin, jl, nl)
        call exjlnl (xkmt, ilp, jlp1, nlp1)
        call phamp(rmt,pu,qu, ck, jl,nl,jlp1,nlp1, ikap, ph0,temp)
        phf(im) = dble(ph0)

        sign = -1.0
        if (ikap.gt.0) sign = 1.0
        factor = ck*alphfs 
        factor = sign * factor/(1+sqrt(1+factor**2))
        dum1 = 1/ sqrt(1+factor**2)
        xfnorm = 1 / temp *dum1
c       normalization factor
c       xfnorm = dum1*rmt*(jl*cos(delta) - nl*sin(delta))/ Rl(rmt)
c       dum1 is relativistic correction to normalization
c       normalize regular solution
        do 130  i = 1,ilast
          p(i)=p(i)*xfnorm
          q(i)=q(i)*xfnorm
  130   continue

        do 5 ii = 1, nrptx
          dgc0(ii) = dgcn(ii,ncore(im))
          dpc0(ii) = dpcn(ii,ncore(im))
    5   continue
      
c       prepare stuff for K matrix
        do 575 i = 1, ilast
          pc(i,im) = dgc0(i)
          qc(i,im) = dpc0(i)
  575   continue

        do 577 i = 1, 10 
          apsm(i,im) = 0
          aqsm(i,im) = 0
  577   continue
        flps = 1.d0
        apsm(1,im) = pc(1,im) / ri(1)
        aqsm(1,im) = qc(1,im) / ri(1)
  
c       pat, qat - atomic functions that we make projection on.
        do 510 i=1,nrptx
         if (nph(im).gt.0) then
          pat(i) = dgcn(i,nph(im))
          qat(i) = dpcn(i,nph(im))
         else
          pat(i) = dgcnp(i,-nph(im))
          qat(i) = dpcnp(i,-nph(im))
         endif
  510   continue

c       normalize pat and qat in the Norman radius sphere: <n|n>=1,
c       (renormalized atomic sphere method)
     
        do 521  i = 1, ilast
          xp(i) = pat(i)**2 + qat(i)**2
  521   continue
c       nb, xinorm is used for exponent on input to somm 
        xinorm = 2*lfin + 2
        i0 = jint + 1
        call somm2 (ri, xp, dx, xinorm, rint, 0, i0)
      
        xinorm = sqrt(xinorm)
        do 522 i=1,ilast
          pat(i) = pat(i) / xinorm
          qat(i) = qat(i) / xinorm
  522   continue
  
c       calculate overlap integral between f and atomic function 
        do 523  i = 1, ilast
          xp(i) = pat(i)* p(i) + qat(i)*q(i)
  523   continue
c       nb, xinorm is used for exponent on input to somm 
        xinorm = 2*lfin + 2
        i0 = jint + 1
        call somm2 (ri, xp, dx, xinorm, rint, 0, i0)
      
        ovrl(im) = xinorm
c       ploc, qloc - localized part of the functions.
        do 524 i=1,ilast
          pf(i,im) = pat(i)
          qf(i,im) = qat(i)
          ptot(i,im) = p(i)
          qtot(i,im) = q(i)
  524   continue        
        do 525 i=1+ilast, nrptx
          pf(i,im) = 0
          qf(i,im) = 0
          ptot(i,im) = 0
          qtot(i,im) = 0
  525   continue        
      
        mult = 0
        iold = 0
c       call radint(1, mult, bf, kinit, dgc0, dpc0, ikap, p, q,
c    1     pn, qn,ri, dx, ilast, iold, xrc, xnc, xrcold, xncold, xirf)
cc      calculate xirf including fscf - TDLDA result
        do 140 id = 1, 2
          if (id.eq.1) then
            do 121 j = 1,ilast
              pp(j)  = p(j)*dble(fscf(j))
              qp(j)  = q(j)*dble(fscf(j))
  121       continue
          else
            do 122 j = 1,ilast
              pp(j)  = p(j)*dimag(fscf(j))
              qp(j)  = q(j)*dimag(fscf(j))
  122       continue
          endif
          ifl = -1
c         ifl = 1
          xirf1 = 0
          call radint(ifl, mult, bf, kinit, dgc0,dpc0, ikap, pp,qp,
     1    pn,qn,ri,dx, ilast,iold, xrc,xnc, xrcold,xncold, xirf1)
          if (ifl.lt.0) xirf1 = xirf1 * xk0 * ww
          if (id.eq.1) then
            xirf = xirf1
          else
           if (abs(xirf1) .lt. abs(xirf)) then
              dum = abs(xirf1) / abs(xirf)
              xirf = xirf * sqrt(1.d0 + dum**2)
            else
              dum = abs(xirf) / abs(xirf1)
              xirf = xirf1 * sqrt(1.d0 + dum**2)
            endif
          endif
  140   continue

        dum = dimag(xirf)
c       dipmat(im) = dimag(xirf)
c       note that for real potential  xirf is real or reduced matrix
c       element for dipole transition is pure imaginary.
            
c       add (-1)^(j-m) (j L j') factor 
c                         -m pol m'                                 
c       this factor averages to 1/3 after summation over m,m'
c       note, that j,m already have factor 2
c       L = 1 in dipole approximation 
        l2 = 2
c       polarization -1, which corresponds to m'-m = 1  
c       ipol = minit(im) - mfin(im)  
        ipol = mfin(im) - minit(im)
        ind2 = 2
c       angpart= cwig3j(jinit(im),l2,jfin(im),-minit(im),ipol,ind2)
        angpart= cwig3j(jfin(im),l2,jinit(im),-mfin(im),ipol,ind2)
 
c       full dipole m.e.
c       dipmat(im)=dipmat(im) * angpart*(-1)**((jinit(im)-minit(im))/2)
c       dipmat(im)=dipmat(im) * angpart*(-1)**((jfin(im)-mfin(im))/2)
        dum=dum * angpart*(-1)**((jfin(im)-mfin(im))/2)
c       manual changes required: for Xe p-->d  final m.e. is in
c       1--15 positions while p-->s in 16--24 positions
c       logic is also fine for 3d, 4d, and 2p elements calculations
        lin = kinitm(1)
        if (lin.lt.0) lin = abs(lin) - 1
        matszp = 3*(2*lin+1)
        matszm = 3*(2*lin-1)
        if (lin.eq.0) matszm = 0

        if (nfo.gt.0) then
          if (im.le.matszp) dipmat(im) = dum
          imp = im - nfo*matszp
          if (imp.gt.0 .and. imp.le.matszm)  dipmat(imp+matszp) = dum
        else
          if (im.le.matszm)  dipmat(im) = dum
        endif


cc      localized part only
c       call radint(1, mult, bf, kinit,dgc0,dpc0,ikap,pf(1,im),qf(1,im),
c    1       pn, qn, ri, dx, ilast, iold, xrc, xnc, xrcold,xncold, xirf)
        do 340 id = 1, 2
          if (id.eq.1) then
            do 321 j = 1,ilast
              pp(j)  = pf(j,im)*dble(fscf(j))
              qp(j)  = qf(j,im)*dble(fscf(j))
  321       continue
          else
            do 322 j = 1,ilast
              pp(j)  = pf(j,im)*dimag(fscf(j))
              qp(j)  = qf(j,im)*dimag(fscf(j))
  322       continue
          endif
          ifl = -1
c         ifl = 1
          xirf1 = 0
          call radint(ifl, mult, bf, kinit, dgc0,dpc0, ikap, pp,qp,
     1    pn,qn,ri,dx, ilast,iold, xrc,xnc, xrcold,xncold, xirf1)
          if (ifl.lt.0) xirf1 = xirf1 * xk0 * ww
          if (id.eq.1) then
            xirf = xirf1
          else
           if (abs(xirf1) .lt. abs(xirf)) then
              dum = abs(xirf1) / abs(xirf)
              xirf = xirf * sqrt(1.d0 + dum**2)
            else
              dum = abs(xirf) / abs(xirf1)
              xirf = xirf1 * sqrt(1.d0 + dum**2)
            endif
          endif
  340   continue

        dipmatl(im) = dimag(xirf)
c       dipmatl(im)=dipmatl(im)* angpart*(-1)**((jinit(im)-minit(im))/2)
        dipmatl(im)=dipmatl(im)* angpart*(-1)**((jfin(im)-mfin(im))/2)

c       if overlap integral < 0, then no localized part
ctemp   if (ovrl(im) .le. 0) then
ctemp     dipmatl(im) = 0.0
ctemp     ovrl(im) = 0.0
ctemp   endif

c       selection rules for dipole matrix elements and chi0
c       if ( abs(kdif) .ne. ks .and. kfin .ne. - kinit ) goto 20   
     
        chi0im(im,im) = - 2*dble(ck) * (ovrl(im))**2
        if (nfo.gt.1) then
          do i=1,nfo-1
            imp = im-i*matszp
            if (imp.gt.0 .and. em .ge.(edge - refsh(im))) then
              chi0im(im,imp) = - 2*dble(ck) * ovrl(im)* ovrl(imp)
              chi0im(imp,im) = chi0im(im,imp) 
            endif
          enddo
        endif
        if (npo.gt.1) then
          do i=1,npo-1
            imp = im-i*matszm
            if (imp.gt.nfo*matszp.and. em .ge.(edge - refsh(im))) then
              chi0im(im,imp) = - 2*dble(ck) * ovrl(im)* ovrl(imp)
              chi0im(imp,im) = chi0im(im,imp) 
            endif
          enddo
        endif

c       only unoccupied part 
        if (em .lt. (edge - refsh(im))) then
          chi0im(im,im) = 0
          dipmatl(im) = 0
          dipmat(im) = 0
        endif
         
   20 continue

c     write out projected Im chi0 for testing: e.g.
c     write (44, *) em, chi0im(1,1), chi0im(4,4), chi0im(7,7)

c------------------------
cc              calculate K

c     first fix multipliers for direct and xc terms
      sfx = 1-sfun
      sxc = 1
      if (ipmbse.ge.3) sxc = -sfun
c test logic
      do i = 1, ilast
        vcx(i) = vch(i)*sfx
      enddo
c end test
c     scale  xc term according to to ipmbse
c     scale direct term later 
      do i = 1, ilast
        fxc0(i) = sxc * fxc0(i)
        fxc(i)  = sxc * fxc(i)
        fxcim(i)= sxc * fxcim(i)
      enddo

      do 30 imj = 1, idim
c     do 30 imj = 1, matsize
        if (dble(p2m(imj)).le.0.d0) goto 30

c       calculate contribution to K due to core-hole potential
        do 241 i = 1, jint
  241   var(i) = vcx(i)* ( pf(i,imj)**2 + qf(i,imj)**2)
        rabcd = 0
        do 242 i = 2, jint
  242   rabcd = rabcd + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
        do 243 i = 1, jint
  243   var(i) = vcx(i)*( pf(i,imj)*ptot(i,imj)+qf(i,imj)*qtot(i,imj) )
        rabcdp = 0
        do 244 i = 2, jint
  244   rabcdp = rabcdp + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
        xkmat(imj, imj) = rabcd
        if (imj.le.nfo*matszp) then
          imp = mod(imj,matszp)
          if (imp.eq.0) imp = matszp
        else
          imp = matszp + mod((imj-nfo*matszp), matszm)
          if (imp.eq.matszp) imp = matszp + matszm
        endif
        xkmatp(imp, imj) = rabcdp

        if (nfo.gt.1) then
          do j=1, nfo-1
            imp = imj-j*matszp
            if (imp.gt.0) then
cc           calculate off-diagonal matrix elements of V_0
             do  i = 1, jint
              var(i)=vcx(i)* (pf(i,imj)*pf(i,imp) +qf(i,imj)*qf(i,imp))
             enddo
             rabcd = 0
             do  i = 2, jint
              rabcd = rabcd + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
             enddo
             xkmat(imj, imp) = rabcd
             xkmat(imp, imj) = rabcd
            endif
          enddo
        endif
        if (npo.gt.1) then
          do j=1,npo-1
            imp = im-j*matszm
            if (imp.gt.nfo*matszp.and. em .ge.(edge - refsh(im))) then
c             notice: same as above
cc           calculate off-diagonal matrix elements of V_0
             do  i = 1, jint
              var(i)=vcx(i)* (pf(i,imj)*pf(i,imp) +qf(i,imj)*qf(i,imp))
             enddo
             rabcd = 0
             do  i = 2, jint
              rabcd = rabcd + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
             enddo
             xkmat(imj, imp) = rabcd
             xkmat(imp, imj) = rabcd
            endif
          enddo
        endif

c       v = 1
        nu = 1
        nu2 = 2*nu

        call yzktd (ncore(imj),nu,flps, pf(1,imj),
     1           qf(1,imj), apsm(1,imj), aqsm(1,imj),
     2                 ykgr, 0)

c       ykgr is Y(r) = r * int dr' U(r,r') Psi_k'(r') R_l'(r') 
c       where R_l(r) is pf (qf)
c       Psi_k(r) is dgc0(ncore) (dpc0)
c       Y(B,D,r), where B = k', D = l', see Grant's paper

        do 35 imi = 1, idim
c       do 35 imi = 1, matsize
          if (dble(p2m(imi)).le.0.d0) goto 35

          do 541 i=1,ilast
cc          calculate int Yk(r) /r * (Psi_k(r)*R_l(r)+qc*qf) in Grant
            var(i)=dble(pc(i,imi)*pf(i,imi) + qc(i,imi)*qf(i,imi)) 
            var(i) = var(i) / ri(i) * dble(ykgr(i)) * sfx
c           add xc term here
            if (kinitm(imi).eq.kinitm(imj) .and. ifxc.ne.2) then
              var(i) = var(i) + fxc0(i) * 
     1         dble(pc(i,imi)*pf(i,imi) + qc(i,imi)*qf(i,imi))*
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            elseif (kinitm(imi).gt.0 .or. ifxc.eq.2) then
              var(i) = var(i) + (fxc(i)+coni*fxcim(i)) * 
     1         dble(pc(i,imi)*pf(i,imi) + qc(i,imi)*qf(i,imi))*
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            else
              var(i) = var(i) + (fxc(i)-coni*fxcim(i)) * 
     1         dble(pc(i,imi)*pf(i,imi) + qc(i,imi)*qf(i,imi))*
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            endif
  541     continue
              
cc        integration by trapezoid method
c         this gives R_ABCD (see Grant's review)

c         A = k, C = l
          rabcd = 0
          do 551 i=2,ilast
            rabcd=rabcd + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
  551     continue 

          do 542 i=1,ilast
cc          calculate int ( Yk(r) /r * (Psi_k(r)*R_l(r)+qc*qf) in Grant 
            var(i)=dble(pc(i,imi)*ptot(i,imi) + qc(i,imi)*qtot(i,imi)) 
            var(i) = var(i) / ri(i) * dble(ykgr(i)) * sfx
c           add xc term here
            if (kinitm(imi).eq.kinitm(imj) .and. ifxc.ne.2) then
              var(i) = var(i) + fxc0(i) * 
     1         dble(pc(i,imi)*ptot(i,imi) + qc(i,imi)*qtot(i,imi)) *
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            elseif (kinitm(imi).gt.0 .or. ifxc.eq.2) then
              var(i) = var(i) + (fxc(i)+coni*fxcim(i)) * 
     1         dble(pc(i,imi)*ptot(i,imi) + qc(i,imi)*qtot(i,imi)) *
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            else
              var(i) = var(i) + (fxc(i)-coni*fxcim(i)) * 
     1         dble(pc(i,imi)*ptot(i,imi) + qc(i,imi)*qtot(i,imi)) *
     2         dble(pc(i,imj)*pf(i,imj) + qc(i,imj)*qf(i,imj))
            endif
  542     continue
              
cc        integration by trapezoid method
c         this gives R_ABCD (see Grant's review)

c         A = k, C = l
          rabcdp = 0
          do 552 i=2,ilast
            rabcdp=rabcdp + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
  552     continue 

c         d^v prefactors

c         ja2 = jinit(imi)
c         ma2 = minit(imi)
c         jc2 = jfin(imi)
c         mc2 = mfin(imi)
c         jd2 = jinit(imj)
c         md2 = minit(imj)
c         jb2 = jfin(imj)
c         mb2 = mfin(imj)
          jc2 = jinit(imi)
          mc2 = minit(imi)
          ja2 = jfin(imi)
          ma2 = mfin(imi)
          jb2 = jinit(imj)
          mb2 = minit(imj)
          jd2 = jfin(imj)
          md2 = mfin(imj)

          if( (ma2+mb2) .ne. (mc2+md2) ) goto 35 

          ind2 = 2

c         Grant's condition (7.13)
c         ja+v+jc is odd if Aa = Ac, even otherwise
c         jd+v+jb is odd if Ad = Ab, even otherwise
c         in our case it turns out j+v+j' should be even => v is odd
c         v =1 is the leading term

          dnuca= cwig3j(ja2,nu2,jc2,1,0,2)
          dnuca= dnuca * cwig3j(ja2,nu2,jc2,-ma2,(ma2-mc2),ind2)

          dnudb= cwig3j(jd2,nu2,jb2,1,0,2)
          dnudb= dnudb * cwig3j(jd2,nu2,jb2,-md2,(md2-mb2),ind2)

          prefac = (-1)**((ma2 + 1)/2.0) * (-1)**((md2 + 1)/2.0)
          prefac = prefac * dnuca * dnudb
          x1 = (ja2+1) * (jd2+1)
          x2 = (jc2+1) * (jb2+1)
          prefac = prefac * sqrt(x1 * x2) 
c         multiply by separation function
          xkmat(imi,imj) = xkmat(imi,imj) + prefac * rabcd 
          xkmatp(imi,imj) = xkmatp(imi,imj) + prefac * rabcdp

          if (ifxc.eq.5 .and. kinitm(imi).ne.kinitm(imj)) then
c           add dominant nonlocal exchange term (nu=2)
            nu = 2
            call yzktd (ncore(imj),nu,flps, pf(1,imj),
     1           qf(1,imj), apsm(1,imj), aqsm(1,imj),
     2                 ykgrex, ncore(imi))

            do 641 i=1,ilast
cc            calculate int Yk(r) /r * (Psi_k(r)*R_l(r)+qc*qf) in Grant
              var(i)=dble(pf(i,imj)*pf(i,imi) + qf(i,imj)*qf(i,imi)) 
              var(i) = var(i) / ri(i) * dble(ykgrex(i)) * sfx
  641       continue
              
cc          integration by trapezoid method
c           this gives R_ABCD (see Grant's review)
c           A = k, C = l
            rabcd = 0
            do 651 i=2,ilast
              rabcd=rabcd + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
  651       continue 

            do 642 i=1,ilast
cc            calculate int ( Yk(r) /r * (Psi_k(r)*R_l(r)+qc*qf) in Grant 
              var(i)=dble(pf(i,imj)*ptot(i,imi) + qf(i,imj)*qtot(i,imi)) 
              var(i) = var(i) / ri(i) * dble(ykgrex(i)) * sfx
  642       continue
              
cc          integration by trapezoid method
c           this gives R_ABCD (see Grant's review)
c           A = k, C = l
            rabcdp = 0
            do 652 i=2,ilast
              rabcdp=rabcdp + (var(i)+var(i-1))*(ri(i)-ri(i-1)) / 2
  652       continue 

c           d^v prefactors

            jd2 = jinit(imi)
            md2 = minit(imi)
            ja2 = jfin(imi)
            ma2 = mfin(imi)
            jb2 = jinit(imj)
            mb2 = minit(imj)
            jc2 = jfin(imj)
            mc2 = mfin(imj)
            if( (ma2+mb2) .ne. (mc2+md2) ) goto 35 

            ind2 = 2

c           Grant's condition (7.13)
c           ja+v+jc is odd if Aa = Ac, even otherwise
c           jd+v+jb is odd if Ad = Ab, even otherwise
c           in our case it turns out j+v+j' should be even => v is odd
c           v =2 is the leading term

            nux = 2*nu
            dnuca= cwig3j(ja2,nux,jc2,1,0,2)
            dnuca= dnuca * cwig3j(ja2,nux,jc2,-ma2,(ma2-mc2),ind2)
  
            dnudb= cwig3j(jd2,nux,jb2,1,0,2)
            dnudb= dnudb * cwig3j(jd2,nux,jb2,-md2,(md2-mb2),ind2)

            prefac = (-1)**((ma2 + 1)/2.0) * (-1)**((md2 + 1)/2.0)
            prefac = prefac * dnuca * dnudb
            x1 = (ja2+1) * (jd2+1)
            x2 = (jc2+1) * (jb2+1)
            prefac = prefac * sqrt(x1 * x2) 
            xkmat(imi,imj) = xkmat(imi, imj) - prefac * rabcd 
            xkmatp(imi,imj) = xkmatp(imi, imj) - prefac * rabcdp
          endif
c         fix later: need generalization
c         if (imi.gt.69)  xkmatp(imi-54,imj) = xkmatp(imi,imj)
c         if (imi.gt.15)  xkmatp(imi,imj) = 0
cc        first 15 for d->f transitions and next 9 for d->p
          if (nfo.gt.0) then
           if (imi.gt.matszp .and. imi.le.nfo*matszp) xkmatp(imi,imj)=0
           imp = imi - nfo*matszp
           if (imp.le.matszm.and.imp.gt.0)
     1           xkmatp(imp+matszp,imj) = xkmatp(imi,imj)
           if (imp.gt.0) xkmatp(imi,imj) = 0
          else
           if (imi.gt.matszm)  xkmatp(imi,imj) = 0
          endif
            
c         test importance of non-diagonal elements
c         if (imi .ne. imj) xkmat(imi,imj) = 0

c         test mixing between two edges - no mixing
c         if (imi .le. 4 .and. imj .gt. 4) xkmat(imi,imj) = 0
c         if (imj .le. 4 .and. imi .gt. 4) xkmat(imi,imj) = 0

c         only mixing between L3-L2 (no L2-L2 or L3-L3)
c         if (imi .gt. 2 .and. imj .gt. 2) xkmat(imi,imj) = 0
c         if (imj .le. 2 .and. imi .le. 2) xkmat(imi,imj) = 0

c         xkmat(imi,imj) = 0.0


   35   continue
   30 continue   
c---------------------
                
      return 
      end 
                     

      function ellpi(x)
      implicit double precision (a-h, o-z)

      en=-x
c     sign differs in Num.Rec. and Byrd/Friedman
      ellpi= rf(0.d0, 0.5d0, 1.d0) - en/3.d0*rj(0.d0,0.5d0,1.d0,1.d0+en)

      return
      end
      function rf(x,y,z)
      implicit double precision (a-h, o-z)
      parameter (errtol=0.0025, tiny=1.5e-38, big=3.e37, third=1./3.,
     1  c1=1./24., c2=0.1, c3=3./44., c4=1./14. )

      if (min(x,y,z).lt.0. .or. min(x+y,x+z,y+z).lt.tiny .or.
     1   max(x,y,z).gt.big) pause 'invalid arguments in rf'

      xt=x
      yt=y
      zt=z
  1   continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        zt=.25*(zt+alamb)
        ave=third*(xt+yt+zt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
      if (max(abs(delx), abs(dely), abs(delz)).gt.errtol) goto 1
      e2 = delx*dely-delz**2
      e3 = delx*dely*delz
      rf=(1+(c1*e2-c2-c3*e3)*e2+c4*e3)/sqrt(ave)
      
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .

      function rj(x,y,z,p)
      implicit double precision (a-h, o-z)
      parameter (errtol=0.0015, tiny=2.5e-13, big=9.e11, c1=3./14.,
     1  c2=1./3., c3=3./22., c4=3./26., c5=.75*c3, c6=1.5*c4, c7=.5*c2,
     2  c8=c3+c3)

      if (min(x,y,z).lt.0. .or. min(x+y,x+z,y+z,abs(p)).lt.tiny .or.
     1   max(x,y,z,abs(p)).gt.big) pause 'invalid arguments in rj'

      sum=0
      fac=1
      if (p.gt.0) then
        xt=x
        yt=y
        zt=z
        pt=p
      else
        xt= min(x,y,z)
        zt= max(x,y,z)
        yt = x+y+z -xt-zt
        a=1./(yt-p)
        b=a*(zt-yt)*(yt-xt)
        pt=yt+b
        rho=xt*zt/yt
        tau=p*pt/yt
        rcx=rc(rho,tau)
      endif

  1   continue
        sqrtx=sqrt(xt)
        sqrty=sqrt(yt)
        sqrtz=sqrt(zt)
        alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz
        alpha=(pt*(sqrtx+sqrty+sqrtz)+sqrtx*sqrty*sqrtz)**2
        beta=pt*(pt+alamb)**2
        sum = sum + fac*rc(alpha,beta)
        fac=.25*fac
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        zt=.25*(zt+alamb)
        pt=.25*(pt+alamb)
        ave=.2*(xt+yt+zt+pt+pt)
        delx=(ave-xt)/ave
        dely=(ave-yt)/ave
        delz=(ave-zt)/ave
        delp=(ave-pt)/ave
      if (max(abs(delx),abs(dely),abs(delz),abs(delp)).gt.errtol) goto 1
      ea=delx*(dely+delz)+dely*delz
      eb=delx*dely*delz
      ec=delp**2
      ed=ea-3*ec
      ee=eb+2*delp*(ea-ec)
      rj=3*sum+fac*(1+ed*(-c1+c5*ed-c6*ee)+eb*(c7+delp*(-c8+delp*c4))
     1   +delp*ea*(c2-delp*c3)-c2*delp*ec)/(ave*sqrt(ave))
      if (p.le.0) rj=a*(b*rj+3*(rcx-rf(xt,yt,zt)))
      
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .

      function rc(x,y)
      implicit double precision (a-h, o-z)
      parameter (errtol=0.0012, tiny=1.69e-38, sqrtny=1.3e-19,big=3.e37,
     1  tnbg=tiny*big, comp1=2.236/sqrtny, comp2=tnbg*tnbg/25.,
     2  third=1./3., c1=.3, c2=1./3., c3=.375, c4=9./22.)

      if (x.lt.0 .or. y.eq.0 .or. (x+abs(y)).lt.tiny .or.
     1  (x+abs(y)).gt.big .or. (y.lt.-comp1.and.x.gt.0..and.x.lt.comp2))
     2  pause 'invalid argument in rc'
      if (y.gt.0) then
        xt=x
        yt=y
        w=1.
      else
        xt=x-y
        yt=-y
        w=sqrt(x)/sqrt(xt)
      endif
  1   continue
        alamb=2.*sqrt(xt)*sqrt(yt)+yt
        xt=.25*(xt+alamb)
        yt=.25*(yt+alamb)
        ave=third*(xt+yt+yt)
        s=(yt-ave)/ave
      if (abs(s).gt.errtol) goto 1
      rc = w*(1+s*s*(c1+s*(c2+s*(c3+s*c4)))) /sqrt(ave)
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .
      subroutine getmat(ihole, lin, nlp1, nlm1, jinit, minit, kinit,
     1     jfin, mfin, kfin, ncore, nph, matsize, kappa, xnval, ibasis)
c   input:
c     lin - orbital momentum of initial state
c     nlp1 - number of (lin+1) orbitals in basis set
c     nlm1 - number of (lin-1) orbitals in basis set
c    output:
c     matsize - matrix size, and for each matrix index
c     jinit, jfin - initial and final j (*2)
c     minit, mfin - initial and final m (*2) mfin - minit = 1 only 
c     kinit, kfin - initial and final kappa
c     nph - index of the orbital in the basis set (dgcn and dgcnp)
c     array nph is initialized for the use with basis set, but
c     it can be overwritten later (see example in subroutine getchi0)

      implicit double precision (a-h, o-z)
      parameter (maxx = 78)
      dimension jinit(maxx), minit(maxx), jfin(maxx), mfin(maxx)
      dimension kinit(maxx), kfin(maxx), nph(maxx), ncore(maxx)
      dimension kappa(30), xnval(30)

      np = 3 * (2*lin + 1)
      nm = 3 * (2*lin - 1)
      if (nm.lt.0) nm = 0
c     there should be at least one lin+1 orbital
      if (nlp1.lt.1) nlp1=1
      if (nlm1.lt.0) nlm1 = 0
      matsize = nlp1*np + nlm1*nm
c     check whether dimension is big enough
      if (matsize.gt.maxx) stop 'Increase dimension maxx in getmat'
c     initialize to zero all arrays
      do 10 i = 1, maxx
       jinit(i) = 0
       minit(i) = 0
       kinit(i) = 0
       jfin(i)  = 0
       mfin(i)  = 0
       kfin(i)  = 0
       nph(i)  = 0
  10  continue


c     i is current matrix index
      i = 0
c     cycle over  lin+1 basis set orbitals
      do 50 j = 0, nlp1-1
c       cycle over 3 dipole allowed lin-->lin+1 transitions
        do 40 idip = 1,3
          if (idip.eq.1) then
            kin = lin
            kfi = lin + 1
          elseif (idip.eq.2) then
            kin = -lin-1
            kfi = lin+1
          else
            kin = -lin-1
            kfi = -lin-2
          endif
          if (kin.eq.0) goto 40

          jin = 2*abs(kin) - 1
          jfi = 2*abs(kfi) - 1
          nbs = -2*j-1
          if (kfi.gt.0) nbs = nbs-1

c         cycle over minit
          do 30 mini = -jin, jin, 2
            mfi = mini + 2
            if (mfi.lt.-jfi .or. mfi.gt.jfi) goto 30

c           set variables for matrix index i
            i = i + 1
            jinit(i) = jin
            minit(i) = mini
            kinit(i) = kin
            jfin(i)  = jfi
            mfin(i)  = mfi
            kfin(i)  = kfi
            nph(i)   = nbs
  30      continue
  40    continue
  50  continue

c     add lin-->lin-1 transitions
c     cycle over lin-1 basis set orbitals
      do 90 j = 0, nlm1-1
c       cycle over 3 dipole allowed lin-->lin-1 transitions
        do 80 idip = 1,3
          if (idip.eq.1) then
            kin = lin
            kfi = lin - 1
          elseif (idip.eq.2) then
            kin = lin
            kfi = -lin
          else
            kin = -lin-1
            kfi = -lin
          endif
          if (kin.eq.0 .or.kfi.eq.0) goto 80

          jin = 2*abs(kin) - 1
          jfi = 2*abs(kfi) - 1
          nbs = -2*(j+nlp1)-1
          if (kfi.gt.0) nbs = nbs-1

c         cycle over minit
          do 70 mini = -jin, jin, 2
            mfi = mini + 2
            if (mfi.lt.-jfi .or. mfi.gt.jfi) goto 70

c           set variables for matrix index i
            i = i + 1
            jinit(i) = jin
            minit(i) = mini
            kinit(i) = kin
            jfin(i)  = jfi
            mfin(i)  = mfi
            kfin(i)  = kfi
            nph(i)   = nbs
  70      continue
  80    continue
  90  continue
c     last sanity check for matrix dimension
      if (i.ne. matsize) then
        print*, i, matsize
        stop 'FAILED matrix size check  in subroutine getmat'
      endif

cc    Manual Input array nph
cc    automate it later
cc    L3 edge- inorb = 4, L2 edge - inorb = 3
      do im = 1, matsize
        if (kinit(im) .lt. 0) then
          ncore(im) = ihole
        else
          ncore(im) = ihole - 1
        endif
        if (ibasis.eq.0) then
         lfin = kfin(im)
         if (lfin.lt.0) lfin = abs(lfin) -1
         do iorb = 1, 30 
          lorb = kappa(iorb)
          if (lorb.lt.0) lorb = abs(lorb) - 1
          if (xnval(iorb).gt.0 .and. lfin.eq.lorb) then
           if (kfin(im).eq.kappa(iorb) .or. kfin(im).lt.0) nph(im)= iorb
c          above logic relies on the order or orbitals from subroutine
c          getorb: for the same lorb first appears the orbit 
c          with j=lorb-1/2 and second with j=lorb+1/2
          endif
         enddo
        endif
cc     manual input
cc     for diamond and other 2p elements
c       if (kinit(im) .eq. -1) ncore(im) = 1
c       if (kfin(im) .eq. 1) nph(im) = 3
c       if (kfin(im) .eq. -2) nph(im) = 4
c      for Mg and other  3p
c       if (kinit(im) .eq. -1) ncore(im) = 1
c       if (kfin(im) .eq. 1 .and. im.le.np) nph(im) = 6
c       if (kfin(im) .eq. -2 .and. im.le.np) nph(im) = 6
c       if (kfin(im).eq. 1 .and. im.gt.np .and. im.le.2*np) nph(im) = 6
c       if (kfin(im).eq.-2 .and. im.gt.np .and. im.le.2*np) nph(im) = 6
cc     for 3d transition metal series L2,3 edges
c       if (kinit(im) .eq. 1) ncore(im) = 3
c       if (kinit(im) .eq. -2) ncore(im) = 4
c       if (kfin(im) .eq. 2) nph(im) = 8
c       if (kfin(im) .eq. -3) nph(im) = 9
cc     for 4d transition metal series N2,3 edges
c       if (kinit(im) .eq. 1) ncore(im) = 6
c       if (kinit(im) .eq. -2) ncore(im) = 7
c       if (kfin(im) .eq. 2) nph(im) = 13
c       if (kfin(im) .eq. -3) nph(im) = 14
cc     for Xe and 4f series N4,5 edges
c       if (kinit(im) .eq. 2) ncore(im) = 13
c       if (kinit(im) .eq. -3) ncore(im) = 14
cc     for W (tungsten) M4,5
c       if (kinit(im) .eq. 2) ncore(im) = 8
c       if (kinit(im) .eq. -3) ncore(im) = 9
c       nph is already set in getmat.f
      enddo

      return
      end

      SUBROUTINE ludcmp(a,n,np,indx,d)
      INTEGER n,np,indx(n),NMAX
      REAL d,a(np,np),TINY
      PARAMETER (NMAX=500,TINY=1.0e-20)
      INTEGER i,imax,j,k
      REAL aamax,dum,sum,vv(NMAX)
      d=1.
      do 12 i=1,n
        aamax=0.
        do 11 j=1,n
          if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j))
11      continue
        if (aamax.eq.0.) pause 'singular matrix in ludcmp'
        vv(i)=1./aamax
12    continue
      do 19 j=1,n
        do 14 i=1,j-1
          sum=a(i,j)
          do 13 k=1,i-1
            sum=sum-a(i,k)*a(k,j)
13        continue
          a(i,j)=sum
14      continue
        aamax=0.
        do 16 i=j,n
          sum=a(i,j)
          do 15 k=1,j-1
            sum=sum-a(i,k)*a(k,j)
15        continue
          a(i,j)=sum
          dum=vv(i)*abs(sum)
          if (dum.ge.aamax) then
            imax=i
            aamax=dum
          endif
16      continue
        if (j.ne.imax)then
          do 17 k=1,n
            dum=a(imax,k)
            a(imax,k)=a(j,k)
            a(j,k)=dum
17        continue
          d=-d
          vv(imax)=vv(j)
        endif
        indx(j)=imax
        if(a(j,j).eq.0.)a(j,j)=TINY
        if(j.ne.n)then
          dum=1./a(j,j)
          do 18 i=j+1,n
            a(i,j)=a(i,j)*dum
18        continue
        endif
19    continue
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .


      SUBROUTINE lubksb(a,n,np,indx,b)
      INTEGER n,np,indx(n)
      REAL a(np,np),b(n)
      INTEGER i,ii,j,ll
      REAL sum
      ii=0
      do 12 i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        if (ii.ne.0)then
          do 11 j=ii,i-1
            sum=sum-a(i,j)*b(j)
11        continue
        else if (sum.ne.0.) then
          ii=i
        endif
        b(i)=sum
12    continue
      do 14 i=n,1,-1
        sum=b(i)
        do 13 j=i+1,n
          sum=sum-a(i,j)*b(j)
13      continue
        b(i)=sum/a(i,i)
14    continue
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software .
      subroutine getwf(ibasis, jj, nlp,nlm, nlpoc,nlmoc, rmt, rint, jri,
     1           jint, em, eref, dx, x0, ri, v, vval, pat, qat,
     2           dgcn, dpcn, adgc, adpc, dgcnp, dpcnp, xnval, 
     3           iz, ihole, xion, iunf, kinitm, kfinm, nph, matsize)
      implicit double precision (a-h, o-z)
c  information specific for finding basis set orbitals
c     jj - index for the basis set orbital (starts from 0)
c     nlp -number of (L+1) orbitals in basis (L-initial state orb.mom.)
c     nlm -number of (L-1) orbitals in basis
c     nlpoc - number of completely occcupied (L+1) orbitals
c     nlmoc - number of completely occcupied (L-1) orbitals
c  information for dfovrg call, to get radial solution for some energy
c     rmt, rint - muffin-tin and Norman radius
c     jri, jint - indeces for muffin-tin and Norman radii on radial grid
c     em, eref - the energy of photoelectron
c     dx, x0, ri - radial grid information
c     v, vval - potential
c     pat, qat - orbitals
c     dgcn, dpcn, adgc, adpc - fully and partially occupied orbitals
c     dgcnp, dpcnp -  unoccupied orbitals (to be calculated and stored)
c     xnval - atomic occupations for valence orbitals
c     iz - nuclei charge
c     ihole - index of core-hole orbital
c     xion - ionicity (zero by default)
c     iunf - flag to freeze/unfreeze f-electrons
c  information about matrix indeces for K and Chi_0
c     kinitm - initial state kappa for each matrix index
c     kfinm - final state kappa for each matrix index
c     nph - index for the basis set orbital for each matrix index
c     matsize - matrix dimension



c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      complex*16 ptz
      dimension ptz(-1:1, -1:1)
      complex*16 xrcold(nrptx) , xncold(nrptx)

      dimension ri(nrptx), vtot(nrptx), edens(nrptx),dmag(nrptx)
      dimension vvalgs(nrptx), edenvl(nrptx)
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30), xnval(30)
      dimension dgcnp(nrptx,30), dpcnp(nrptx,30)
   
      dimension xp(nrptx), xq(nrptx)

c     work space for xcpot
      dimension vxcrmu(nrptx), vxcimu(nrptx), gsrel(nrptx)
      dimension vvxcrm(nrptx), vvxcim(nrptx)

c     work space for fovrg
      complex*16 p(nrptx), q(nrptx), pn(nrptx), qn(nrptx)

      complex*16  p2, ck, xkmt, xkmtp
      complex*16  pu, qu, dum1, factor
      complex*16  xfnorm, xirf
      complex*16  temp, aa, bb, cc, phold
      complex*16  phx(8), ph0
      complex*16  xm1, xm2, xm3, xm4
      complex*16 jl,jlp1,nl,nlp1
      complex*16  v(nrptx), vval(nrptx)
      complex*16  xrc(nrptx), xnc(nrptx)
      character*512 slog

c     nesvi:  
      parameter (maxsize = 78)
      dimension kinitm(maxsize), kfinm(maxsize)
      dimension nph(maxsize)
      complex*16 eref
      dimension pat(nrptx), qat(nrptx)
c     orbital input file imension
      parameter (norbx=5000)
      dimension phi(norbx), rip(norbx)
      

c     set initial orb. mom. and dimension in matrix per each final orbital
      ll = kinitm(1)
      if (ll.le.0) ll = -ll -1
      n1 = 3*(2*ll+1)
      n2 = 3*(2*ll-1)
c     set ilast larger than jri for better interpolation for pu
      ilast = jint + 1
      if (ilast.le.jri) ilast = jri+1

      if (jj.lt.nlm+nlp) then
c       set initial and final indeces for this orbital in matrix
        if (jj.lt.nlp) then
          imi = 1+n1*jj
          imf = n1*(jj+1)
        else
          imi = 1 + n1*nlp + n2*(jj-nlp)
          imf = imi + n2 - 1
        endif
        
        do im = imi, imf
c         notice that actually don't need to cycle over all im's 
c         but rather only over positive and negative kappa (ik)
c         iforb = 2*jj + ik + 1
c         however neglect it for now since it is not a bottleneck

c         check whether really need to calculate the orbital
c         iforb = - nph(im)
          iforb = 2*jj+1
          if (kfinm(im).gt.0) iforb = iforb+1
          kfin = kfinm (im)
          lfin = kfin
          if (kfin.le.0) lfin = abs(kfin) - 1
          do i=1,nrptx
            pat(i) = 0
            qat(i) = 0
          enddo

          if (ibasis.eq.0)  then
c           copy orbital from array dgcn to dgcnp
            do i=1, nrptx
              pat(i) = dgcn(i,nph(im))
            enddo
            do i=1, nrptx
              qat(i) = dpcn(i,nph(im))
            enddo
            nph(im) = - iforb
          elseif (ibasis.eq.1) then
c           read orbital from file, neglecting SO in final state
            nph(im) = - iforb
            if (jj.eq.2) then
              open (unit=3, file='Vila/Orbs/mg.4p.dat', status='old')
            elseif (jj.eq.1) then
              open (unit=3, file='Vila/Orbs/mg.4p.dat', status='old')
            else 
              open (unit=3, file='Vila/Orbs/mg.3p.dat', status='old')
            endif
            n=0
  10        n = n+1
              read(3,*, end=20) rip(n), phi(n)
c             need \psi(r) * r and distance in bohrs
              phi(n) = phi(n)*rip(n)
              rip(n) = rip(n) /bohr
              goto 10
  20        continue
            n = n-1
            close (unit=3)

c           interpolate on our radial grid
            do i = 1, ilast
              call terp (rip, phi, n, 1, ri(i), pat(i))
            enddo
            do i = 1, nrptx
              qat(i) = 0
              if (i.gt.ilast) pat(i) = 0
            enddo
          else
c           ibasis=2
c           find orbital for required number of nodes and zero at R_int

c           note that we neglect SO interaction for projection operator
c           thus need to calculate orbital only for one of j=l +/- 1/2
c           p2 is (complex momentum)**2 referenced to energy dep xc
c           if the initial state is p1/2(L2) edge, then subtract spin-orbit
c           splitting, because em
c           is linked to p3/2 energy origin
            p2 = em - (dble(eref))      
            ck = sqrt (2*p2 + (p2*alphfs)**2)
            xkmt = rmt * ck

            irr = -1
            ncycle = 0
            ic3 = 1
            call dfovrg (ncycle, kfin, rmt, ilast, jri, p2, dx,
     1               ri, v,vval, dgcn, dpcn, adgc, adpc,
     1               xnval, pu, qu, p, q,
     1               iz, ihole, xion, iunf, irr, ic3)

            ilp = lfin - 1
            if (kfin .lt. 0) ilp = lfin + 1
            call exjlnl (xkmt, lfin, jl, nl)
            call exjlnl (xkmt, ilp, jlp1, nlp1)
            call phamp(rmt,pu,qu, ck, jl,nl,jlp1,nlp1, kfin, ph0,temp)

            sign = -1.0
            if (kfin.gt.0) sign = 1.0
            factor = ck*alphfs 
            factor = sign * factor/(1+sqrt(1+factor**2))
            dum1 = 1/ sqrt(1+factor**2)
            xfnorm = 1 / temp *dum1
c           normalization factor
c           xfnorm = dum1*rmt*(jl*cos(delta) - nl*sin(delta))/ Rl(rmt)
c           dum1 is relativistic correction to normalization
c           normalize regular solution
            do i = 1,ilast
              p(i)=p(i)*xfnorm
              q(i)=q(i)*xfnorm
            enddo

c           cut solutions beyond ii-th zero
            inul = ilast
c           set ii to the number of nodes to be found (including one at
c           norman radius) In case of Xe simple connection with jj index.
            ii = jj+ 1 + nlpoc
            if (jj.ge.nlp) ii = (jj-nlp) +1 + nlmoc
            do  i = 5, ilast
              if (dble(p(i-1))* dble(p(i)) .le. 0) then
                inul = i -1
                if (dble(p(i)).ne.0) ii = ii - 1
                if (ii.eq.0) goto 30
              endif
            enddo
   30       continue
            print*, 'getwf: second index should be 0; '
            print*, '   and distance close to norman radius'
            print*,  jj,ii,kfin,  'r(inul)' , ri(inul)*bohr
            print*,  jj, em*hart

            do i = 1,inul 
              pat(i)=dble(p(i))
              qat(i)=dble(q(i))
            enddo
          endif
c         orthogonalize pat to previous f-orbitals
          if(jj.le.nlp-1) then
            jin = 0
          else
            jin = nlp
          endif
          do jp = jin, jj-1
            ifp = iforb-2*((jp-jin)+1)
            do i = 1, ilast
              xp(i) = pat(i)*dgcnp(i,ifp) + qat(i)*dpcnp(i,ifp)
              xq(i) = 0
            enddo
            xinorm = 2*lfin + 2
            i0 = jint + 1
            call somm2 (ri, xp, dx, xinorm, rint, 0, i0)
            do i=1,nrptx
              pat(i) = pat(i) - xinorm*dgcnp(i,ifp)
              qat(i) = qat(i) - xinorm*dpcnp(i,ifp)
            enddo
          enddo

c         normalize pat and qat in the Norman radius sphere: <n|n>=1,
c         (renormalized atomic sphere method)
          do i = 1, ilast
            xp(i) = pat(i)**2 + qat(i)**2
            xq(i) = 0
          enddo
c         nb, xinorm is used for exponent on input to somm 
          xinorm = 2*lfin + 2
          i0 = jint + 1
          call somm2 (ri, xp, dx, xinorm, rint, 0, i0)
        
          xinorm = sqrt(xinorm)
          do i=1,nrptx
            pat(i) = pat(i) / xinorm
            qat(i) = qat(i) / xinorm
          enddo
          do  i=1, nrptx
            dgcnp(i,iforb) = pat(i)
            dpcnp(i,iforb) = qat(i)
          enddo
        enddo
      endif

      return 
      end 
      subroutine kkchi ( emu, edge, refsh, kinitm, kfinm, matsize,
     7                  em, ne, ne1, chi0im, chi0r)
   
     
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      parameter (maxsize = 78)
      dimension chi0im(nex,maxsize,maxsize)
      parameter (nexfk = 2000)
      dimension chi0fk(nexfk,maxsize,maxsize)
      dimension chi0r(nex,maxsize,maxsize)
      dimension kinitm(maxsize), kfinm(maxsize)
      dimension em(nex), emfk(nexfk)
      dimension refsh(maxsize)

c     E1 transitions, mult = 0

c     do 700 iemain = 1, ne
      do 700 iemain = 1, ne1
        w = em(iemain)   

c       make "fake" grid - a constant step energy grid around w

        eleft = em(1)
        eright = em(ne1) + 2.0/hart
        nefk = 2000
        step = (eright - eleft)/(nefk - 1)
        nel = int((w - eleft)/step)
c       w is between poits nel and nel+1
        delta = step/2.0 - ( (w - eleft) - step*nel )
        emfk(1) = eleft - delta         
        if (delta .gt. 0) emfk(1) = emfk(1) + step 
        do 11 ie = 2, nefk
          emfk(ie) = emfk(ie-1) + step
   11   continue       


        do 20 im = 1, matsize
        do 20 imp = 1, matsize

          chi0r(iemain,im,imp) = 0.0

          kinit = kinitm(im)
          kfin = kfinm(im)
          kdif = kfin - kinit
c         selection rules (buggy?)
c          ks = 1
c          if ( abs(kdif) .ne. ks .and. kfin .ne. - kinit ) goto 20    

c         find chi0im on the fake grid. Use simple linear interpolation

          do 16 ief = 1, nefk
           do 15 ie = 1, ne1
            if (emfk(ief) .eq. em(ie)) then
              chi0fk(ief,im,imp) = chi0im(ie,im,imp)
            else
              del1 = emfk(ief) - em(ie)
              del2 = emfk(ief) - em(ie+1)   
              if (del1*del2 .lt. 0.0 .or.ie.eq.ne1-1) then
                t1 = chi0im(ie,im,imp)*(em(ie+1) - emfk(ief))
                t2 = chi0im(ie+1,im,imp)*(emfk(ief) - em(ie))
                chi0fk(ief,im,imp) = (t1+t2)/(em(ie+1)-em(ie))
                goto 16
              endif
            endif
   15      continue
   16     continue

c         make integration
c         trapeozoid method 

c         here we use fake grid

          xint = 0.0
          do 920 ie = 1, (nefk-1)
            pint = 0.0
            e1 = emfk(ie)
            e2 = emfk(ie + 1)
c            w = wm(iw)
cc           integration starts at Ef (that is, em = edge)
            if (e1 .lt. (edge - refsh(im))) go to 920

c           add second pole contribution, if is.ne.0
            is = 1
c           is = 0
            nc = 0
            es = emu

            if ( e2 .gt. w .and. e1 .lt. w ) then
c             chi0(e) at E=w
              a1 = chi0fk(ie,im,imp) * (e2 - w)
c             if (is.ne.0) a1 = a1* 2 *(w +es)**2 /(2*es+w+e2)/(es+e2)
c             if (is.ne.0) a1 = a1* 2 /(2*es+w+e2)*(es+e2)
             if (is.ne.0) a1=a1*2/(w+es)**nc/(2*es+w+e2)*(es+e2)**(nc+1)
              a2 = chi0fk(ie+1,im,imp) * (w - e1)
c             if (is.ne.0) a2 = a2* 2 *(w +es)**2 /(2*es+w+e1)/(es+e1)
c             if (is.ne.0) a2 = a2* 2 /(2*es+w+e1)*(es+e1)
             if (is.ne.0) a2=a2*2/(w+es)**nc/(2*es+w+e1)*(es+e1)**(nc+1)
              xchiint = (a1 + a2) / (e2 - e1)
c             first term
              arg = (w - e1) / (e2 - w)
              pint = - xchiint * log(arg) 
              pint = pint + (chi0fk(ie+1,im,imp) - chi0fk(ie,im,imp))   
            else
              a1 = chi0fk(ie+1,im,imp) / (e2 - w)
c             if (is.ne.0) a1 = a1* 2 *(w +es)**2 /(2*es+w+e2)/(es+e2)
c             if (is.ne.0) a1 = a1* 2 /(2*es+w+e2)*(es+e2)
             if (is.ne.0) a1=a1*2/(w+es)**nc/(2*es+w+e2)*(es+e2)**(nc+1)
              a2 = chi0fk(ie,im,imp) / (e1 - w)       
c             if (is.ne.0) a2 = a2* 2 *(w +es)**2 /(2*es+w+e1)/(es+e1)
c             if (is.ne.0) a2 = a2* 2 /(2*es+w+e1)*(es+e1)
             if (is.ne.0) a2=a2*2/(w+es)**nc/(2*es+w+e1)*(es+e1)**(nc+1)
              pint = 0.5 * (e2 - e1) * (a2 + a1)
            endif
c           extra factor 1/pi
            pint =  pint / pi
 
            xint = xint + pint 
  920     continue  

c test constant shift
          shift = 0.0
          chi0r(iemain,im,imp) =  xint + shift

c         test - put real part of chi to 0
c         chi0r(iemain,im,imp) = 0

   20   continue
c     end of loop over im
   
  700 continue
c     end of energy loop            
       
      return 
      end
      subroutine meshlda (xkstep, ne, ne1, em, ik0)
     
      implicit double precision (a-h, o-z)
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
     
      complex*16 em(nex)

c     see arrays.h

c     constant step near Ef
c  manual input
cc for 3d elements
c     eleft = -15.0 / hart
c     eright = 15.0 / hart
c     eext = 60.0 / hart
cc for 4d, 5d elements
c     eleft = -15.0 / hart
c     eright = 75.0 / hart
c     eext = 150.0 / hart
cc for Xe and diamond and MgO
c     eleft = -15.0 / hart
c     eright = 45.0 / hart
c     eext = 135.0 / hart
cc for W and Ta
      eleft = -20.0 / hart
      eright = 200.0 / hart
      eext = 450.0 / hart

      ne = 100
      next = 20

      step = (eright - eleft)/(ne-1)
      step1 = (eext - eright)/(next-1)

      nk = int(sqrt((eright-eleft)/(2*xkstep)))
      next = 20
        
      ne1 = ne + next


      em(1) = eleft
      do 10 i = 2, ne
        em(i) = em(i-1) + step 
   10 continue
   
      do 20 i = ne+1, ne1
          em(i) = em(i-1) + step1 
   20 continue
c      do 20 i = ne+1, ne1
c         em(i) = em(i-1) + 4*((xkstep*(i - ne + 2))**2)
c   20 continue

c      do 25 i = 2, ne1
c         em(i) = em(i-1) + ((xkstep*i)**2)/2
c   25 continue
 
     
c     don't need ik0
      ik0 = 0
      

      return
      end

      subroutine yzktd(i,k,flps,ps,qs,aps,aqs,ykgr,j)
c nesvi - don't want to use common blocks to pass ykgr, otherwise it's
c         the same subroutine as yzkrdc

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 function ykgr.
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={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}

      complex*16 aprdec, dyzk
c     complex*16 a1,a2,b1,b2,coni
c     complex*16 xck, temp, ck, phx
      parameter (coni=(0.d0,1.d0))
      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/comdic/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/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idim
      dimension bgi(10),bpi(10)
      complex*16 bgj(10),bpj(10)

      complex*16 ykgr(nrptx)
c#mn
       external aprdec

c     construction of the function f
      do  5 l= 1,ibgp
        bgi(l) = bg(l,i)
  5     bpi(l) = bp(l,i)

      if (j.eq.0) then
        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 13 l=1,ndor
 13     ag(l) = aprdec(aps,bgi,l) + aprdec(aqs,bpi,l)
      else
        do 15 l= 1,ibgp
          bgj(l) = bg(l,i)
 15       bpj(l) = bp(l,i)
        id=min(nmax(i),nmax(j))
        ap(1)=fl(i)+fl(j)
        do 21 l=1,id
 21     dg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)
        do 22 l = id+1,idim
 22      dg(l) = 0.0d0
        do 23 l=1,ndor
 23     ag(l) = aprdec(bgj,bgi,l) + aprdec(bpj,bpi,l)
      endif

      dyzk = 0

      call yzktec (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim, dyzk)

      do 777 l=1,nrptx
c       yk is in dg
        ykgr(l) = dg(l)
  777 continue
 
      return
      end
      subroutine rdpotp ( vtot) 
c  opens pot.ch file and reads following information
c  Muffin-tin geometry
c     imt    - index of radial grid just below muffin-tin radii
c  Electron density information 
c     rhoint - interstitial density
c     rs     - r_s estimate from rhoint (4/3 r_s**3 * rhoint = 1)
c     xf     - estimate of momentum at Fermi level from rhoint
c     edens  - total electron density
c     edenvl - density from valence electrons
c     qnrm   - charge accumulated inside Norman sphere as result of SCF
c     xnmues - occupation numbers of valence orbitals from SCF procedure
c  Potential information
c     xmu    - Fermi level position
c     vint   - muffin-tin zero energy (interstitial potential)
c     vclap  - Coulomb potential
c     vtot   - vclap + xc potential from edens

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
      dimension imt(0:nphx), rmt(0:nphx), inrm(0:nphx),  rnrm(0:nphx)
      dimension folp(0:nphx), folpx(0:nphx), dgc0(251), dpc0(251)
      dimension dgc(251, 30, 0:nphx), dpc(251, 30, 0:nphx)
      dimension adgc(10, 30, 0:nphx), adpc(10, 30, 0:nphx)
      dimension edens(251, 0:nphx), vclap(251, 0:nphx)
      dimension vtot(251, 0:nphx), edenvl(251, 0:nphx)
      dimension vvalgs(251, 0:nphx), dmag(251, 0:nphx)
      dimension xnval(30,0:nphx), qnrm(0:nphx), xnmues(0:lx,0:nphx)
      dimension eorb(30), kappa(30)
      dimension iorb(-4:3,0:nphx), iz(0:nphx), xion(0:nphx)
      dimension xnatph(0:nphx)

      character*80 title(nheadx)

      dimension dum(13)

  10  format(a)
   20 format (bn, i15)

      open (unit=3, file='pot.ch', status='old')
      read(3,30) ntitle, nph, npadx, nohole, ihole, inters, iafolp,
     1            jumprm, iunf
  30  format(9(1x,i4))
c     nph and npadx are not passed to calling subroutine
      do 133  i  = 1, ntitle
         read(3,10) title(i)
         call triml(title(i))
  133 continue
c     Misc double precision stuff from pot.bin
      call rdpadd(3, npadx, dum(1), 13)
      rnrmav = dum(1)
      xmu    = dum(2)
      vint   = dum(3)
      rhoint = dum(4)
      emu    = dum(5)
      s02    = dum(6)
      erelax = dum(7)
      wp     = dum(8)
      ecv    = dum(9)
      rs     = dum(10)
      xf     = dum(11)
      qtotel = dum(12)
      totvol = dum(13)

c     read imt
      read (3, 40) (imt(i),i=0,nph)
  40  format(20(1x,i4))
      call rdpadd(3, npadx, rmt(0), nph+1)
c     read inrm
      read (3, 40) (inrm(i),i=0,nph)
      read (3, 40) (iz(i),i=0,nph)
      read (3, 40) (kappa(i),i=1,30)
      call rdpadd(3, npadx, rnrm(0), nph+1)
      call rdpadd(3, npadx, folp(0), nph+1)
      call rdpadd(3, npadx, folpx(0), nph+1)
      call rdpadd(3, npadx, xnatph(0), nph+1)
      call rdpadd(3, npadx, xion(0), nph+1)
      call rdpadd(3, npadx, dgc0(1), 251)
      call rdpadd(3, npadx, dpc0(1), 251)
      call rdpadd(3, npadx, dgc(1,1,0), 251*30*(nph+1) )
      call rdpadd(3, npadx, dpc(1,1,0), 251*30*(nph+1) )
      call rdpadd(3, npadx, adgc(1,1,0), 10*30*(nph+1) )
      call rdpadd(3, npadx, adpc(1,1,0), 10*30*(nph+1) )
      call rdpadd(3, npadx, edens(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, vclap(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, vtot(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, edenvl(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, vvalgs(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, dmag(1,0), 251*(nph+1) )
      call rdpadd(3, npadx, xnval(1,0), 30*(nph+1) )
      call rdpadd(3, npadx, eorb(1), 30)
      do 50 iph=0,nph
 50   read (3, 60) (iorb(i,iph),i=-4,3)
 60   format(8(1x,i2))
      call rdpadd(3, npadx, qnrm(0), nph+1 )
      nn = (lx+1)*(nph+1)
      call rdpadd(3, npadx, xnmues(0,0), nn )
      close (unit=3)
      imt0 = imt(0)
      rmt0 = rmt(0)
      inrm0 = inrm(0)
      rnrm0 = rnrm(0)

      return
      end
      subroutine correorb( iz, ihole, rmt, jri, dx, ri, p2f,edge,
     1       vxc, dgcn, dpcn, adgc, adpc, eorb,
     2       neg, eng, rhoj, kappa, norbp)
c     correct energy of the orbital for solid state potential
c     for deep core orbitals; output eng(1) (neg = 1, rhoj(1) = xx)
c     for valence band orbital create projected DOS on the 
c     orbital:  neg = number of energy points, eng - energy grid
c              rhoj(i) - projected DOS (sum_i rhoj(i) = xx)
c     coded by a.ankudinov 2004

c     input:
c        rmt     muffin-tin radius
c        jlast   last point for integration of Dirac eq.
c        jri     first interstitial grid point (imt + 1)
c        edge    shifted Fermi level
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        dgcn(dpcn) large(small) dirac components for 'iph' atom
c        adgc(adpc) their development coefficients

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      complex*16 vxc(nrptx), p2p, p2
      dimension ri(nrptx)
c     main output: energy points and weights
      dimension neg(30), eng(nex,30), rhoj(nex,30)
c     all atoms' dirac components and their development coefficients
c     orbitals(dgc,kappa), their energy(eorb) 
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30)
      dimension eorb(30), kappa(30)
      logical done

      do 20 i = jri+1,nrptx
 20   vxc(i)=vxc(jri+1)
c     calculate initial photoelectron orbital using lda
      ic3 = 0

c     do 300 iorb = 13, 13
      do 300 iorb = 1, 30
          print*,'iorb=',iorb, eorb(iorb)*hart
      if (eorb(iorb).ge.0.d0) goto 300
        norbp = iorb
        kfin = kappa(iorb) 
          xx = 2.d0 * abs(kfin)
        neg(iorb) = 1
        eng(1,iorb) = eorb(iorb) 
        vint = edge - p2f
        eng(1,iorb) = eorb(iorb) - vint
        rhoj(1,iorb) = xx / 2 /abs(kfin)

        do 250 ib = 1,2
        p2p = eng(1,iorb)
c       return point with different p2p, if not done
        done = .false.

c       use broadening to remove  possible resonant behaviour
c       when E_i - E_j = omega for occupied i and j
        gamb = max( 3.d0/hart, (p2f - dble(p2p))/5000)
        if (ib.eq.1) gamb = max( 3.d0/hart, (p2f - dble(p2p))/50)

 100    continue
        p2p = dble(p2p) + coni*gamb
           
        x1 = -1
        x2 = 0
        x3 = 1
        jlast = jri+6

        itest = 0
        if (itest.eq.1 ) then
          do 120 ie = -100, 100
           p2 = p2p + ie*gamb/3
          call cdos( iorb,p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1               iz, dgcn, dpcn, adgc, adpc, dos2)
          write( 57, 130) dble(p2) * hart, dos2
 120      continue
 130      format (2f15.4)
          stop
        endif

        call cdos( iorb,p2p, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1             iz, dgcn, dpcn, adgc, adpc, dos2)
      
        p2 = p2p - gamb
        call cdos( iorb,p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1             iz, dgcn, dpcn, adgc, adpc, dos1)
        p2 = p2p + gamb
        call cdos( iorb,p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1             iz, dgcn, dpcn, adgc, adpc, dos3)
        ncdos = 3

 200    continue
        t1 = (x3-x2)/dos1
        t2 = (x1-x3)/dos2
        t3 = (x2-x1)/dos3
        aqd = t1 + t2 + t3
        bqd = (x3+x2)*t1 + (x2+x1)*t3 + (x1+x3)*t2

        if (aqd.eq.0) then
c         1/dos is linear or constant
c         incrase broadening and try abain
          gamb = 2* gamb
          if (gamb.gt. abs(dble(p2p))) stop ' error in correrr.f' 
          goto 100
        endif

        x0 = bqd/aqd/2
        if ((dos1.le.0 .or. dos2.le.0 .or. dos3.le.0) .or.
     1   (1/dos1.gt.500 .and. 1/dos2.gt.500 .and. 1/dos3.gt.500) ) then
          p2p = p2p + gamb
          dos1 = dos2
          dos2 = dos3
          p2 = p2p + gamb
          call cdos(iorb, p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1              iz, dgcn, dpcn, adgc, adpc, dos3)
          ncdos = ncdos + 1
        elseif (x0.le.x3 .and.x0.ge.x1) then
          done = .true.
        elseif (x0.lt.x1) then
          p2p = p2p - gamb
          dos3 = dos2
          dos2 = dos1
          p2 = p2p - gamb
          call cdos(iorb, p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1              iz, dgcn, dpcn, adgc, adpc, dos1)
          ncdos = ncdos + 1
        elseif (x0.gt.x3) then
          p2p = p2p + gamb
          dos1 = dos2
          dos2 = dos3
          p2 = p2p + gamb
          call cdos(iorb, p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1              iz, dgcn, dpcn, adgc, adpc, dos3)
          ncdos = ncdos + 1
        endif

        if (.not.done) goto 200

        eng(1,iorb) = dble(p2p) + x0*gamb
 250  continue
c       eigenenergy eng above is relative to vint; to get energy
c        relative to absolute zero use line below
c       eng(1,iorb) = eng(1,iorb) +vint
 300  continue

c     spread energy levels into bands above Ecut
      ecut = 0
      itest = 1
      do 500 iorb = 1, norbp
      if (eng(1,iorb) .gt. ecut .and. itest.eq.0) then
        kfin = kappa(iorb) 
        xx = rhoj(1,iorb)
        gamb = max( 3.d0/hart, (p2f - dble(p2p))/50)
c       make energy grid 
        emin = ecut 
        emax = p2f
        de = gamb / 3
        ne = nint((emax-emin)/de)
        if (ne.le.1) ne = 2
        if (ne.gt.nex) ne = nex
        de =  (emax-emin) / (ne-1)
        neg(iorb) = ne
c       print*, 'iorb, sum', iorb, xx, kappa(iorb)
        sumx = 0
        do 400 ie = 1, ne
          eng(ie,iorb) = emin + (ie-1)*de
          p2 = eng(ie,iorb) + coni*gamb
          call cdos(iorb, p2, kfin,  rmt, jri, jlast, dx, ri, vxc,
     1              iz, dgcn, dpcn, adgc, adpc, dos)
          rhoj(ie,iorb) = dos
          sumx = sumx + dos
  400   continue
        xx = xx/sumx
        sumx = 0
        do 410 ie = 1,ne
          rhoj(ie,iorb) = rhoj(ie,iorb) * xx
          sumx = sumx + rhoj(ie,iorb)
  410   continue
c       print*, 'checksum', sumx
c       fix later: don't need xnval to check sum?

      endif
 500  continue

      return
      end
      subroutine phiscf (ifxc, rmt, jlast, jri, p2, edge, emu, dx,
     1      ri, vxc, edens, dgcn, dpcn, adgc, adpc, iz, ihole, neg, eng,
     2      rhoj, kappa, norbp, fscf, yvec, maxsize, matsize, sfun)
c     Zangwill-Soven effective field calculation
c     coded by a.ankudinov 2003

c     input:
c        rmt     muffin-tin radius
c        jlast   last point for integration of Dirac eq.
c        jri     first interstitial grid point (imt + 1)
c        p2      current complex energy
c        edge    shifted Fermi level
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        dgcn(dpcn) large(small) dirac components for 'iph' atom
c        adgc(adpc) their development coefficients
c     output:
c        fscf  - self-consistent radiation field

      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      complex*16 vxc(nrptx), p2, p2p
      complex*16 vxcp(nrptx)
      dimension ri(nrptx), edens(nrptx), fxc(nrptx)
      complex*16 pu, qu, vm(nrptx)
      complex*16 ps(nrptx), qs(nrptx), aps(10),aqs(10), xnorm1
      complex*16  api(10),aqi(10)
c     DOS information
      dimension neg(30), eng(nex,30), rhoj(nex,30), kappa(30)

c     new arrays for TDLDA
c     solution of homgeneous equations (needed for normalization)
      complex*16 ph(nrptx), qh(nrptx)
      complex*16 pir(nrptx), qir(nrptx)

      complex*16 dum1, factor, fscf(nrptx), yvec(nrptx, maxsize)
      complex*16 wronsk, hpp, jpp
      complex*16 chik(251,251), ww
      complex cchik(251,251)

c     bessel functions
      complex*16 ck, xkmt, ff, tl
      complex*16 jl(ltot+2), nl(ltot+2)
      complex*16 j0(ltot+2), n0(ltot+2)
      complex*16 jlp(0:ltot+1), hl(0:ltot+1)
      complex*16 jl0(0:ltot+1), hl0(0:ltot+1)


c     all atoms' dirac components and their development coefficients
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30)
 
c     iph 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/comdic/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/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/snoyac/dvn(nrptx),anoy(10),nuc
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idm

      external besjn

      iholep = 0
      xion = 0
      iunf = 1
      do 5 i = 1,30
 5    nmax(i) = 0
      cl = alpinv
      do 9 i = jri+2,nrptx
 9      vxc(i)=vxc(jri+1)
      ibgp=10
      numerr = 0
      nz = iz
      hx = dx
      idm= 1 + nint(250*0.05/dx)
      if (idm .gt. nrptx) idm = nrptx
      if (mod(idm,2) .eq. 0) idm=idm-1
c initialize
      do 10 i = 1, nrptx
  10  fscf(i) = 1
      do 20  i = 1,251
      do 20  j = 1,251
  20    cchik(i,j) =  0

c      itest = 1
c      if (itest .eq.1) goto 999

c     xc model: ifxc=0 --> RPA; ifxc=1 -->Znagwil soven adiabatic fxc
      do 40 i= 1, nrptx
c       also calculate the local exchange term fxc = vxc*r_s**3/r**2
        if (edens(i).le.0) then
          rs = 100
        else
          rs = (4*pi*edens(i)/3)**(-third)
        endif
c       vvbh from Von Barth Hedin paper, 1971
c       see eq.60-61 of Gross&Kohn, Adv. Quant. Chem. 21, p.255(1990).
c       eq.60 fxc = d V_xc / d rho * (2\ell + 1) /(4*pi*r**2)
c       where second factor comes from \delta(r-r')
c       for dipole field \ell=1 
c       fxc(i) = rs**3 / ri(i)**2 / 6 * (-1.22177412/rs -1.512/(30+rs))
cc      below are coefficients in Zangwill/Soven paper
        fxc(i) = rs**3 / ri(i)**2 / 6 * (-1.222/rs -0.75924/(11.4+rs))
        if (ifxc.eq.0) fxc(i) = 0
  40  continue


c     numerical integration of Dirac eq. works if you have 6 grid points
c     for one period of oscillations, switch to analytical expression
c     for a steplike potential  at large distances
      aa = 0.5d0
      ck =  sqrt (2*p2+ (p2*alphfs)**2)
      rwkb = aa / dx / abs(ck) 
      x0 = 8.8d0
      do 12 i =1, nrptx
12    dr(i) = exp(-x0 + (i-1)*dx)
      iwkb= (log(rwkb) + x0) / dx  +  2
      if (iwkb.gt.idm) iwkb = idm
      if (iwkb.lt. 10) iwkb = 10
      
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) 
 13      bp(i,j) = adpc(i,j) 
      do 15 j = 1, 30
      do 15 i = 1, nrptx
         cg(i,j) = dgcn(i,j) 
 15      cp(i,j) = dpcn(i,j) 

      ikap = 0
      call inmuac (iholep, xion, iunf, ikap)
      nmax(norb)=jlast
      if (iwkb.ge. jlast-1) iwkb = idm
c     note that here norb correspond to photoelectron

c     calculate initial photoelectron orbital using lda
      do 18 i = 1, nrptx
  18  vm(i)=0.0d0
      ic3 = 0

      if (ihole.ne.0) then
c       true x-ray photon energy, calcualtions are done for
        wp = dble(p2 + emu - edge)
c       wp = p2 + emu - edge -0.5
c       single electron energy for which chi0 is calculated
        ww = p2 - eng(1,ihole)

c       wp = 1
c       first power is needed to satisfy f-sumrule
        wp = (dble(ww)/wp)
c       wp = (dble(ww)/wp)**2

c       cycle over atomic orbitals and energy points
        do 155 iorb = 1, norbp
        do 155 ieg = 1, neg(iorb)
          kinit = kappa(iorb) 
          xx = rhoj(ieg, iorb)

c         cycle over 2 poles
          do 150 ind = 1, 2
c           print*, iorb, dble(ww)*hart, dble(eng(ieg,iorb)) * hart
            p2p = eng(ieg,iorb) + ww
            if (ind.eq.2)  p2p = eng(ieg,iorb) -dble(ww) +coni*dimag(ww)
            if (dble(p2p).lt.edge) then
c              no contibution to Im chi0. Only Re chi0 is important
c              use large broadening to remove  possible resonant behaviour
c              when E_i - E_j = omega for occupied i and j
               yy = eng(ieg, iorb) + dble(ww) 
               if (ind.eq.2) yy = eng(ieg, iorb) 
c              gamb = max( dimag(ww) , (edge - yy)/100)
               gamb = max( dimag(ww) , (edge - yy)/10)
c              gamb = dimag(ww) 
               p2p = dble(p2p) + coni*gamb
            endif
             
c           set complex momentum and call bessel functions
            ck =  sqrt (2*p2p+ (p2p*alphfs)**2)
            rmtx =  10.d0 / abs(dimag(ck))
            if (rmtx.gt.rmt) rmtx = rmt
            jrip = (log(rmtx) + x0) / dx + 2
            rmtp = ri(jrip) - 1.d-20
            do 133 i = 1, jrip
133         vxcp(i) = vxc(i)
            do 134 i = jrip+1, nrptx
134         vxcp(i) = vxc(jri+1)
            xkmt = rmtp * ck
            call besjn (xkmt, jl, nl)
            ix = ltot
            xkmt = ri(jrip) * ck
            call besjh (xkmt, ix, jl0, hl0)

c           set iwkb
            aa = 0.5d0
            rwkb = aa / dx / abs(ck) 
            iwkb= (log(rwkb) + x0) / dx  +  2
            if (iwkb.gt.idm) iwkb = idm
            if (iwkb.lt. 10) iwkb = 10
            if (iwkb.ge. jlast-1) iwkb = idm

c           cycle over dipole selection rules
            do 149 ik = -1,1
              kfin = kinit + ik
              if (ik.eq.0) kfin = -kfin
              if (kfin.eq.0) goto 149
c  test : final f states only
c             if (kfin.ne.-4 .and. kfin.ne.3 .and.kinit.ne.-4 .and.
c    1            kinit.ne.3) goto 149
c             if (kfin.ne.-3 .and. kfin.ne.2) goto 149
c  end test

              kap(norb) = kfin
              irr = -1
              call wfirdc (p2p, kap, nmax, vxcp, ps, qs,aps,aqs,irr,ic3,
     1           vm, rmtp, jrip, iwkb)
              do 130 i=1, idm
                ph(i) = ps(i)
                qh(i) = qs(i)
  130         continue
c             wronskian normalization of regular solution is below
c             find irregular solution first
              il = abs(kfin) 
              if (kfin.lt. 0) il = il - 1
              ilp = il - 1
              if (kfin .lt. 0) ilp = il + 1
              sign = -1.0
              if (kfin.gt.0) sign = 1.0
              factor = ck*alphfs
              factor = sign * factor/(1+sqrt(1+factor**2))
              dum1 = 1/ sqrt(1+factor**2)
              api(1) = hl0(il)  * rmtp * dum1
              aqi(1) = hl0(ilp) * rmtp * dum1 * factor
              irr = 1
              call wfirdc (p2p,kap,nmax,vxcp,pir,qir,api,aqi,irr,ic3,vm,
     1               rmtp, jrip, iwkb)

c             set irregular solution outside jrip
              il = abs(kfin)
              if (kfin.lt. 0) il = il - 1
              ilp = il - 1
              if (kfin .lt. 0) ilp = il + 1
              ilx = il+1
              if (ilp.gt.il) ilx=ilp+1
              ilx = ltot

c             get irregular solutions at jrip+1
              i = jrip+1
              xkmt = ck * ri(i)
              call besjh( xkmt, ilx, jlp, hl)
              dum2 = ri(i) / ri(jrip)
              pir(i) = pir(jrip) * dum2 * hl(il) /hl0(il)
              qir(i) = qir(jrip) * dum2 * hl(ilp)/hl0(ilp)

c             calculate wronskian at jrip
              wronsk= 2*alpinv* (pir(jrip)*qh(jrip) -ph(jrip)*qir(jrip))
              wronsk = 2 /wronsk

c             put wronskian normalization into irrregular solution
              do 136 i=1, jrip
                ph(i) = ph(i) * wronsk
                qh(i) = qh(i) * wronsk
  136         continue
              xkmt = ck * ri(jrip)
              tl = (ph(jrip)/(2*xkmt) - jl0(il)) /hl0(il)
              do 135 i = jrip+1, idm
                xkmt = ck * ri(i)
                call besjh( xkmt, ilx, jlp, hl)
                dum2 = ri(i) / ri(jrip)
                pir(i) = pir(jrip) * dum2 * hl(il) /hl0(il)
                qir(i) = qir(jrip) * dum2 * hl(ilp)/hl0(ilp)
                ph(i) = 2*xkmt* (jlp(il)+tl*hl(il))
                qh(i) = 2*xkmt* (jlp(ilp)+tl*hl(ilp))
  135         continue

c             make K(r,r') * chi0(r'r'') = chik(r,r")
              call lipman (iorb, ph,qh, pir,qir, fxc, jrip,
     1                     nmax(norb), chik)
              jfin2 = 2*abs(kfin) - 1
              jin2 = 2*abs(kinit) - 1
              aa= -cwig3j( jfin2,2,jin2, 1,0,2)**2 *(jfin2+1)*(jin2+1)/3
c             xx - fraction of the shell occupation
              aa =  aa * xx
c             wp - correction due to inequality of photon energy
c             and single electron energy differences
              aa = aa * wp
c             separation function (between ZS and PM)
              aa = aa * sfun
         
              do 161 i = 1,251
              do 161 j = 1,251
               itest = 0
               if (itest.eq.0) then
                 if (ind.eq.1 .and. dble(p2p).gt. edge) then
                  cchik(i,j) = cchik(i,j) + real(aa) *
     1            cmplx( real(dble(chik(i,j))), real(dimag(chik(i,j))))
                 else
                  cchik(i,j) = cchik(i,j) + real(aa) * 
     1            cmplx( real(dble(chik(i,j))), 0 )
                 endif
               else
                 if (ind.eq.1) then
                  cchik(i,j) = cchik(i,j) + real(aa) *
     1            cmplx( real(dble(chik(i,j))), real(dimag(chik(i,j))))
                 else
                  cchik(i,j) = cchik(i,j) + real(aa) * 
     1            cmplx( real(dble(chik(i,j))), -real(dimag(chik(i,j))))
                 endif
               endif
  161         continue
  149       continue
  150     continue
  155   continue

        itest = 0
        if (itest.eq.0) then
c         invert matrix and multiply by r
          nx = idm/5 + 1
          call chiklu(nx, dr, cchik, fscf, yvec, maxsize, matsize)
        elseif (itest.eq.1) then
c         do one iteration test
          do 191 i = 1,251
            i1 = 1+5*(i-1)
c           qir(i) =  fscf(i1) * dr(i1)
            qir(i) =  dr(i1)
            do 192 j=1,251
              j1 = 1+5*(j-1)
              qir(i) = qir(i) + cchik(i,j)*dr(j1)
c             qir(i) = qir(i) - cchik(i,j)*fscf(j1)*dr(j1)
  192       continue
            fscf(i1) = qir(i) / dr(i1)
  191     continue
        else
c         get f' and f" = r*chi0*r'
c         replace lipman.f with lipman.new also
          ff = 0
          do 194 i = 1,251
            i1 = 1+5*(i-1)
            qir(i) =  0
            do 193 j=1,251
              j1 = 1+5*(j-1)
c             qir(i) = qir(i) + chik(i,j)*dr(j1)
              qir(i) = qir(i) + cchik(i,j)*dr(j1)
  193       continue
            if (i.gt.1) then
              ff = ff + (qir(i) + qir(i-1)) * (dr(i1) - dr(i1-5))/2
            endif
  194     continue
c          do 196 i = 1,251
c           i1 = 1+5*(i-1)
c           write(56, *) dr(i1) , real(cchik(i,i)), aimag(cchik(i,i))
c 196      continue
          write(56, *) dble(ww)*hart, dble(ff), dimag(ff)
c         print*, dble(ww)*hart, dble(ff), dimag(ff)
        endif

c       write out scf field
        p2ev = dble(p2)*hart
c       if (p2ev.gt.14.d0 .and. p2ev.lt.15.d0) then
c       if (p2ev.gt.27.d0 .and. p2ev.lt.28.d0) then
c       if (p2ev.gt.41.d0 .and. p2ev.lt.42.d0) then
c       if (p2ev.gt.54.d0 .and. p2ev.lt.56.d0) then
        if (p2ev.gt.99.d0 .and. p2ev.lt.101.d0) then
c          print*, 305, idm
cc        write out scf field Re and Im parts
          do 305 i = 1,251
            i1 = 1 +5*(i-1)
            write(43,306) dr(i1), dr(i1)*dble(fscf(i1)),
     1        dr(i1)*dimag(fscf(i1))
c           write(43,306) dr(i1), dble (dgcn(i1, ihole))
  306       format(3f11.5)
c 306       format(3e14.5)
  305     continue
          close (unit=43)
          itest = 0
          if (itest.gt.1) stop 'test finished'
        endif
      endif

 999  continue
      return
      end
      subroutine chiklu( nx, dr, chik, fnew, yvec, maxsize, matsize)
c     fix later : this routine works only with RGRID 0.01 !
c     need to pass grid information and interpolate between
c     0.05 and finer grids

      implicit real (a-h,o-z)
      implicit integer (i-n)
c  input:
c     nx - number of points on 0.05 grids
c     dr - now 0.01 radial grid
c     chik - K*chi on coarse 0.05 grid
c     yvec(r,n) = K(r,r')*phi^n_init(r')*phi^n_final(r'),
c        where n - index in  double basis set
c     matsize - maximum n
c  output
c     fnew - (1-K*chi)^-1 r
c     yvec = (1-K*chi)^-1 yvec

c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={xparamtd.h
c nphasx MUST be the same as nphx, the maximum number of unique
c        potentials
c natxx MUST be the same as natx, the maximum number of atoms in the
c       extendeed cluster
c nexx MUST be the same as nex, the maximum number of energy points
      parameter (nphasx=nphx)
      parameter (natxx=natx)
      parameter (nexx=nex)
      parameter (istatx=(lx+1)**2*nclxtd*nspx)
      parameter (nkmin=1)
c     parameter (nkmin=-9)
c= xparamtd.h}

      parameter (one = 1, zero = 0)
      integer   ipiv(istatx)

c**** array of state kets at current energy
      common /stkets/ lrstat(4, istatx), istate

      complex   tmatrx(nspx, istatx)
      complex   chik(251,251)
c     big work matrices
      complex   g0( istatx, istatx), g0t( istatx, istatx)
      complex   g0s( istatx, nspx*(lx+1)**2)
c     return matrix containing info about each unique potential
      complex   gg(nspx*(lx+1)**2, nspx*(lx+1)**2, 0:nphasx)
      double precision dr(nrptx)
      complex*16 fnew(nrptx), yvec(nrptx, maxsize)

      character*3  cerr
      character*13 trans

 400  format(i4)


c -------------------- LU gg
c     multiply T and G0 matrices together, construct g0t = 1 - G0*T
c     notice that the signs below for g0t ARE correct since 1 is the
c     unit matrix
c     since t is tri-diagonal, this product can be computed in n^2 time
c     also fill up some work matrices for use in eigenvalue and
c     determinant calculations and elsewhere
      istate = nx
      do 320 icol = 1,istate
        do 310 irow = 1,istate
        g0t(irow, icol) = -chik(irow, icol)
 310    continue
        g0t(icol, icol) = g0t(icol, icol) + one
 320  continue

c --- invert matrix by LU decomposition
c     call cgetrf from lapack.  this performs an LU decomposition on
c     the matrix g0t = 1 - g0*T
      call cgetrf( istate, istate, g0t, istatx, ipiv, info )
      if (info.lt.0) then
          call wlog('    *** Error in cgetrf when computing G')
          write(cerr,400)abs(info)
          call wlog('        Argument #'//cerr//
     $                ' had an illegal value.')
      elseif (info.gt.0) then
          call wlog('    *** Error in cgetrf when computing G')
          write(cerr,400)info
          call wlog('        g0t('//cerr// ','//cerr//
     $                ') is exactly 0 -- '//
     $                'this matrix cannot be decomposed.')
      endif

c     now we want g_c = (g0t)^-1 * g0.  Rather than calculating
c     the inverse of g0t from the LU decomposition, we can compute
c     g0t^-1 * g0 directly by backsubstituting the columns of G0.
c     See sect. 2.3 in Numerical Recipes or LAPACK Users' Guide
c     sect. 2.3

c     third arg in number of output columns, istate for full
c     matrix, ipart(ik) for just the parts of the matrix needed
c     to contruct fine structure + DOS functions

      ipart = 1
      do 700 im = 0, matsize
        if (im.eq.0) then
           do 590 is1 = 1, istate
             i = 1+5*(is1-1)
             g0s(is1,ipart) = real(dr(i))
  590      continue
        else
           do 591 is1 = 1, istate
             i = 1+5*(is1-1)
             g0s(is1,ipart) = real(dble(yvec(i,im)))
  591      continue
        endif

        trans = 'NotTransposed'
        call cgetrs(trans, istate, ipart, g0t, istatx,
     $                ipiv, g0s, istatx, info)
        if (info.lt.0) then
            call wlog('    *** Error in cgetrf')
            write(cerr,400) abs(info)
            call wlog('        Argument #'//cerr//
     $              ' had an invalid value.')
        endif

c **** at this point g0s contains the full MS ****

c  pack FMS matrix into an nsp*(lx+1)^2 x nsp*(lx+1)^2 matrix for each
c  ipot

        do 600 is=1,istate
          i = 1+5*(is-1)
          if (im.eq.0) then
            fnew(i) = cmplx(dble(real(g0s(is,ipart))),
     1                      dble(aimag(g0s(is,ipart)))) / dr(i)
            if (is.gt.1) then
              do 595 j=1,4
  595         fnew(i-j) = ( j*fnew(i-5) + (5-j)*fnew(i)) / 5
            endif
          else
            yvec(i,im) = cmplx(dble(real(g0s(is,ipart))),
     1                      dble(aimag(g0s(is,ipart)))) / dr(i)
            if (is.gt.1) then
              do 596 j=1,4
  596         yvec(i-j,im) = ( j*yvec(i-5,im) + (5-j)*yvec(i,im)) / 5
            endif
          endif
 600    continue
 700  continue

      return
      end
      subroutine cdos (iorb, p2, ikap, rmt, jri,jlast, dx, ri, vxc,
     1   iz, dgcn, dpcn, adgc, adpc, dos)
c     calculate central atom DOS with wronskian normalization
c     which can be used to find very deep core levels.
c     coded by a.ankudinov 2004

c     input:
c        p2  - energy
c        ikap    quantum number kappa for the orbital
c        rmt     muffin-tin radius
c        jlast   last point for integration of Dirac eq.
c        jri     first interstitial grid point (imt + 1)
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     output:
c        dos  - dos at energy p2


      implicit double precision (a-h, o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}

      complex*16 vxc(nrptx), p2, p2p
      complex*16 vxcp(nrptx)
      dimension ri(nrptx)
      complex*16 ph0, pu, qu, vm(nrptx)
      complex*16 ps(nrptx), qs(nrptx), aps(10),aqs(10), xnorm1
      complex*16  api(10),aqi(10)
c     all atoms' dirac components and their development coefficients
      dimension dgcn(nrptx,30), dpcn(nrptx,30)
      dimension adgc(10,30), adpc(10,30)

c     new arrays for TDLDA
c     solution of homgeneous equations (needed for normalization)
      complex*16 ph(nrptx), qh(nrptx)
      complex*16 pir(nrptx), qir(nrptx), xirf

      complex*16 dum1, factor, pun, qun
      complex*16 wronsk, hpp, jpp
c     need to save pun and qun to start irregular solutions

c     bessel functions
      complex*16 ck, xkmt, tl
      complex*16 jl(ltot+2), nl(ltot+2)
      complex*16 j0(ltot+2), n0(ltot+2)
      complex*16 jlp(0:ltot+1), hl(0:ltot+1)
      complex*16 jl0(0:ltot+1), hl0(0:ltot+1)

c     iph 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/comdic/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/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/snoyac/dvn(nrptx),anoy(10),nuc
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idm

      external besjn

c     get orbitals(dgc,kappa), their energy(eorb) and occupation(xnval)
      ipr1 = 0
      iph = 0
      nph =1
      xion = 0
      iunf = 1
      ispinr = 0
      do 10 i = 1,30
 10   nmax(i) = 0
      ndor = 3
      cl = alpinv
      numerr = 0
      nz = iz
      hx = dx
      idm= 1 + nint(250*0.05/dx)
      if (idm .gt. nrptx) idm = nrptx
      if (mod(idm,2) .eq. 0) idm=idm-1
c     copy information into common's of atomic code
      ibgp=10
      do 20 j = 1, 30
      do 20 i = 1, 10
         bg(i,j) = adgc(i,j)
 20      bp(i,j) = adpc(i,j)
      do 30 j = 1, 30
      do 30 i = 1, nrptx
         cg(i,j) = dgcn(i,j)
 30      cp(i,j) = dpcn(i,j)
c initialize
      iholep = 0
      kkap = 0
      call inmuac (iholep, xion, iunf, kkap)
c     norb = norbp
      nmax(norb)=jlast
c     note that here norb correspond to photoelectron

c     numerical integration of Dirac eq. works if you have 6 grid points
c     for one period of oscillations, switch to analytical expression
c     for a steplike potential  at large distances
      aa = 0.5d0
      ck =  sqrt (2*p2+ (p2*alphfs)**2)
      rwkb = aa / dx / abs(ck) 
      x0 = 8.8d0
      do 35 i =1, nrptx
 35   dr(i) = exp(-x0 + (i-1)*dx)
      iwkb= (log(rwkb) + x0) / dx  +  2
      if (iwkb.gt.idm) iwkb = idm
      if (iwkb.lt. 10) iwkb = 10
      
      if (iwkb.ge. jlast-1) iwkb = idm
c     note that here norb correspond to photoelectron

c     calculate initial photoelectron orbital using lda
      call diff (vxc,ri,ikap,cl,hx,jri,vm)
      do 40 i = jri+1,nrptx
  40  vm(i)=0.0d0
      ic3 = 0

      p2p = p2
c     set complex momentum and call bessel functions
      ck =  sqrt (2*p2p+ (p2p*alphfs)**2)
      rmtx =  10.d0 / abs(dimag(ck))
      if (rmtx.gt.rmt) rmtx = rmt
      jrip = (log(rmtx) + x0) / dx + 2
      rmtp = ri(jrip) - 1.d-20
      do 50 i = 1, jrip
 50   vxcp(i) = vxc(i)
      do 60 i = jrip+1, nrptx
 60   vxcp(i) = vxc(jri+1)
      xkmt = rmtp * ck
      call besjn (xkmt, jl, nl)
      ix = ltot
      xkmt = ri(jrip) * ck
      call besjh (xkmt, ix, jl0, hl0)

c     set iwkb
      aa = 0.5d0
      rwkb = aa / dx / abs(ck) 
      iwkb= (log(rwkb) + x0) / dx  +  2
      if (iwkb.gt.idm) iwkb = idm
      if (iwkb.lt. 10) iwkb = 10
      if (iwkb.ge. jlast-1) iwkb = idm

      kfin = ikap
      kap(norb) = kfin
      irr = -1
      call wfirdc (p2p, kap, nmax, vxcp, ps, qs,aps,aqs,irr,ic3,
     1           vm, rmtp, jrip, iwkb)
      do 70 i=1, idm
        ph(i) = ps(i)
        qh(i) = qs(i)
   70 continue
c     wronskian normalization of regular solution done below
c     find irregular solution first that matches H_l outside
      il = abs(kfin) 
      if (kfin.lt. 0) il = il - 1
      ilp = il - 1
      if (kfin .lt. 0) ilp = il + 1
      sign = -1.0
      if (kfin.gt.0) sign = 1.0
      factor = ck*alphfs
      factor = sign * factor/(1+sqrt(1+factor**2))
      dum1 = 1/ sqrt(1+factor**2)
      api(1) = hl0(il)  * rmtp * dum1
      aqi(1) = hl0(ilp) * rmtp * dum1 * factor
      irr = 1
      call wfirdc (p2p,kap,nmax,vxcp,ps,qs,api,aqi,irr,ic3,vm,
     1       rmtp, jrip, iwkb)

c     set irregular solution outside jrip
      il = abs(kfin)
      if (kfin.lt. 0) il = il - 1
      ilp = il - 1
      if (kfin .lt. 0) ilp = il + 1
      ilx = il+1
      if (ilp.gt.il) ilx=ilp+1
      ilx = ltot
      do 80 i = jrip+1, idm
        xkmt = ck * ri(i)
        call besjh( xkmt, ilx, jlp, hl)
        dum2 = ri(i) / ri(jrip)
        ps(i) = ps(jrip) * dum2 * hl(il) /hl0(il)
        qs(i) = qs(jrip) * dum2 * hl(ilp)/hl0(ilp)
  80  continue

c     calculate wronskian at jrip
      hpp = (ps(jrip+1)/ri(jrip+1) - ps(jrip-1)/ri(jrip-1) ) /
     1               (ri(jrip+1) - ri(jrip-1) )
      jpp = (ph(jrip+1)/ri(jrip+1) - ph(jrip-1)/ri(jrip-1) ) /
     1               (ri(jrip+1) - ri(jrip-1) )
c     hpp = qs(jrip)/ri(jrip)
c     jpp = qh(jrip)/ri(jrip)
c     wronsk = ri(jrip)* ( ps(jrip) * jpp - ph(jrip)*hpp)
      wronsk = 2*alpinv*(ps(jrip)*qh(jrip) - ph(jrip)*qs(jrip))

cc    project green's function on the atomic orbital

c     put wronskian normalization into regular solution
      wronsk = 2 /wronsk
      do 90 i=1, idm 
        ph(i) = ph(i) * wronsk
        qh(i) = qh(i) * wronsk
        qir(i) = cg(i,iorb) * ph(i) + cp(i,iorb) * qh(i)
        if (i.gt.1) then
          pir(i)= pir(i-1) + (qir(i) + qir(i-1))*(ri(i)-ri(i-1))
        else
          pir(i)= qir(i)*ri(i)
        endif
  90  continue
      do 100 i=1,idm
        ph(i) = cg(i,iorb) * pir(i)
        qh(i) = cp(i,iorb) * pir(i)
  100 continue
      do 110 i=1, idm 
        qir(i) = ps(i) * ph(i) + qs(i) * qh(i)
  110 continue

      xirf = 0
      call csomm2 (ri, qir, dx, xirf, ri(jrip), jrip+1)
      gamb = dimag(p2p)
      dos = dimag(xirf) * gamb

      return
      end
      subroutine lipman( j1, ph, qh, pir, qir, fxc, jri, imx0,  chik)
c     calculate K*chi_0 matrix, by perorming radial integration
c     chik(r,r") = \int d r' K(r,r') \chi0(r', r") * (hx*r(i))
c     K(r,r') = r< / r>**2  + fxc(r)*\delta(r-r')
c     chi0(r',r") = \phi_j1(r') \phi_j1(r") R_l(r<) H_l(r>)
c     (hh*r(i)) - factor needed on exponential grid integration
c      and is required for matrix inversion in r-space
c     imx0 the last point of tabulation of the wave function
 
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      parameter (npi=6, test=1.0d+5)
      parameter (ccl=2*alpinv, csq=ccl**2 )
      complex*16 en,agi,api
      complex*16 chik (251,251) 
      complex*16 gg,ag,gp,ap,dv,av,eg,ceg,ep,cep, vm(nrptx)
      common/comdic/cl,dz,gg(nrptx),ag(10),gp(nrptx),ap(10),dv(nrptx),
     1   av(10),eg(nrptx),ceg(10),ep(nrptx),cep(10)
      common/dff/cg(nrptx,30),cp(nrptx,30),bg(10,30),bp(10,30),
     1             fl(30), fix(30), ibgp

      complex*16 ec,eph,f,g, ph(nrptx), qh(nrptx)
      complex*16 pir(nrptx), qir(nrptx)
      dimension fxc(nrptx)
c
      common/tabtec/hx,dr(nrptx),test1,test2,ndor,np,nes,method,idm
      complex*16 f1(nrptx), f2(nrptx), f3(nrptx), f4(nrptx)
c hx exponential step
c dr radial mesh
c idm dimension of the block dr

c     initialize
      do 20 i0 = 1,251
      do 20 j0 = 1,251
        chik(i0,j0) = 0
 20   continue

      do 205 i = 1, imx0
        eg(i) = (cg(i,j1) * ph(i) + cp(i,j1) *qh(i)) / dr(i)**2
 205  continue
      f1(1) = 0
      do 210 i = 1, imx0-1
        f1(i+1) = f1(i) + (dr(i+1)-dr(i)) / 2 * (eg(i)+eg(i+1))
 210  continue

      do 215 i = 1, imx0
        eg(i) = (cg(i,j1) * ph(i) + cp(i,j1) *qh(i)) * dr(i)
 215  continue
      f2(1) = 0
      do 220 i = 1, imx0-1
        f2(i+1) = f2(i) + (dr(i+1)-dr(i)) / 2 * (eg(i)+eg(i+1))
 220  continue

      do 225 i = 1, imx0
        eg(i) = (cg(i,j1) * pir(i) + cp(i,j1) *qir(i)) / dr(i)**2
 225  continue
      do 230 i = jri, imx0
 230  f3(i) = 0
      do 235 i =  jri-1, 1, -1
        g = eg(i)*pir(i) + ep(i)*qir(i)
        f3(i) = f3(i+1) + (dr(i+1)-dr(i)) / 2 * (eg(i) + eg(i+1))
 235  continue

      do 245 i = 1, imx0
        eg(i) = (cg(i,j1) * pir(i) + cp(i,j1) *qir(i)) * dr(i)
 245  continue
      do 250 i = jri, imx0
 250  f4(i) = 0
      do 255 i =  jri-1, 1, -1
        f4(i) = f4(i+1) + (dr(i+1)-dr(i)) / 2 * (eg(i) + eg(i+1))
 255  continue

      hh = 0.05d0
      do 265 i = 1, imx0
        gg(i) = cg(i,j1) * ph(i) + cp(i,j1) * qh(i)
        eg(i) = gg(i) * hh * dr(i)
        gp(i) = cg(i,j1) * pir(i) + cp(i,j1) * qir(i)
        ep(i) = gp(i) * hh * dr(i)
 265  continue
      do 280 i0 = 1,251
         i = 1 + 5*(i0-1)
         do 275 j0 = 1,251
           j = 1 + 5*(j0-1)
           if (i.gt.imx0 .or.j.gt.imx0) goto 275

           if (i0.le.j0) then
             chik(i0,j0) = chik(i0,j0) +
     1       (f2(i)/dr(i)**2 + (f1(j)-f1(i))*dr(i)) * ep(j) +
     2       f3(j)*dr(i) * eg(j)
c  add xc part
             chik(i0,j0) = chik(i0,j0) + fxc(i)* gg(i) * ep(j)
           else
             chik(i0,j0) = chik(i0,j0) +
     1       f2(j)/dr(i)**2 * ep(j) +
     2       ((f4(j)-f4(i))/dr(i)**2 + f3(i)*dr(i)) * eg(j)
c  add xc part
             chik(i0,j0) = chik(i0,j0) + fxc(i)* gp(i) * eg(j)
           endif
 275     continue
 280  continue

      return
      end
      subroutine ridxmu(kinit, ne, ee,
     1                 chil2, chil3, chil4, chil5, deltaso)
cc    reads several xmu.dat files and interpolates fine structure
cc    on energy grid given by array ee
cc    Input:
cc       kinit - initial state kappa
cc       ne - number of points in energy grid
cc       ee - energy grid
cc    Output:
cc       chil* - (1+chi) for various channels
cc       deltaso - spin-orbit splitting between 2 edges
cc    wirrten by Alexei Ankudinov , Dec. 2004
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      dimension ee(nex), chil2(nex), chil3(nex), chil4(nex), chil5(nex)
      dimension x1(nex), x2(nex), x3(nex), x4(nex), x5(nex), x6(nex)
      dimension y1(nex), y2(nex), y3(nex), y4(nex), y5(nex), y6(nex)
      dimension s1(nex), s2(nex), s3(nex), s4(nex), s5(nex), s6(nex)
      dimension t1(nex), t2(nex), t3(nex), t4(nex), t5(nex), t6(nex)
      character*52 filename

c     initialize all (1+chi) to 1
      do ie = 1, nex
        chil2(ie) = 1.d0
        chil3(ie) = 1.d0
        chil4(ie) = 1.d0
        chil5(ie) = 1.d0
      enddo

c     get xmu.dat for the dominant l-->l+1 cahnnel
      filename = 'Oddp1/xmu.dat'
      call xmudat(filename, x1, x2, x3, x4, x5, x6, n, e1)
      deltaso = 0.d0
      if (kinit.lt.-1) then
c       get second edge xmu.dat for l-->l+1 channel
        filename = 'Evenp1/xmu.dat'
        call xmudat(filename, y1, y2, y3, y4, y5, y6, m, e2)
        deltaso = (e2-e1) / hart
        do i = 1, m
          y2(i) = y2(i) + deltaso
        enddo
c       get  xmu.dat files  for l-->l-1 channels
        filename = 'Oddm1/xmu.dat'
        call xmudat(filename, s1, s2, s3, s4, s5, s6, n, ef)
        filename = 'Evenm1/xmu.dat'
        call xmudat(filename, t1, t2, t3, t4, t5, t6, m, ef)
      endif

c     construct energy grid (ee) from 2 grids (x2 and y2)
      if (deltaso.eq. 0.d0) then
c       special case if deltaso = 0, then ee=x2
        ne = n
        do ie = 1, ne
          ee(ie) = x2(ie)
        enddo
      else
c       need to combine 2 grids
c       start with x grid until first y point
        do i = 1, n
          if (x2(i).lt.y2(1)) then
            ix = i
            ee(ix) = x2(ix)
          endif
        enddo
        ne = ix
        iy = 1
c       continue with x grid until xstep is less than ystep
  20    continue
          if ( ix.eq.n) goto 30
          if ( y2(iy).ge.e2) goto 30

          xstep = x2(ix+1)-x2(ix)
          ystep = y2(iy+1)-y2(iy)
          if (ystep.le.xstep) goto 30

          ne = ne+1
          ix = ix+1
          ee(ne) = x2(ix)
c         next y-point if the end of y-interval beyond the end of x-interval
          if (x2(ix+1).gt.y2(iy+1)) iy = iy + 1
        goto 20

  30    continue
c       continue with y-grid; keep nex as a maximum number of points
        np = min(m, nex-ne+iy-1)
        do i = iy, np
          ne = ne + 1
          ee(ne) = y2(i)
        enddo
      endif
c     end of energy mesh construction

c     interpolate fine structure on the energy grid ee
      do ie = 1, ne
        z1 = ee(ie)
        xnew = 1
        if (z1.ge.x2(1).and.z1.le.x2(n)) 
     1     call terp (x2,x6,n,3,z1, chil3(ie))
        if (kinit.lt.-1) then
          if (z1.ge.y2(1).and.z1.le.y2(m))
     1      call terp (y2,y6,m,3,z1, chil2(ie))
          if (z1.ge.s2(1).and.z1.le.s2(n))
     1      call terp (s2,s6,n,3,z1, chil5(ie))
          if (z1.ge.y2(1).and.z1.le.y2(m))
     1      call terp (y2,t6,m,3,z1, chil4(ie))
        endif
      enddo

c     for each edge find energy point (ix) with first nonzero chi,
c     padd the energy points below ix with chi(ix) to avoid jumps in xmu
c     notice that at high energies chi=0 ,
c     since extrapolation has not been used
      ix = 0
      do ie = 1, ne
        if (ix.eq.0 .and. abs( chil3(ie)-1.d0 ).ne.0.d0) ix = ie
      enddo
      do ie = 1,ix-1
        chil3(ie) = chil3(ix)
      enddo
      if (kinit.lt.-1) then
c       do the same with the rest of the data
        do ie = 1,ix-1
          chil5(ie) = chil5(ix)
        enddo
        ix = 0
        do ie = 1, ne
          if (ix.eq.0 .and. abs( chil2(ie)-1.d0 ).ne.0.d0) ix = ie
        enddo
        do ie = 1,ix-1
          chil2(ie) = chil2(ix)
          chil4(ie) = chil4(ix)
        enddo
      endif

      do ie = 1, ne
      write(18,*) ee(ie)*hart, chil3(ie), chil2(ie)
      enddo

      return
      end

      subroutine xmudat (filename, x1, x2, x3, x4, x5, x6, n, ef)
      implicit double precision (a-h,o-z)
c={../HEADERS/dim.h
c      maximum number of atoms for FMS. Reduce nclusx if you need
c      smaller executable.
      parameter (nclusx=100)
c      maximum number of atoms for tdlda module.
      parameter (nclxtd=100)
c      max number of spins: 1 for spin average; 2 for spin-dep
      parameter (nspx=1)
c      max number of atoms in problem for the pathfinder
      parameter (natx =1000)
c      max number of atoms in problem for the rdinp and ffsort
      parameter (nattx =1000)
c      max orbital momentum for FMS module.
      parameter (lx=4)
c      max number of unique potentials (potph) (nphx must be ODD to
c      avoid compilation warnings about alignment in COMMON blocks)
      parameter (nphx = 11)
c      max number of ang mom (arrays 1:ltot+1)
      parameter (ltot = 24)
c      Loucks r grid used through overlap and in phase work arrays
      parameter (nrptx = 1251)
c      Number of energy points genfmt, etc.
      parameter (nex = 150)
c      Max number of distinct lambda's for genfmt
c      15 handles iord 2 and exact ss
      parameter (lamtot=15)
c      vary mmax and nmax independently
      parameter (mtot=4, ntot=2)
c      max number of path atoms, used in path finder, NOT in genfmt
      parameter (npatx = 8)
c      matches path finder, used in GENFMT
      parameter (legtot=npatx+1)
c      max number of overlap shells (OVERLAP card)
      parameter (novrx=8)
c      max number of header lines
      parameter (nheadx=30)
c      max number of poles that can be used to
c      model epsilon^-1 for HL multipole self energy
      parameter (MxPole=1000)
c= ../HEADERS/dim.h}
c={../HEADERS/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 (hart = 2 * ryd)
      parameter (alpinv = 137.035 989 56d0)
c     fine structure alpha
      parameter (alphfs = 1 / alpinv)
c= ../HEADERS/const.h}
      dimension x1(nex), x2(nex), x3(nex), x4(nex), x5(nex), x6(nex)
      character*512 string
      character*52 filename

      n = 0
      open (file=filename, unit=3, status='unknown',iostat=ios)
 10   read(3,'(a)', end=20) string
      if (string(4:10).eq.'-------') goto 30
      goto 10
       
c     check if xmu.dat file does not have the data
 20   stop ' xmu.dat is empty'

 30   continue
      read(3,'(a)',end=20) string

 40   n=n+1
      read(3,*,end=50)    x1(n), x2(n), x3(n), x4(n), x5(n), x6(n)
      if (x3(n).gt.-0.01d0 .and. x3(n).lt.0.01d0) ef = x1(n)
      x6(n) = x6(n)/x5(n) + 1
      x2(n) = x2(n) / hart
      goto 40

 50   continue
      n = n -1

      close (unit=3)
      return
      end
