      program phagen

c  ....................................
C  ..                                ..
c  .. Generates atomic phase shifts  ..
c  .. for inequivalent atoms in a    ..
c  .. given cluster. Prototypical    ..
c  .. atoms selected automatically.  ..
c  .. Muffin-tin radii and type of   ..
c  .. final state potential selected ..
c  ..       via input option         ..
C  ..                                ..
c  ..    By C.R. Natoli 15/10/93     ..
C  ..                                ..
c  .. This version can handle ES     ..
c  .. ES = Empty Spheres 28/09/2007  ..
C  ..                                ..
C  .. Scalar-relativistic version    ..
C  ..   with spin-orbit selection    ..
C  ..   by C.R. Natoli  9 june 2011  ..
C  ..                                ..
C  ....................................
c  ....................................
C
c  .. INCOMING WAVE BOUNDARY CONDITIONS
c
C  ....................................
C
C        bug corrected in subroutine 
C              GET_CORE_STATE 
C            (FDP 18th May 2006)
C
C        bug corrected in subroutine
C        ALPHA0 (DS : 7th May 2007)
C        2nd dimension r: 150 ---> UA_
C
C        LEED case (calctype = 'led')
C        added (DS : 30th May 2007).
C
C        bug corrected in subroutine
C        SETEQS (DS+CRN 30th May 2007) :
C        z_shift=5.0 and i_z_shift=5
C        instead of 0.0 and 0.
C
C        bug corrected in subroutines
C        MOLDAT,GRPNEI,WRIDAT :
C        NEIMAX set to nat_ instead
C        of 350 in PARAMETER statement
C        (FDP+DS 4th June 2007)
C
C        all error output redirected to
C        unit 6 (DS 4th March 2008).
C
C        modified to handle high Z elements
C           (CRN : september 2008)
C
C        cleaned : DS 17th November 2008
C
C        modified to impose lmaxt externally
C           (CRN : july 2009)
C
C        modified to include quadrupole 
C        radial matrix elements
C           (CRN : june 2012)
C
C        File formats for radial integrals
C        modified (DS 8th january 2013)
C
C        modified to introduce t-matrix 
C        calculation in the eikonal approximation
C           (CRN : march 2013)
C
C        bug corrected in routine linlogmesh: rhon ---> r_sub
C           (CRN : april 2013)
C
C        modified to calculate tmatrix, radial integrals 
C        and atomic cross sections on linearlog mesh
C           (CRN: september 2012 and april 2013)
C
C        bug corrected in routine pgenll2: complex*16 dnm.
C        v potential converted to complex*16 in routines
C        pgenll1m and pgenll2 
C           (CRN: april 2013)
C
C        bug corrected in the calculation of the total mfp = amfpt
C           (CRN: april 2014)
C
C        modified to calculate eels regular radial matrix elements
C           (CRN: november 2014)
C
C        modified to convert energy input data in data3.ms to Ryd
C           (CRN: november 2014)
C
C        modified to calculate eels and xas/rexs irregular radial matrix elements
C           (CRN: juin 2015)
C
C        modified to calculate e2e regular radial matrix elements
C           (CRN: december 2015) modification in subroutine smtxllm
C           statement 13824
C
C        bug corrected in subroutine calc_edge (xion = 0 for ground state)
C           (CNR: June 2017)
 
      implicit real*8 (a-h,o-z)
c
      include 'msxas3.inc'
      include 'msxasc3.inc'
c
c.. constants
c
      antoau  = 0.52917715d0
      pi      = 3.141592653589793d0
      ev      = 13.6058d0
      zero    = 0.d0
c
c.. threshold for linearity
c
      thresh  = 1.d-4
c
c.. fortran io units
c
      idat = 5
      iwr = 6

c      iwr = 16
      iwf=32
      iphas = 30
      iedl0 = 31
      iof = 17
c.......................................................
c      open (iwr,file='results.dat',form='formatted',status='unknown')
      write(iwr,1000)
c...
c      open (idat,file='data/auger.ms',status='old')
c      open (iphas,file='phases.dat',status='unknown')
c      if (calctype.eq.'xpd') then
      call system('mkdir -p div/wf')
      call system('mkdir -p plot')
      call system('mkdir -p tl')

      open (iphas,file='div/phases.dat',form='formatted',
     1      status='unknown')
      open (iedl0,file='div/exdl0.dat',form='unformatted',
     1      status='unknown')
      open (iof,file='div/inf.xas',form='unformatted',status='unknown')
c      open (iwr,file='phagen_3.lis',status='unknown')

      open (unit=21,form='unformatted',status='scratch')
      open (60,file='div/file060.dat',form='formatted',status='unknown')
      open (50,file='div/filerme.dat',form='formatted',
     1      status='unknown')
c      open (56,file='div/eelsrme.dat',form='formatted',
c     1      status='unknown')
      open (unit=13,file='div/filepot.dat',form='formatted',
     1      status='unknown')
      open (unit=14,file='div/filesym.dat',form='formatted',
     1      status='unknown')
      open(unit=11,file='div/fort.11',status='unknown')
c      open(unit=56,file='div/nchannels.dat',status='unknown')
      open(unit=32,file='div/wf/wf1.dat',status='unknown')
      open(unit=33,file='div/wf/wf2.dat',status='unknown')
      open(unit=66,file='div/file066',status='unknown')
c      open(unit=15,file='div/vrel.dat',status='unknown')  !in sub vrel
c      open(unit=34,file='wf3.dat',status='unknown')
      open(unit=70,file='div/tl-nr.dat',status='unknown')
      open(unit=71,file='div/phases-nr.dat',status='unknown')
c
      open(unit=80,file='div/tl-sr.dat',status='unknown')
      open(unit=81,file='div/phases-sr.dat',status='unknown')
c
      open(unit=90,file='div/tl-so.dat',status='unknown')
      open(unit=91,file='div/phases-so.dat',status='unknown')
C
C  Storage of old t_l calculation (subroutine smtx) for reference
C
      open(unit=95,file='div/tl_ref.dat',status='unknown')
c
      open(unit=98,file='div/cshsm.dat',status='unknown')
c
      open(unit=99,file='div/csllm.dat',status='unknown')
c      open(unit=69,file='check.log',status='unknown')
c      else

c      open(iphas,file='phasesaed.dat',form='formatted',status='unknown'
c      open (iwf,file='wfaed.dat',form='formatted',status='unknown')
c      open(iedl0,file='exdl0aed.dat',form='unformatted',
c     * status='unknown')
c      open (iof,file='infaed.xas',form='unformatted',status='unknown')


c      open (iwr,file='phagen_12aed.lis',status='unknown')
c      write(iwr,*)'ciao'

c      open (unit=21,form='unformatted',status='scratch')
c      open (60,file='file060aed.dat',form='formatted',status='unknown')
c      open (50,file='fileatcsaed.dat',form='formatted',status='unknown'
c	 open (unit=13,file='filepotaed.dat',form='formatted',
c     1      status='unknown')
c	 open (unit=14,file='filesymaed.dat',form='formatted',
c     1      status='unknown')
c      open(unit=11,file='fortaed.11',status='unknown')
c	 open(unit=32,file='wf1aed.dat',status='unknown')
c	 open(unit=33,file='wf2aed.dat',status='unknown')
c	 open(unit=66,file='fortaed.66',status='unknown')
c	 open(unit=34,file='wf3aed.dat',status='unknown')
c       open(unit=35,file='tlaedmio3.dat',status='unknown')
c	 open(unit=55,file='radaedmio3.dat',status='unknown')

c       endif
c
      rewind idat
      rewind iwf
      rewind iphas
      rewind iedl0
      rewind iof
c
c read control cards
c
      call inctrl
c
c read title cards
c
      call intit(iof)
c
c read atomic coordinates cards (internal or cartesian)
c
      call incoor
c
c compute atomic phase shifts if required
c
      call calphas
c
c normal end
c
      write(iwr,1100)
c
c..
c      close(69)
      close(70)
      close(71)
      close(80)
      close(81)
      close(90)
      close(91)
      close(21)
      close(60)
      close(13)
      close(14)
      close(15)
      close(7)
      close(50)
      close(56)
      close(35)
      close(iwf)
      close(iphas)
c
 1000 format(1x,65('_'),//,31x,'PHAGEN',/,1x,65('_'),/)
 1100 format(//,15x,' ** phagen terminated normally ** ',//)
c
      end
c
      subroutine inctrl
      implicit real*8 (a-h,o-z)
      include 'msxas3.inc'
c
      include 'msxasc3.inc'
c
      real*4  emin,emax,delta,cip,gamma,eftri,db
      common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg
      real*4 einc,esct,scangl,qt,lambda
c
      common/typot/ ipot
c
c     I define the shells and orbitals of the primary core hole, and the
c     two holes in the final state:
c
      character shell,shell1,shell2,orbital1,orbital,orbital2
c................................................................
      namelist/job/edge,edge1,edge2,l2h,potype,norman,absorber,coor,
     $  emin,emax,delta,gamma,eftri,cip,vc0,rs0,vinput,eikappr,rsh,db,
     $  lmaxt,ovlpfac,ionzst,charelx,calctype,potgen,lmax_mode,relc,
     $  einc,esct,scangl,optrsh,enunit,lambda,expmode
c
c initialize namelist
c
      vinput = .false.
      potype='hedin'
      potgen='in'
      cip=0.0           
      relc='nr'
      eikappr=' no'
      coor='angs'
      edge='k'
      edge1='k'
      edge2='k'
      lmaxt=60
      lmax_mode=2
      l2h=0
      absorber = 1
      charelx = 'ex'
      norman = 'stdcrm'
      ovlpfac=0.d0
      ionzst='neutral'
c      mode = 0
      calctype='xpd'
      expmode='cis'
      optrsh='n'
      enunit='Ryd'
c
      vc0 = -0.7d0
      rs0 = 3.d0
c
      emin =  0.5
      emax = 40.0
      delta=  0.05
      gamma=  0.0
      eftri=  0.0
      rsh = 0.0d0            !used as a flag; set below to default in au
      db = 0.01
c
c     data initialization for calctype='els' or 'e2e'
c      if(calctype.eq.'els'.or.calctype.eq.'e2e') then
c
         einc= 1200.0
         esct= 1000.0
         scangl= 7.0/180.0*3.1415926
         lambda = 0.0 !used as a flag; set below to default in au
c      endif
c
c.....definition of lmax_mode:
c.....   lmax_mode = 0: lmaxn(na)=lmax_, independent of energy and atom number
c.....   lmax_mode = 1: lmaxn(na)= km*rs(na)+1, where km=(emax)^{1/2}
c.....   lmax_mode = 2: lmaxn(na)= ke*rs(na)+1, where ke=(e)^{1/2}, where 
c.....   e is the running energy
c
c..   read control cards in namelist &job
c
      read(idat,job)
      read(idat,*)
c
c.....convert lengths in au if coor='angs'. Coordinates will be converted 
c     in subroutine inoor
      if(coor.eq.'angs'.and.lambda.ne.0) then 
         lambda = lambda/real(antoau)
      else
         lambda = 20.0 ! in au corresponding to kappa = 0.05 (see subroutine cont)
      endif
c
      if(coor.eq.'angs'.and.rsh.ne.0) then 
         rsh = rsh/antoau
      else
         rsh = 1.0d0         ! in au
      endif
c.....convert all energies to Ryd (when they are inputed in eV)
c
      if(enunit.eq.' ev') then
c         vc0 = vc0/ev
c
         cip = cip/real(ev)
         emin = emin/real(ev)
         emax = emax/real(ev)
         delta= delta/real(ev)
         gamma= gamma/real(ev)
         eftri= eftri/real(ev)
         einc= einc/real(ev)
         esct= esct/real(ev)
      endif
c
      if(lmax_mode.gt.2) then
        write(iwr,*) 'lmax_mode should be less than 3'
        call exit
      endif
c
      if(calctype.eq.'els') then 
         lmax_mode = 2
         einl = dble(einc - esct - cip)
         if(cip.ne.0.0.and.einl.lt.0.0d0) then
            write(6,*)' unable to excite chosen edge:',
     &                ' einc - esct - cip less than zero =', einl 
            call exit
         endif
      endif
c
      if(calctype.eq.'led') charelx = 'gs'
        if ((calctype.eq.'xpd').or.(calctype.eq.'led').or.
     &    (calctype.eq.'els')) then
c
        write(iwr,1000) calctype
        write(iwr,1001)
        if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     &     calctype.eq.'rex'.or.calctype.eq.'els') write(iwr,1005)edge
        write(iwr,1010)potype,norman,absorber
        write(iwr,1015)coor,emin,emax
        write(iwr,1020)delta,gamma,eftri
c        write(iwr,1025)cip,lmax
        write(iwr,1038) ionzst
c        if (mode.eq.0) write(iwr,1036)
        if (potgen.eq.'in') write(iwr,1036)
c        if (mode.eq.1) write(iwr,1037)
        if (potgen.eq.'ex') write(iwr,1037)
 1000   format('  parameters for this ',a3,' calculation:')
 1001   format(1x,65('-'))
 1005   format(2x,'edge= ',a2)
 1010   format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2)
 1015   format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ',
     $     f7.2,' Ry')
 1020   format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2,
     $     2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry')
 1025   format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2)
 1036   format(2x,'final state potential generated internally')
 1037   format(2x,'final state potential read in from extnl file')
 1038   format(2x,'ionization state : ',a7)
c
        else
c
        write(iwr,10001) calctype
        write(iwr,10011)
        write(iwr,10051)edge,edge1,edge2
        write(iwr,10101)potype,norman,absorber
        write(iwr,10151)coor,emin,emax
        write(iwr,10201)delta,gamma,eftri
c        write(iwr,10251)cip,lmax
        write(iwr,10381) ionzst
c        if (mode.eq.0) write(iwa,10361)
c        if (mode.eq.1) write(iwa,10371)
10001   format('  parameters for this 'a3,' calculation:')
10011   format(52('-'))
10051   format(2x,'edge= ',a2,2x,'edge1= ',a2,2x,'edge2= ',a2)
10101   format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2)
10151   format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ',
     $     f7.2,' Ry')
10201   format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2,
     $     2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry')
10251   format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2)
10381   format(2x,'ionization state :',a7)
c
        end if
c
c......check number of energy points
c
       kxe = nint((emax-emin)/delta + 1.)
          if(kxe.gt.nep_)then
              write(6,731) kxe
731           format(//,
     &        ' increase the dummy dimensioning variable, nep_. ',
     &        /,' it should be at least equal to: ', i5,/)
              call exit
          end if
c
c..   set other options and seek for errors
c
      ierror=0
c
c potgen   determines whether the potential is generated internally
c          by the present program or read in externally
c potype   determines which which kind of exchange-correlation potential
c          is used
c mode     is 0 if the potential is to be computed and 1 if the
c          potential is to be read
c iexcpot  is defined after the potential type according to
c          the values found below
c
      mode = 0
      if (potgen.eq.'ex') mode=1
c
      iexcpot = 0
      ipot = 0
c
      if(potype.eq.'xalph')then
	 iexcpot=1
	 else
	 if(potype.eq.'hedin')then
            ipot = 1
	    iexcpot=5
	    else
	    if(potype.eq.'dhrel')then
	       iexcpot=2
	       else
	       if(potype.eq.'dhcmp')then
                  ipot = 1
		  iexcpot=4
		  else
		  if(potype.eq.'hdrel')then
		     iexcpot=3
		     else
                     if(potype.eq.' lmto') then
                        iexcpot=6
                        else
			ierror=1
                     endif
		   endif
		endif
	     endif
	  endif
	endif
c
      shell=edge(1:1)
      orbital=edge(2:2)
c
      if(shell.eq.'k')then
	 lin=0
	 hole=1
	else
	 if(shell.eq.'l')then
	    if(orbital.eq.'1') then
	       lin=0
	       hole=2
	       else
	       if(orbital.eq.'2')then
		  lin=1
		  hole=3
		  else
		  if(orbital.eq.'3')then
		     lin=1
		     hole=4
		     else
		     ierror=1
		     endif
		  endif
	       endif
c
	else
	  if(shell.eq.'m')then
	       if(orbital.eq.'1')then
		  lin=0
		  hole=5
		  else
		  if(orbital.eq.'2')then
		     lin=1
		     hole=6
		     else
		     if(orbital.eq.'3')then
			lin=1
			hole=7
			else
			if(orbital.eq.'4')then
			   lin= 2
			   hole=8
			   else
			   if(orbital.eq.'5')then
			      lin=2
			      hole=9
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
c
      else
c
        if(shell.eq.'n')then
	       if(orbital.eq.'1')then
		  lin=0
		  hole=10
		  else
		  if(orbital.eq.'2')then
		     lin=1
		     hole=11
		     else
		     if(orbital.eq.'3')then
			lin=1
			hole=12
			else
			if(orbital.eq.'4')then
			   lin= 2
			   hole=13
			   else
			   if(orbital.eq.'5')then
			      lin=2
			      hole=14
			       else
			   if(orbital.eq.'6')then
			      lin=3
			      hole=15
			       else
			   if(orbital.eq.'7')then
			      lin=3
			      hole=16
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
		  endif
	       endif
c
      else
c
        if(shell.eq.'o')then
	       if(orbital.eq.'1')then
		  lin=0
		  hole=17
		  else
		  if(orbital.eq.'2')then
		     lin=1
		     hole=18
		     else
		     if(orbital.eq.'3')then
			lin=1
			hole=19
			else
			if(orbital.eq.'4')then
			   lin= 2
			   hole=20
			   else
			   if(orbital.eq.'5')then
			      lin=2
			      hole=21
			       else
			   if(orbital.eq.'6')then
			      lin=3
			      hole=22
			       else
			   if(orbital.eq.'7')then
			      lin=3
			      hole=23
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
		  endif
	       endif
c
      endif
      endif
      endif
      endif
      endif
c

	if (calctype.eq.'aed') then
c
c	We take the substrings of the final holes in the Auger decay
c
       shell1=edge1(1:1)
       orbital1=edge1(2:2)
	 shell2=edge2(1:1)
       orbital2=edge2(2:2)
c
	 if(shell1.eq.'k')then
	  lin1=0
	 hole1=1
	 else
	 if(shell1.eq.'l')then
	    if(orbital1.eq.'1') then
	       lin1=0
	       hole1=2
	       else
	       if(orbital1.eq.'2')then
		  lin1=1
		  hole1=3
		  else
		  if(orbital1.eq.'3')then
		     lin1=1
		     hole1=4
		     else
		     ierror=1
		     endif
		  endif
	       endif
c
	else
c
	  if(shell1.eq.'m')then
	       if(orbital1.eq.'1')then
		  lin1=0
		  hole1=5
		  else
		  if(orbital1.eq.'2')then
		     lin1=1
		     hole1=6
		     else
		     if(orbital1.eq.'3')then
			lin1=1
			hole1=7
			else
			if(orbital1.eq.'4')then
			   lin1= 2
			   hole1=8
			   else
			   if(orbital1.eq.'5')then
			      lin1=2
			      hole1=9
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
c
      else
c
        if(shell1.eq.'n')then
	       if(orbital1.eq.'1')then
		  lin1=0
		  hole1=10
		  else
		  if(orbital1.eq.'2')then
		     lin1=1
		     hole1=11
		     else
		     if(orbital1.eq.'3')then
			lin1=1
			hole1=12
			else
			if(orbital1.eq.'4')then
			   lin1= 2
			   hole1=13
			   else
			   if(orbital1.eq.'5')then
			      lin1=2
			      hole1=14
			       else
			   if(orbital1.eq.'6')then
			      lin1=3
			      hole1=15
			       else
			   if(orbital1.eq.'7')then
			      lin1=3
			      hole1=16
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
		  endif
	       endif
c
      else
c
        if(shell1.eq.'o')then
	       if(orbital1.eq.'1')then
		  lin1=0
		  hole1=17
		  else
		  if(orbital1.eq.'2')then
		     lin1=1
		     hole1=18
		     else
		     if(orbital1.eq.'3')then
			lin1=1
			hole1=19
			else
			if(orbital1.eq.'4')then
			   lin1= 2
			   hole1=20
			   else
			   if(orbital1.eq.'5')then
			      lin1=2
			      hole1=21
			       else
			   if(orbital1.eq.'6')then
			      lin1=3
			      hole1=22
			       else
			   if(orbital1.eq.'7')then
			      lin1=3
			      hole1=23
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
		  endif
	       endif
c
      endif
      endif
      endif
      endif
      endif
c
      if(shell2.eq.'k')then
c
        lin2=0
        hole2=1
c
      else
c
	 if(shell2.eq.'l')then
	    if(orbital2.eq.'1') then
	       lin2=0
	       hole2=2
	       else
	       if(orbital2.eq.'2')then
		  lin2=1
		  hole2=3
		  else
		  if(orbital2.eq.'3')then
		     lin2=1
		     hole2=4
		     else
		     ierror=1
		     endif
		  endif
	       endif
c
	else
c
	  if(shell2.eq.'m')then
	       if(orbital2.eq.'1')then
		  lin2=0
		  hole2=5
		  else
		  if(orbital2.eq.'2')then
		     lin2=1
		     hole2=6
		     else
		     if(orbital2.eq.'3')then
			lin2=1
			hole2=7
			else
			if(orbital2.eq.'4')then
			   lin2= 2
			   hole2=8
			   else
			   if(orbital2.eq.'5')then
			      lin2=2
			      hole2=9
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
c
      else
c
        if(shell2.eq.'n')then
	       if(orbital2.eq.'1')then
		  lin2=0
		  hole2=10
		  else
		  if(orbital2.eq.'2')then
		     lin2=1
		     hole2=11
		     else
		     if(orbital2.eq.'3')then
			lin2=1
			hole2=12
			else
			if(orbital2.eq.'4')then
			   lin2= 2
			   hole2=13
			   else
			   if(orbital2.eq.'5')then
			      lin2=2
			      hole2=14
			       else
			   if(orbital2.eq.'6')then
			      lin2=3
			      hole2=15
			       else
			   if(orbital2.eq.'7')then
			      lin2=3
			      hole2=16
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
		  endif
	       endif
c
      else
c
        if(shell2.eq.'o')then
	       if(orbital2.eq.'1')then
		  lin2=0
		  hole2=17
		  else
		  if(orbital2.eq.'2')then
		     lin2=1
		     hole2=18
		     else
		     if(orbital2.eq.'3')then
			lin2=1
			hole2=19
			else
			if(orbital2.eq.'4')then
			   lin2= 2
			   hole2=20
			   else
			   if(orbital2.eq.'5')then
			      lin2=2
			      hole2=21
			       else
			   if(orbital2.eq.'6')then
			      lin2=3
			      hole2=22
			       else
			   if(orbital2.eq.'7')then
			      lin2=3
			      hole2=23
			       else
			       ierror=1
			       endif
			      endif
			   endif
			endif
		     endif
		  endif
	       endif
c
      endif
      endif
      endif
      endif
      endif
c
	endif
c
c.. stop if errors occurred
c
      if(ierror.eq.0)goto 10
c
       write(iwr,*) '  '
       write(iwr,*) '  '
       write(iwr,*)'                ** error in inctrl **'
       write(iwr,*)'                -> check namelist values'
       write(iwr,*) '  '
       write(iwr,*) '  '
c
      stop
   10 continue
c
c.. check dimensions for lmax
c
      if(lmaxt.gt.lmax_) then
        write(iwr,*) '  '
        write(iwr,*) '  '
        write(iwr,*)'                ** error in inctrl **'
        write(iwr,*)'                -> check dimensions for lmax_'
        write(iwr,*) '  '
        write(iwr,*) '  '
        stop
      endif
c
      end
c
      subroutine intit(iof)
C
c... read title cards until a blank card is encountered
C
      implicit real*8 (a-h,o-z)
      include 'msxas3.inc'
c
      include 'msxasc3.inc'
c
      logical  blank
      logical line1
      character*1 card(80)
c
      write(iwr,1001)

      line1=.true.
c
    1 call incard (idat,card,ierr)
      if(ierr.eq.0) goto 3
      if(ierr.eq.1) then

	 write(iwr,2000)

	if(ierr.eq.2) then

	  write(iwr,2001)

	endif
	endif
 2000 format(//,'                ** intit : end input -> stop **',//)
 2001 format(//,'                ** intit : input error -> stop **',//)
      stop
    3 continue
c
c..  write the 1st line of title into iof
c
      if (line1) write(iof) (card(j),j=1,79)
      line1=.false.
      if ( blank(card) ) goto 2
      write(iwr,1000) (card(j),j=1,79)
      goto 1
    2 continue
      write(iwr,1001)
1000  format(1x,80a1)
1001  format(/)
      end
c
      subroutine incard (idat,card,ierr)
c
      character*1 card(80)
      ierr=0
      do 2 i=1,80
    2 card(i)=' '
      read(idat,1000,end=9,err=10) (card(i),i=1,80)
      return
    9 ierr=1
      return
   10 ierr=2
      return
 1000 format(80a1)
      end
c
      logical function  blank(card)
      character*1 card(80)
      data iasc/32/
c
c     iasc is the ascii code for ' ' (32)
c     here a blank card is a card with ascii codes < 32
c     i.e., control characters are ignored
c
      blank=.true.
      do 1 i=1,80
      if (ichar(card(i)).gt.iasc) then
	     blank=.false.
	     return
	     endif
    1 continue
      end
c
      subroutine incoor
c
      implicit real*8 (a-h,o-z)
      include 'msxas3.inc'
c
      include 'msxasc3.inc'
c
      common/lmto/ rdsymbl,tag(nat_)
      character*2 tag,tagi
      logical rdsymbl
c
      if( coor.eq.'au  ') write(iwr,2000)
      if( coor.eq.'angs') write(iwr,2001)
      write(iwr,2002)
      i=1
    1 continue
c
      rdsymbl=.false.
      read (idat,*,iostat=ios) tagi,nzi
      backspace(idat)
      if (ios.eq.0) rdsymbl=.true.
c
      if (rdsymbl) then
c
	 if (norman.eq.'stdcrm') then
	    radi = 0.0d0
	    redfi = 0.0d0
	    read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3
	 endif
c
         if (norman.eq.'stdfac') then
	    radi = 0.d0
	    redfi = 0.8d0
	    read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3
	 endif
c
         if (norman.eq.'scaled') then
	    radi = 0.0d0
	    read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,redfi
	 endif
c
         if (norman.eq.'extrad') then
	    redfi = 0.0d0
	    read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,radi
	 endif
c
      else
c
	 if (norman.eq.'stdcrm') then
	    radi = 0.0d0
	    redfi = 0.0d0
	    read (idat,*,err=2) nzi,ci1,ci2,ci3
	 endif
c
         if (norman.eq.'stdfac') then
	    radi = 0.d0
	    redfi = 0.8d0
	    read (idat,*,err=2) nzi,ci1,ci2,ci3
	 endif
c
         if (norman.eq.'scaled') then
	    radi = 0.0d0
	    read (idat,*,err=2) nzi,ci1,ci2,ci3,redfi
	 endif
c
         if (norman.eq.'extrad') then
	    redfi = 0.0d0
	    read (idat,*,err=2) nzi,ci1,ci2,ci3,radi
	 endif
c
      endif
c
      if (nzi.lt.0) goto 2
c
      if (i.gt.natoms) then
        write(iwr,*) '  '
        write(iwr,*) '  '
        write(iwr,*)'                 ** error in incoor **'
        write(iwr,*)'                 -> too many atoms, ',
     1              'check dimensions'
        write(iwr,*) '  '
        write(iwr,*) '  '
        stop
       endif
c
       nz(i) = nzi
       c(i,1) = ci1
       c(i,2) = ci2
       c(i,3) = ci3
       rad(i) = radi
       redf(i) = redfi
       tag(i) = tagi
      if(rdsymbl) then
        write (iwr,101) tag(i),nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i)
      else
        write (iwr,100) nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i)
      endif
  100 format(2x,i3,3f10.4,3x,2f7.4)
  101 format(2x,a2,3x,i3,3f10.4,3x,2f7.4)
      i=i+1
      goto 1
    2 nat = i-1
C	print *, 'nat =', nat
      write(iwr,2002)
      write(iwr,2003)
      if(ionzst.eq.'  ionic') then
  10    read(idat,*) nzat
        if(nzat.lt.0) goto 20
        backspace(idat)
        read(idat,*) ndummy,charge_ion(nzat)
        goto 10
      endif
  20  continue
c
c.. default units are angtroms, convert to a.u. if necessary
c
      if (coor.eq.'au  ') return
      if (coor.eq.'angs') then
		      do 3 i=1,nat
                      if (norman.eq.'extrad')
     &                rad(i) = rad(i)/antoau
		      do 3 iz=1,3
		      c(i,iz)= c(i,iz) / antoau
    3                 continue
		      return
		      endif
c
      write(iwr,*) '  '
      write(iwr,*) '  '
      write(iwr,*)'                 ** incoor: unit type unknown -> ',
     1            'stop ** '
      write(iwr,*) '  '
      write(iwr,*) '  '
c
 2000 format('  coordinates in a.u.     ',25x,'Radii')
 2001 format('  coordinates in angstroms',25x,'Radii')
 2002 format(1x,65('-'))
 2003 format(/)
      stop
      end
c
      subroutine calphas
c
      implicit real*8 (a-h,o-z)
      include 'msxas3.inc'
c
      include 'msxasc3.inc'
c
c
      real*4  emin,emax,delta,cip,gamma,eftri,db
      common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg
      real*4 einc,esct,scangl,qt,lambda
c
      character*8 nsymbl
c
c    ######## Modified to introduce the two state wave functions for the
c              Auger decay
c    ######## let's introduce i_absorber_hole1 and i_absorber_hole2
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode
      common/dimens/nats,ndat,nout,lmaxx,irreps
c
      common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms),
     u  nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms),
     u  lmaxat(natoms), ktau(ua_),natau(neq_,ua_)
c
      common/aparms_extra/rs_(natoms),redf_(natoms),ovlf
c
c      real*4  emin,emax,delta,cip,gamma,eftri
c
      write(iwr,*) ' ** enter calphas **'
c
      if(cip.eq.0.0) then
c
c calculate edge ionization potential
c
         call calc_edge(cip)
         write(6,*) ' calculated ionization potential (ryd)    =',cip
      else
         write(6,*) ' given ionization potential (ryd)         =',cip
      endif
      write(6,*) '                       ---'
c
c check consistency of input data in case of calctype = 'els'
c
      if(calctype.eq.'els') then
         einl = dble(einc - esct - cip)
         if(einl.lt.0.0d0) then
            write(6,*)' unable to excite chosen edge:',
     &                '  einc - esct - cip less than zero =', einl 
            call exit
         endif
      endif
c
c phase shifts computation
c initializes some variables for symmetry+potential programs
c nat is the total number of physical atoms as read in in
c subroutine incoor and is listed in common/atoms/
c
      nats=nat
      i_absorber = absorber
      i_absorber_hole = hole
c
c	################## Modified to introduce the two state wave functions
c                          for the Auger decay
c    ################## hole1 is the electron that will go down to fill
c                       the primary core hole
c
	i_absorber_hole1 = hole1


 	i_absorber_hole2 = hole2






      i_norman = 1
c     if (norman.eq.'extrad') i_norman = 0
      i_mode = mode
      do 100 i=2,nat+1

      nzeq(i) = nz(i-1)
      xv(i) = c(i-1,1)
      yv(i) = c(i-1,2)
      zv(i) = c(i-1,3)
      rs_(i)=rad(i-1)
      redf_(i)=redf(i-1)
  100 continue
      ovlf = ovlpfac
c
      write(iwr,*) '          '
      write(iwr,*) '          '
      write(iwr,*) ' symmetrizing coordinates... '
      open (7,file='div/sym.out',status='unknown')

      call xasymfn_sub


c
c.....Warning: in subroutine xasymfn_sub nats has been assigned
c.....the value (nat+1) to take into account the outer sphere.
c
c create equivalence table neqat
c i=1 is the outer sphere in xasym programs
c
      do 200 i=1,nat
      if (neq(i+1).eq.0) then
	  neqat(i)=i
	  else
	  neqat(i)=neq(i+1)-1
	  endif
  200 continue
c
c.....Write out atomic coordinates in symmetry-program order:
c     each prototypical atom is followed by its sym-equivalent atoms
c
c      open (10,file='clus/clus.out',status='unknown')
      if( coor.eq.'au  ') then
         ipha=1
         coef=1.d0
      endif
      if( coor.eq.'angs') then
        ipha=2
        coef=0.529177d0
      endif
      write(10,888) ipha
  888 format(30x,i1)
      write(7,10) (neqat(i),i=1,nat)
   10 format (/,16i5,//)
c
c      write(7,10) nat, ndat-1
c
      x0 = xv(2)
      y0 = yv(2)
      z0 = zv(2)
c
      no = 0
      do na = 1, ndat-1
        do k = 2, nat+1
          if (neqat(k-1).eq.na) then
             no = no + 1
             write(7,20) no,nsymbl(k),nzeq(k),xv(k)-x0,
     &                   yv(k)-y0,zv(k)-z0,neqat(k-1)
             write(10,20) no,nsymbl(k),nzeq(k),(xv(k)-x0)*coef,
     &                   (yv(k)-y0)*coef,(zv(k)-z0)*coef,neqat(k-1)
          endif
          continue
        enddo
      enddo
c
      close(10)
c
   20 format (i5,6x,a4,i5,3f10.4,i5)
c
      write(iwr,*)
      write(iwr,*)' computing muffin tin potential and phase shifts'
      call cont_sub(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db)
c
ctn      write(iwr,*)'calphas: neq', (neq(i),i=1,nat+1)
ctn      write(iwr,*)'calphas: neqat', (neqat(i),i=1,nat)
c      tstop=cputim()
c      elapsed=tstop-tstart
c      write(iwr,2000)elapsed
c 2000 format('  ** end calphas ** elapsed time ',f10.3,' seconds')
      return
      end
c
c
      subroutine exit
c
      write(6,*) '   '
      write(6,*) '   '
      write(6,*)'                 ** stop via call exit **'
      write(6,*) '   '
      write(6,*) '   '
      stop
      end
c
      subroutine xasymfn_sub
c
c***********************************************************************
c
c    xasymfn: xalpha symmetry function program (version 3, 11 feb 1981)
c
c      written by m. cook, 1981.
c
c      calls: input(at input,outpot),seteqs,symops,closur,ctable,basfns
c
c***********************************************************************
c

      implicit real*8 (a-h,o-z)
c      include 'mscalc.inc'
      include 'msxas3.inc'
      integer op_,ord_,two_npr_
      parameter (natm2_=nat_-2,npr_=24,op_=48,ntax_=250,
     1           ir_=14,ib_=28,ord_=8,l_=3,lp1_=4,
     2           nms_=7,nfac_=9,nbf_=nat_*4,ncs_=24)
      parameter(two_npr_=2*npr_,npr_p1_=npr_+1)
c
      common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1,
     u              nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx
c
c                                       !flag for reformatted output
      common/sym_out/isym_format


c
c----- define maximum array dimensions ---------------------------------
c warning : natmx est dans le common
cman      data natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1,
cman     u     nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx
cman     u     /nat_,ua_,neq_,npr_,two_npr_,npr_p1_,
cman     u      ord_,ir_,ib_,l_,nbf_,ncs_,ntax_/
c
      data natm2m,nopmax,lp1mx,nmsmx,mxfct
     u /natm2_,op_,lp1_,nms_,nfac_/
cman
      natmx      =    nat_
      ndatmx     =    ua_
      neqsmx     =    neq_
      nprmx      =    npr_
      nopmx      =    two_npr_
      nimp1      =    npr_p1_
      nordmx     =    ord_
      nirpmx     =    ir_
      nibmx      =    ib_
      lbasmx     =    l_
      nbfmx      =    nbf_
      ncsmx      =    ncs_
      ntaxmx     =    ntax_

c
c
      if (natm2m.lt.natmx-2)      go to 10
      if (nopmax.ne.2*nprmx)      go to 20
      if (lp1mx.ne.lbasmx+1)      go to 30
      if (nmsmx.ne.2*lbasmx+1)    go to 40
      if (mxfct.lt.2*lbasmx+1)   go to 50
      if (nordmx.lt.3)            go to 60
c
c----- call major calculational subroutines ----------------------------
c

      call input_xasymfn


      call seteqs
      call outpot_xasymfn
c
      return
c
c----- error prints and stops ------------------------------------------
c
   10 write (6,500) natm2m
      stop
   20 write (6,510) nopmax
      stop
   30 write (6,520) lp1mx
      stop
   40 write (6,530) nmsmx
      stop
   50 write (6,540) mxfct
      stop
   60 write (6,550) nordmx
      stop
c
  500 format (//,'  error stop: natm2m =',i6,'  is less than',
     u  ' natmx-2 :  redimension',//)
  510 format (//,'  error stop: nopmax =',i6,'  is not equal to',
     u  ' 2*nprmx :  redimension',//)
  520 format (//,'  error stop: lp1mx =',i6,'  is not equal to',
     u  ' lbasmx+1 :  redimension',//)
  530 format (//,'  error stop: nmsmx =',i6,'  is not equal to',
     u  ' 2*lbasmx+1 : redimension',//)
  540 format (//,'  error stop: mxfct =',i6,'  is less than',
     u  ' 2*lbasmx+1 : redimension',//)
  550 format (//,'  error stop: nordmx =',i6,'  : must be',
     u  ' redimensioned to 3 or greater',//)
      end
c
c
      subroutine input_xasymfn
c
c***********************************************************************
c
c        reads in the molecular geometry information, desired
c      l-values, and mode control variables.  modes of operation:
c
c     iprt=0, rot'n matrices not printed
c     iprt=1, rot'n matrices will be printed out from ctable
c
c     mdin=0, geometry, nz, neq data all read from card input
c     mdin=1, non-sym data read from a molec stpot; sym data from cards
c
c     mdou=0, only 1st col of degenerate irreps output to ktape
c     mdou=1, all columns of degenerate irreps will be written
c
c     mdco=0, single-atom core functions will be generated
c     mdco=1, symmetry-adapted core functions will be generated
c
c     mdeq=0, calc'd symmetry-eq list (neq) overrides any input neq
c     mdeq=1, input list of symmetry-equivalences will be used
c
c        if mdin=1, mdeq=1 is automatically enforced by this program
c      because the form of the stpot depends on the list of sym-eq ats.
c
c      called by: main (at input,outpot)
c
c***********************************************************************
c
      implicit real*8(a-h,o-z)
c      include 'mscalc.inc'
      include 'msxas3.inc'
c
      logical cmplxc,frezeq,inpot,nonint,onecol,symcor
      character*8 nsymbl,nsymbl2
      common/aparms_extra/rs(nat_),redf(nat_)
      common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_),
     u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_),
     u  ktau(ua_),natau(neq_,ua_)
      common/aparms2/xv2(nat_),yv2(nat_),zv2(nat_),rs2(nat_),
     u  alpha2(nat_),redf2(nat_),z2(nat_),q2(nat_),qspnt2(2),
     u  qint2(2),
     u  watfac(nat_),alpha02,volint2,ovout2,rmxout2,nsymbl2(nat_),
     u  nz2(nat_),neq2(nat_),kmax2(nat_),kplace2(nat_),ktau2(ua_)
      common/lparam/lmax2(nat_),l0i
      common/coords/s(3,nat_)
      dimension s2(3,nat_)
      common/dimens/nat,ndat,nout,lmaxx,irreps
      common/dimens2/nat2,ndat2
      common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor
      common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1,
     u              nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx
c                                       !flag for reformatted output
      common/sym_out/isym_format
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode

c                                      !generate potential file
      common/out_ascii/iout_ascii
c
      common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc
      logical shift_cc
c
      common/lmto/ rdsymbl,tag(nat_)
      character*2 tag
      logical rdsymbl

      character*2 nameat
      dimension nameat(100)
c
       DATA NAMEAT/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne',
     1 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca',
     1 'Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn',
     1 'Ga','Ge','As','Se','Br','Kr','Rb','Sr',' Y','Zr',
     1 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn',
     1 'Sb','Te',' I','Xe','Cs','Ba','La','Ce','Pr','Nd',
     1 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb',
     1 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg',
     1 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th',
     1 'Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm'/
c
      data thr/0.001d0/
      data zero/0.d0/
      data lunout,lunout2/7,60/

c
      iprt=0
      mdou=0
      mdco=0
      mdeq=0
      isym_format=0

c                         !nout defined
      nout=1
c                           !same as nout but global
      i_outer_sphere=1
c
      frezeq=.false.
      symcor=.false.
      onecol=.true.
      if (mdeq.eq.1) frezeq=.true.
      if (mdco.eq.1) symcor=.true.
      if (mdou.eq.1) onecol=.false.
c
c-----------------------------------------------------------------------
c  mdin = 0 : only geometry & atomic # data, from card input
c-----------------------------------------------------------------------
c
      inpot=.false.
c                         !nout defined
      nout=1
ctn
ctn Values passed through the subroutines parameters
ctn      read (lunin,*) nat,i_absorber,i_absorber_hole,i_norman,
ctn     &i_mode
c
      nat=nat+i_outer_sphere
      if (nout.eq.0) write (lunout,570) nat
      if (nout.ne.0) write (lunout,580) nat
      if (nat.gt.natmx) go to 140
      write (lunout,530)


c
      r_sphere=0.0d0



      do 10 na=2,nat


ctn      read (lunin,*) nsymbl(na),nz(na),xv(na),yv(na),zv(na),
ctn     u rs(na),redf(na)
ctn modifs :


c      nsymbl(na)=nameat(nz(na))
c......modification for Empty Spheres
c
       if(rdsymbl) then
       nsymbl(na)=tag(na-1)
       else
         if(nz(na).eq.0) then
           nsymbl(na)='ES'
         else
           nsymbl(na)=nameat(nz(na))
         endif
      endif
      z(na)=dfloat(nz(na))
      neq(na)=0
c                  !needed to determine point group
      lmax(na)=3
      ncores(na)=0


      write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na),
     u neq(na),lmax(na),ncores(na)
  10  continue
c
c     define outer sphere parameters (i. e. atomic center)
c
      na=1
      nsymbl(na)='osph'
      nz(na)=0
      z(na)=0.0d0
      neq(na)=0
      rs(na)=0.0d0
      redf(na)=0.0d0
c                   !needed to determine point group
      lmax(na)=3
      ncores(na)=0
c
c     define outer sphere coordinates at center of charge
c
      xo=zero
      yo=zero
      zo=zero
      wt=zero
      do 910 na1=2,nat
      xo=xo+z(na1)*xv(na1)
      yo=yo+z(na1)*yv(na1)
      zo=zo+z(na1)*zv(na1)
      wt=wt+z(na1)
  910 continue
      xo=xo/wt
      yo=yo/wt
      zo=zo/wt
      if (dabs(xo).lt.thr) xo=zero
      if (dabs(yo).lt.thr) yo=zero
      if (dabs(zo).lt.thr) zo=zero
      xv(na)=xo
      yv(na)=yo
      zv(na)=zo
c
      if(i_norman.ne.1)then
         do 15 na1=2,nat
              r_sphere_temp=sqrt((xv(na1)-xv(1))**2+
     u        (yv(na1)-yv(1))**2+
     u        (zv(na1)-zv(1))**2)+rs(na1)
              if(r_sphere.lt.r_sphere_temp)then
                  r_sphere=r_sphere_temp
              end if
15        continue
      rs(1)=r_sphere
      end if
      write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na),
     u neq(na),lmax(na),ncores(na)
      write (lunout,560)
c
c***  check coordinates of atoms
c
      do 1150 na1=1,nat
      do 1140 na2=1,na1
      dist =dsqrt((xv(na1)-xv(na2))**2
     u                 +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 )
      if((na2.gt.1).and.(na1.ne.na2)) then
          if(dist.lt.thr)then
              write(6,562)na1,na2
              call exit
          end if
      end if
 1140 continue
 1150 continue
c
      return
c
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c   entry outpot_xasymfn
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
c----- molecule will usually have been rotated:
c        print the new atomic coordinates in standard orientation ------
c
      entry outpot_xasymfn
      write (lunout,590)
      print 595
      write (lunout,530)
      print 535
      nashf=1
c

      nat2=nat
      ndat2=ndat
      i_absorber_real=i_absorber+i_outer_sphere
c
c     set z on absorbing atom back to original value
c
      z(i_absorber_real)=z(i_absorber_real)-z_shift
      nz(i_absorber_real)=nz(i_absorber_real)-i_z_shift
c                                               !symmetry distinct atoms
      do 70 nda=1,ndat
      if(shift_cc)then
c                                                 !go back to real cente
	  s2(1,nashf)=s(1,nashf)-cc_dif(1,1)
c                                                 !of charge
	  s2(2,nashf)=s(2,nashf)-cc_dif(2,1)
          s2(3,nashf)=s(3,nashf)-cc_dif(3,1)
          if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero
          if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero
          if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero
      else
          s2(1,nashf)=s(1,nashf)
          s2(2,nashf)=s(2,nashf)
          s2(3,nashf)=s(3,nashf)
      endif
      write (lunout,550) nda,nsymbl(nda),nz(nda),
     u  s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda),
     u  lmax(nda),ncores(nda)
      print 555, nda,nsymbl(nda),nz(nda),
     u  s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda)
      if(nda.ne.1)write (lunout2,552) s2(1,nashf),s2(2,nashf),
     u  s2(3,nashf),nsymbl(nda)
c
        rs2(nda)=rs(nda)
        redf2(nda)=redf(nda)
        nsymbl2(nda)=nsymbl(nda)
        xv2(nda)=s2(1,nashf)
        yv2(nda)=s2(2,nashf)
        zv2(nda)=s2(3,nashf)
        nz2(nda)=nz(nda)
        z2(nda)=z(nda)
        neq2(nda)=neq(nda)
        ktau2(nda)=ktau(nda)
      nashf=nashf+ktau(nda)
   70 continue
      nashf=0
      do 90 nda=1,ndat
      nashf=nashf+1
      neqs=ktau(nda)
      if (neqs.eq.1) go to 90
      do 80 ne=2,neqs
c                                                !equivalent sets
      nashf=nashf+1
      na=natau(ne,nda)
      if(shift_cc)then
c                                                 !go back to real cente
	  s2(1,nashf)=s(1,nashf)-cc_dif(1,1)
c                                                 !of charge
	  s2(2,nashf)=s(2,nashf)-cc_dif(2,1)
          s2(3,nashf)=s(3,nashf)-cc_dif(3,1)
          if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero
          if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero
          if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero
      else
          s2(1,nashf)=s(1,nashf)
          s2(2,nashf)=s(2,nashf)
          s2(3,nashf)=s(3,nashf)
      endif
      write (lunout,550) na,nsymbl(na),nz(na),
     u  s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na),lmax(na),ncores(na)
      print 555, na,nsymbl(na),nz(na),
     u  s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na)
      write (lunout2,552) s2(1,nashf),s2(2,nashf),s2(3,nashf),
     u  nsymbl(na)
        rs2(na)=rs(na)
        redf2(na)=redf(na)
        nsymbl2(na)=nsymbl(na)
        xv2(na)=s2(1,nashf)
        yv2(na)=s2(2,nashf)
        zv2(na)=s2(3,nashf)
        nz2(na)=nz(na)
	  z2(na)=z(na)
        neq2(na)=neq(na)
   80 continue
   90 continue
      if(nout.eq.1) then


          z2(1)=1.0d0
          nz2(1)=1
      end if
      write (lunout,560)

      return
c
c----- error prints and stops ------------------------------------------
c
  140 write (6,600) natmx,nat
      stop
c
  530 format (t53,'position'/30x,'atom    no.',4x,'x',9x,'y',9x,'z',8x,
     u  'eq',5x,'lmax',5x,'#cores'/)
  535 format (t35,'position'/12x,'atom    no.',4x,'x',9x,'y',9x,'z',8x,
     u  'eq'/)
  550 format (26x,i4,2x,a4,i6,3f10.4,i6,i8,i9)
  552 format (3(2x,f10.3),2x,a4)
  555 format (8x,i4,2x,a4,i6,3f10.4,i6)
  560 format (/46x,6('*****')/)
  562 format (//,'error:  check coordinates of atoms # ',i4,
     & ' and # ',i4,//)
  570 format (//38x,'number of centers=',i5,'  no outer sphere'/)
  580 format (//38x,'number of centers=',i5,'  outer sphere at '
     u  ,'center 1'/)
  590 format (///38x,'molecular orientation for basis fn projection:'/)
  595 format (//14x,' symmetrized atomic coordinates of cluster  '/)
  600 format (//'  error stop: variable nat is .gt.',i6,
     u  '  : redimension natmx to',i6,//)
      end
c
      subroutine seteqs
c
c***********************************************************************
c
c        translates the molecule to the center of nuclear charge
c      and tentatively identifies symmetry-equivalent sets of atoms
c      on the basis of interatomic distances.
c        checks that the atoms are arranged in correct order for
c      xascf: nda's first and eq atoms following. if input is from
c      a molec starting pot, error stop if order is not correct. if
c      input is not from a pot, the atoms will be shuffled into
c      the appropriate xascf order at output time.
c        note that during the execution of the symmetry program, the
c      atoms are not kept in the scf order:  they are in sym-program
c      order, each nda followed immediately by its sym-eq partners.
c
c      called by: main
c
c***********************************************************************
c
      implicit real*8 (a-h,o-z)
c      include 'mscalc.inc'
      include 'msxas3.inc'
      parameter (natm2_=nat_-2)
c
      character*8 nsymbl
      logical doshuf,equiv,found,match,frezeq
      logical cmplxc,inpot,nonint,onecol,symcor
      dimension neqt(nat_)
      dimension found(natm2_),nbrz(natm2_,nat_),dnbr(natm2_,nat_)
      integer trans(nat_)
      common/aparms_extra/rs(nat_),redf(nat_)
      common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_),
     u  nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_),
     u  ktau(ua_),natau(neq_,ua_)
      common/coords/s(3,nat_)
      common/dimens/nat,ndat,nout,lmaxx,irreps
      common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor
      common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1,
     u              nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode

c
      common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc
      common/transform/trans
      logical shift_cc
c
      data zero,thr/0.0d0,0.001d0/
c
      data jtape/21/
      data lunout/7/
c
c-----------------------------------------------------------------------
c  find the center of charge of the nuclear framework and
c    translate the molecule to that origin
c-----------------------------------------------------------------------
c                        !define nuclear charge shift
      z_shift=5.0d0
      i_z_shift=5
      shift_cc=.true.
c
      xo=zero
      yo=zero
      zo=zero
      wt=zero
      nastrt=nout+1
c                         !set up to make absorbing atom unique by addin
      cc_dif(1,1)=zero
c                         !z_shift units of charge to its nucleus
      cc_dif(2,1)=zero
      cc_dif(3,1)=zero
      wt_real=zero

      do 5 na=nastrt,nat
      cc_dif(1,1)=cc_dif(1,1)+z(na)*xv(na)
      cc_dif(2,1)=cc_dif(2,1)+z(na)*yv(na)
      cc_dif(3,1)=cc_dif(3,1)+z(na)*zv(na)
      wt_real=wt_real+z(na)
   5  continue
      cc_dif(1,1)=cc_dif(1,1)/wt_real
      cc_dif(2,1)=cc_dif(2,1)/wt_real
      cc_dif(3,1)=cc_dif(3,1)/wt_real
c
      i_absorber_real=i_absorber+i_outer_sphere
c     increase z value of absorbing atom
      z(i_absorber_real)=z(i_absorber_real)+z_shift
      nz(i_absorber_real)=nz(i_absorber_real)+i_z_shift
c
      do 10 na=nastrt,nat
      xo=xo+z(na)*xv(na)
      yo=yo+z(na)*yv(na)
      zo=zo+z(na)*zv(na)
      wt=wt+z(na)
   10 continue
      xo=xo/wt
      yo=yo/wt
      zo=zo/wt
      if (dabs(xo).lt.thr) xo=zero
      if (dabs(yo).lt.thr) yo=zero
      if (dabs(zo).lt.thr) zo=zero
c                                    !cc_dif is difference between
      cc_dif(1,1)=cc_dif(1,1)-xo
c                                    !real and shifted centers of
      cc_dif(2,1)=cc_dif(2,1)-yo
c                                    !charge
      cc_dif(3,1)=cc_dif(3,1)-zo
      if (dabs(cc_dif(1,1)).lt.thr) cc_dif(1,1)=zero
      if (dabs(cc_dif(2,1)).lt.thr) cc_dif(2,1)=zero
      if (dabs(cc_dif(3,1)).lt.thr) cc_dif(3,1)=zero
      r_dif_cc=sqrt( cc_dif(1,1)*cc_dif(1,1)+cc_dif(2,1)*
     u cc_dif(2,1)+cc_dif(3,1)*cc_dif(3,1) )/dsqrt(3.0d0)
      if(r_dif_cc.lt.thr)shift_cc=.false.
      do 20 na=1,nat
      xv(na)=xv(na)-xo
      yv(na)=yv(na)-yo
      zv(na)=zv(na)-zo
      if (dabs(xv(na)).lt.thr) xv(na)=zero
      if (dabs(yv(na)).lt.thr) yv(na)=zero
      if (dabs(zv(na)).lt.thr) zv(na)=zero
   20 continue
c
c-----------------------------------------------------------------------
c  classify sym-eq sets of atoms: two atoms are eqiv
c    if they have same number of neighbors of same nz at same distances
c-----------------------------------------------------------------------
c
c----- calculate the distances of each atom from the others ------------
c
      neqt(1)=0
      do 40 na1=nastrt,nat
      nabor=0
      neqt(na1)=0
      do 30 na2=nastrt,nat
      if (na1.eq.na2) go to 30
      nabor=nabor+1
      nbrz(nabor,na1)=nz(na2)
      rab=dsqrt((xv(na1)-xv(na2))**2
     u            +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 )
      dnbr(nabor,na1)=rab
   30 continue
   40 continue
c
c----- compare the neighbor charges and distances ----------------------
c
      nabors=nat-(nout+1)
      do 90 na1=nastrt,nat
      na1p1=na1+1
      if (na1p1.gt.nat) go to 90
      do 80 na2=na1p1,nat
      if (nz(na1).ne.nz(na2)) go to 80
      if (neqt(na2).ne.0)     go to 80
      do 50 nabor=1,nabors
   50 found(nabor)=.false.
      equiv=.true.
c
c----- try to match the neighbors of na1 & na2 one-to-one --------------
c
      do 70 nabor1=1,nabors
      nzt= nbrz(nabor1,na1)
      rabt=dnbr(nabor1,na1)
      match=.false.
      do 60 nabor2=1,nabors
      if (found(nabor2))                      go to 60
      if (nbrz(nabor2,na2).ne.nzt)            go to 60
      if (dabs(dnbr(nabor2,na2)-rabt).gt.thr) go to 60
      found(nabor2)=.true.
      match=.true.
      go to 65
   60 continue
   65 if (match) go to 70
      equiv=.false.
      go to 75
   70 continue
c
c----- if all nabor2 found and each nabor1 had match=.true.,
c        na1 and na2 have equivalent sets of neighbors -----------------
c
   75 if (equiv) neqt(na2)=na1
   80 continue
   90 continue
c
c-----------------------------------------------------------------------
c  compare the calculated and input neq arrays
c-----------------------------------------------------------------------
c
      write (lunout,500)
      write (lunout,510) (na,neqt(na),na=1,nat)
      equiv=.true.
      do 100 na=1,nat
      if (neqt(na).ne.neq(na)) equiv=.false.
      if (.not.frezeq) neq(na)=neqt(na)
  100 continue
      if (equiv)                      write (lunout,520)
      if (.not.equiv.and.frezeq)      write (lunout,530)
      if (.not.equiv.and..not.frezeq) write (lunout,540)
c
c-----------------------------------------------------------------------
c  check that the atoms are arranged in the correct scf order:
c    all nda's first, then the sym-eq atoms for each nda in same order
c-----------------------------------------------------------------------
c
      doshuf=.false.
      do 110 na=nastrt,nat
      if (neq(na).eq.0.and.neq(na-1).ne.0) doshuf=.true.
      if (neq(na).lt.neq(na-1))            doshuf=.true.
  110 continue
      if (inpot.and.doshuf) go to 230
c
c----- if not running from a molecular starting pot,
c        shuffle the atoms into xascf order ----------------------------
c
      rewind jtape
      nda=0
      do 130 na=1,nat
      if (neq(na).gt.0) go to 130
      nda=nda+1
      write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na)
      write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na)
      do 120 na2=1,nat
      if (neq(na2).eq.na) neq(na2)=nda
  120 continue
  130 continue
      ndat=nda
      if (ndat.gt.ndatmx) go to 240
      do 150 nda=1,ndat
      do 140 na=1,nat
      if (neq(na).ne.nda) go to 140
      write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na)
      write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na)
  140 continue
  150 continue

      nda=0
      do 310 i=2,nat
	if (neq(i).eq.0) then
	  nda=nda+1
	  trans(i-1)=nda
	endif
  310 continue


      do 320 na=2,ndat
      do 325 i=2,nat
	 if (neq(i).eq.na) then
	   nda=nda+1
	   trans(i-1)=nda
	 endif
  325 continue
  320 continue


c
c----- read the shuffled atomic parameters back in ---------------------
c
      rewind jtape
      do 160 na=1,nat
      read (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na)
      read (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na)
  160 continue
      rewind jtape
c
c-----------------------------------------------------------------------
c  calculate the final symmetry-equivalence list ( natau )
c-----------------------------------------------------------------------
c
      do 200 nda=1,ndat
      neqs=1
      natau(1,nda)=nda
      do 190 na=1,nat
      if (neq(na).ne.nda) go to 190
      neqs=neqs+1
      if (neqs.gt.neqsmx) go to 250
      natau(neqs,nda)=na
  190 continue
      ktau(nda)=neqs
  200 continue

c
c-----------------------------------------------------------------------
c  arrange the atomic x,y,z coords in symmetry-program order:
c    each nda is followed immediately by its sym-equivalent atoms
c-----------------------------------------------------------------------
c
      nashuf=0
      do 220 nda=1,ndat
      neqs=ktau(nda)
      do 210 ne=1,neqs
      na=natau(ne,nda)
      nashuf=nashuf+1
      s(1,nashuf)=xv(na)
      s(2,nashuf)=yv(na)
      s(3,nashuf)=zv(na)
  210 continue
  220 continue

      return
c
c----- error prints and stops ------------------------------------------
c
  230 write (6,550)
      stop
  240 write (6,560) ndatmx,ndat
      stop
  250 write (6,570) neqsmx
      stop
c
  500 format (//25x,'calculated atomic symmetry equivalences,'/
     u  30x,'based on interatomic distance matrix:',7x,'na',
     u  4x,'neq(na)'/)
  510 format (69x,i7,i8)
  520 format (/t35,'the calculated symmetry-eq sets agree with',
     u  ' the input'/)
  530 format (/t25,'calculated & input symmetry-eq sets do not',
     u  ' agree: input sets will be used'/)
  540 format (/t22,'calculated & input symmetry-eq sets do not',
     u  ' agree: calculated sets will be used'/)
  550 format (//t25,'input molecular pot does not have distinct',
     u  ' & sym-eq atoms in correct order for input to xascf',//)
  560 format (//'  error stop: variable ndat is .gt.',i6,
     u  '  : redimension ndatmx to',i6,//)
  570 format (//'  error stop: variable neqs is .gt.',i6,
     u  '  : redimension neqsmx',//)
      end
c
c
      subroutine vgen
c      write(6,*) 'check1'
      call rhoat
c      write(6,*) 'check2'
      call molpot
c      write(6,*) 'check3'
      call inpot
c      write(6,*) 'check4'
      return
      end
c
C***********************************************************************
      SUBROUTINE RHOAT
C***********************************************************************
C
C   MAY-92
C
C   GENERATES ATOMIC CHARGE DENSITY FOR PROTOTYPICAL ATOMS
C
C   DICTIONARY :
C   NDAT	Number of prototypical atoms
C   INV		Logical unit on which to write the output [8]
C   ZAT		Atomic number
C   MESH	Number of radial mesh points [441]
C
C************************************************
      implicit real*8 (a-h,o-z)
c
      include 'msxas3.inc'
      include 'msxasc3.inc'
c
      common/dimens/nats,ndat
c
      character*8 nsymbl
c..


c      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1
c     *i_absorber_hole2,i_norman,i_alpha,
c     1i_outer_sphere,i_exc_pot,i_mode



      COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1,
     *  I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA,
     1    I_OUTERSPHERE,I_EXC_POT,I_MODE




C      COMMON/APARMS/XV(NATOMS),YV(NATOMS),ZV(NATOMS),Z(NATOMS),
C     u  NSYMBOL(NATOMS),NZEQ(NATOMS),NEQ(NATOMS),NCORES(NATOMS),
C     .  LMAXAT(NATOMS)

C      COMMON/APARMS_EXTRA/RS_(NATOMS),REDF_(NATOMS),OVLF


      common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms),
     u  nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms),
     u  lmaxat(natoms),ktau(ua_),natau(neq_,ua_)
C
      COMMON/CRHOAT/RO(441,UA_,1)
c
      DIMENSION X(441),RMESH(441)
C
      REAL*4 XC,YC,ZC
      DIMENSION XC(NAT_),YC(NAT_),ZC(NAT_)
C
      DIMENSION NPAC(100)
C
      LOGICAL OK
C
      OK = .TRUE.
C
C* * * Initialize variables for subroutine molpot * * *
C
      MESH = 441
C
C  Prepare coordinate vectors to input subroutine moldat
C
      DO 10 I=1,NAT
      XC(I) = sngl(XV(I+1))
      YC(I) = sngl(YV(I+1))
10    ZC(I) = sngl(ZV(I+1))
C  Initialize to zero the vector indicating for which atom the density
C  has already been calculated
      DO N = 1, 100
	NPAC(N) = 0
      ENDDO
C
C   compute x and r mesh (441 points)
C
         NBLOCK=11
         I=1
         X(I)=0.0D0
         RMESH(I)=0.0D0
         DELTAX=0.0025D0
         DO 120 J=1,NBLOCK
         DO 121 K=1,40
         I=I+1
         X(I)=X(I-1)+DELTAX
121      CONTINUE
C
C   For each new block, double the increment
C
         DELTAX=DELTAX+DELTAX
120      CONTINUE
C
C  Loop over prototypical atoms excluding outer sphere
C
      NDAT1 = NDAT-1

      DO 100 M=2,NDAT
         DO NR = 1, 441
            RO(NR,M,1) = 0.D0
         ENDDO
      IHOLE = 0
      IF (M.EQ.2.AND.CHARELX.EQ.'ex')  IHOLE=HOLE
      NZAT = NZEQ(M)
      IF(NZAT.NE.0) CION=CHARGE_ION(NZAT)
      ZAT = Z(M)
C
C.....CHANGE FOR EMPTY SPHERES; CHS=0.88534138D0/ZAT**(1.D0/3.D0)
C
         IF(ZAT.NE.0.D0) THEN
            CHS=0.88534138D0/ZAT**(1.D0/3.D0)
         ELSE
            CHS=0.88534138D0
         ENDIF
C
C   Factor CHS is to go from X values to R values
C   (the latter in atomic units; See Herman-Skillman p.5-3)
C
         DO  130  I=2,MESH
         RMESH(I)=CHS*X(I)
130      CONTINUE
C
      IF(NZAT.EQ.0) GO TO 100
      IF(NPAC(NZAT).EQ.0) THEN
        CALL atom_sub(NZAT,IHOLE,RMESH(1),RO(1,M,1),0,0,CION)
        IF(M.NE.2) NPAC(NZAT) = M
        GO TO 100
      ELSE
        DO I = 1, 441
          RO(I,M,1) = RO(I,NPAC(NZAT),1)
        ENDDO
      ENDIF
C
100   CONTINUE
C
C* * * * Generate input structural parameters for subroutine molpot * *
C
C
      CALL MOLDAT(XC,YC,ZC,NZEQ(1),NEQAT(1),NAT,NDAT1,OK)
C
      RETURN
C
      END
C
C*******************************
C
      subroutine atom_sub(iz,ihole,r_hs,rho0_hs,i_mode_atom,
     $                     i_radial,xion)
c
c     i_mode_atom = 1          pass_back P_nK corresponding to neutr
c                              atom.  i_radial designates radial function
c                              which is passed back in array rho0_hs re
c                              to mesh r_hs.
c                              I_radial has same label convention
c                              as ihole (1 = 1s1/2 ...).
c                 = all else   pass back charge density in rho0_hs.
c
c
      implicit real*8(a-h,o-z)
c
      parameter ( mp = 251, ms = 30 )
c
      character*40  title
c
      common/mesh_param/jlo
      common dgc(mp,ms),dpc(mp,ms),bidon(630),IDUMMY
c
c     common /pass/  passd, passvt(251), passvc(251), passc(251)
c     rho0 not renormalized
c     common /rho/rho0(251)
c     dgc contains large component radial functions
c     common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30)
c     passc and rho0 contain 4*pi*r^2*rho(r)
c
      dimension r(mp),r_hs(440),rho0_hs(440)
C
      dimension dum1(mp), dum2(mp)
      dimension vcoul(mp), rho0(mp), enp(ms)
c
      title = ' '
c
      ifr=1
      iprint=0
C
      amass=0.0d0
      beta=0.0d0
c
c There are no nodes in relativistic radial charge density
c
      small=1.0d-11
c                    !Hence a lower limit on rho(r) can be used.
      dpas=0.05d0
      dr1=dexp(-8.8d0)
      dex=exp(dpas)
      r_max=44.447d0
c
c     compute relativistic Hartree-Fock charge density (on log mesh)
C        and core state orbital wave function
c      open(unit=543,file='atom_.dat',status='unknown')
c

      call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint,
     1                   vcoul, rho0, dum1, dum2, enp, eatom)


c
c     compute radial log mesh (see subroutine phase in J.J. Rehr's progr
c     FEFF.FOR)
c
      ddex=dr1
      do 10 i=1,251
	  r(i)=ddex
	  ddex=ddex*dex
10    continue
C
      DO JMP=1,MP
        WRITE(66,*) R(JMP),RHO0(JMP)
      ENDDO
c
      do 15 i=1,441
	  rho0_hs(i)=0.0d0
15    continue

c
cman      if(i_mode_atom.eq.1)goto 30
c
      if(i_mode_atom.eq.1)goto 31
c
c using mesh form xainpot (r=0 not included)
c
      do 30 i=1,441
	   if(r_hs(i).gt.r_max) goto 30
c
c          find nearest points
c          initialize hunting parameter (subroututine nearest)
c
	   jlo=1
	   call nearest(r,251,r_hs(i),
     1     i_point_1,i_point_2,i_point_3)
	   if(abs(rho0(i_point_3)).lt.small) goto 30
c          interpolate charge density
	   call interp_quad( r(i_point_1),rho0(i_point_1),
     1     r(i_point_2),rho0(i_point_2),
     1     r(i_point_3),rho0(i_point_3),
     1     r_hs(i),rho0_hs(i) )
c
c branch point
c
30    continue
31    continue
c
c
      if(i_mode_atom.ne.1)goto 50
c
c     wave function generation
c using mesh form xainpot (r=0 not included)
c
      do 40 i=1,441
	   if(r_hs(i).gt.r_max) goto 50
c
c          find nearest points
c        initialize hunting parameter (subroututine nearest)
c
	   jlo=1
	   call nearest(r,251,r_hs(i),
     1     i_point_1,i_point_2,i_point_3)
c          interpolate wavefunction
	   call interp_quad(
     1     r(i_point_1),dgc(i_point_1,i_radial),
     1     r(i_point_2),dgc(i_point_2,i_radial),
     1     r(i_point_3),dgc(i_point_3,i_radial),
     1     r_hs(i),rho0_hs(i)
     1                     )
40    continue
c
c branch point
c
50    continue
c
      return
      end

      SUBROUTINE NEAREST(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3)
C
C     FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X
C     AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3
C     This subroutine was taken from Numerical Recipes,
C     W. H. Press, B. F. Flanney, S. A. Teukolsky and W.  T.
C     Vetterling, page 91. Originally called HUNT
c
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/MESH_PARAM/JLO
C
      DIMENSION XX(N)
      LOGICAL ASCND
      ASCND=XX(N).GT.XX(1)
C
C EXTRAPOLATE BELOW LOWEST POINT
C
      IF(X.LE.XX(1))THEN
	  I_POINT_1=1
	  I_POINT_2=2
	  I_POINT_3=3
	  RETURN
      END IF
C
C EXTRAPOLATE BEYOND HIGHEST POINT
C
      IF(X.GE.XX(N))THEN
	  I_POINT_1=N-2
	  I_POINT_2=N-1
	  I_POINT_3=N
	  RETURN
      END IF
      IF(JLO.LE.0.OR.JLO.GT.N)THEN
	JLO=0
	JHI=N+1
	GO TO 3
      ENDIF
      INC=1
      IF(X.GE.XX(JLO).EQV.ASCND)THEN
1       JHI=JLO+INC
	IF(JHI.GT.N)THEN
	  JHI=N+1
	ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN
	  JLO=JHI
	  INC=INC+INC
	  GO TO 1
	ENDIF
      ELSE
	JHI=JLO
2       JLO=JHI-INC
	IF(JLO.LT.1)THEN
	  JLO=0
	ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN
	  JHI=JLO
	  INC=INC+INC
	  GO TO 2
	ENDIF
      ENDIF
3     IF(JHI-JLO.EQ.1)THEN
	  IF((JLO+1).EQ.N)THEN
	      I_POINT_1=JLO-1
	      I_POINT_2=JLO
	      I_POINT_3=JLO+1
	  ELSE
	      I_POINT_1=JLO
	      I_POINT_2=JLO+1
	      I_POINT_3=JLO+2
	  END IF
      RETURN
      END IF
      JM=(JHI+JLO)/2
      IF(X.GT.XX(JM).EQV.ASCND)THEN
	JLO=JM
      ELSE
	JHI=JM
      ENDIF
      GO TO 3
      END
C
C
	SUBROUTINE INTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4)
C
C       INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2)
C       TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT
C       PARAMETERS.  THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C
C
	IMPLICIT REAL*8(A-H,O-Z)
C
	TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1)
	BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1)
	B = TOP/BOTTOM
	A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1)
	C = Y3 - A*X3*X3 - B*X3
	Y4 = A*X4*X4 + B*X4 + C
C
	RETURN
	END

C***********************************************************************
C
	SUBROUTINE MOLDAT(XCOORD,YCOORD,ZCOORD,ZNUMBE,GROUPN,NATOMSM,
     1             NTYPES,OK)
C
C   8-dec-86 C.Brouder
C   This subroutine builds the file containing the additional input
C   required for MOLPOT once CLEM has been run.
C   15-dec-86 If program CONTINUUM is to be run with complex
C             potential, set all alpha parametres to zero.
C             If program MOLPOT is to be run with an outer sphere,
C             write corresponding parametres.
C
C  Arguments description :
C  XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms
C  ZNUMBE	Array of the atomic numbers of the atoms
C  GROUPN	Array of the number of the group to which the
C               atoms belong. (A group is a class of atoms equivalent
C               by the symmetry operations of the symmetry group)
C   NATOMSM	Number of atoms
C   NTYPES	Number of groups (prototypical atoms)
C
C   DATA description (Value of data is [value]) :
C   NRUNS	Number of cluster for which potential is computed [1]
C   INV		Logical unit from which output from CLEM is read [8]
C
C   NOUT	0 No outer sphere, 1 an outer sphere [0]
C   NWR1	Punched output to be punched [PCH]
C   NWR2	Print charge densities, charge, potential [PRT]
C   1NSPINS	1 spin restricted potential, 2 spin polarized potential [1]
C   EXAFCO	Slater alpha parameter for exchange for the interstitial regi
C   OVLF	Overlap factor of neighbouring spheres [.10]
C   CHPERC	The charge radius of the atom, is defined as the radius
C               for which the integrated density of charge is Z*(1+CHPER
C               This is used to compute the muffin-tin radii [0.005]
C   NCUT	A control number intended to change the mesh size for high
C               energy calculations [0] (= no change)
C
C   NSYMBL	4 character description of the atom (Symbol + number)
C   NEQ		0 for prototypical atoms
C               NTYPE of the prototypical atom for atoms equivalent to N
C   NGBR	The number of neighbours surrounding the atom.
C   NTYPE	Type of the atom (Group number)
C   XV,YV,ZV	Coordinates in atomic units
C   EXFACT	Slater alpha parameter
C
C   ALPHAP	Alpha Parameter of elements, from Schwarz, (Phys.Rev.B 5(7)
C		2466 (1972)) up to Z=41 (Nb), some possible "interpolation"
C               for the other elements.
C   NAMEAT	Name of atoms
C   OUTER	Logical. .TRUE. if MOLPOT is to be run with an outer sphere
C   BOHRAD	Bohr radius in Angstrom
C
C***********************************************************************
C
        INCLUDE 'msxas3.inc'
C
        COMMON/CONTINUUM/EMIN,EMAX,DELTA,CIP,GAMMA,EFTRI,IEXCPOT
C
        REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM
C
	COMMON/MOLINP/
     1  EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM,
     1  NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_),
     1  NAM(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2

C
	PARAMETER (NEIMAX=nat_)
	REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS)
	INTEGER ZNUMBE(NATOMS),ZNBRE,GROUPN(NATOMS)
	INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX)
	LOGICAL OK,OUTER,PROTO,DEUX
	CHARACTER*5 NWR1,NWR2
	REAL ALPHAP(100)
	DATA NRUNS/1/,INV/8/
        DATA NOUT/0/,NSPINS/1/
	DATA OVLF/0.0/,CHPERC/0.005/,NCUT/1/
C	DATA BOHRAD/.529177/
	DATA BOHRAD/1.0/
C H-Ne,Na-Ca,Sc-Zn,Ga-Zr,Nb-Sn,Sb-Nd,Pm-Yb
	DATA ALPHAP/.978,.773,.781,.768,.765,.759,.752,.744,.737,.731,
     1 .731,.729,.728,.727,.726,.725,.723,.722,.721,.720,
     1 .718,.717,.716,.714,.713,.712,.710,.709,.707,.707,
     1 .707,.707,.707,.706,.706,.706,.706,.705,.705,.704,
     1 .704,.704,.704,.704,.704,.704,.704,.704,.704,.704,
     1 .703,.703,.703,.703,.703,.703,.703,.703,.703,.703,
     1 .702,.702,.702,.702,.702,.702,.702,.702,.702,.702,
     1 30*.702/
       NWR1='  PCH'
       NWR2='  PRT'
C
C   Check whether complex potential will be used
C
        IF (IEXCPOT.EQ.4.OR.IEXCPOT.EQ.5) THEN
	   DO 100 I=1,100
	   ALPHAP(I)=0.
100	   CONTINUE
	END IF
C
C   Ask whether an outer sphere is to be used.
C  13-APR-87 In this new version, the file is always generated with an o
C            sphere.
C
	OUTER=.TRUE.
C
C* * * * Open file and write header * * * * * * *
C
	OPEN(UNIT=2,FILE='div/STRPARM.DAT',STATUS='UNKNOWN',
     &       FORM='FORMATTED')
C
C   Write first line
C
	WRITE(2,2000) NRUNS,INV
2000	FORMAT(2I5)
C
C   Compute EXAFCO (EXAFCO is taken as the average of all alpha parametr
C   and write second line.
C
C   Correction for the presence of empty spheres: 27th Sept 2007
C
	NPA = 0
        EXAFCO=0.
        DO 200 I=1,NATOMSM
	NZAT = ZNUMBE(I)
	IF(NZAT.NE.0) THEN
          NPA = NPA + 1
          EXAFCO=EXAFCO+ALPHAP(NZAT)
	ENDIF
200     CONTINUE
        EXAFCO=EXAFCO/NPA
	IF (OUTER) THEN
	   IITYPE=NTYPES+1
	   IIATOM=NATOMSM+1
	   NOUT=1
	ELSE
	   IITYPE=NTYPES
	   IIATOM=NATOMSM
	   NOUT=0
	END IF
	WRITE(2,2010) IITYPE,IIATOM,NOUT,NWR1,NWR2,NSPINS,EXAFCO,OVLF,
     1  CHPERC,NCUT
2010	FORMAT(3I5,2A5,I5,3F10.5,I5)
C
        EXAFCOM=DBLE(EXAFCO)
        OVLFM=DBLE(OVLF)
        CHPERCM=DBLE(CHPERC)
C
C* * * * * * Write outer sphere description if any * * * *
C
	IF (OUTER) THEN
	   XV=0.
	   YV=0.
	   ZV=0.
	   ITYPE=0
	   CALL GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM,
     1     NGBR,NEIGHB,NUMNEI,OK)
	   IF (.NOT.OK) THEN
	      CLOSE(UNIT=2)
	      RETURN
	   END IF
	   EXFACT=EXAFCO
	   ZNBRE=0
	   PROTO=.TRUE.
           N = 1
	   CALL WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN,
     1     NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N)
	END IF
C
C* * * * * * Write prototypical atom description * * * * *
C
	DO 300 NTYPE=1,NTYPES
	XV=XCOORD(NTYPE)/BOHRAD
	YV=YCOORD(NTYPE)/BOHRAD
	ZV=ZCOORD(NTYPE)/BOHRAD
C
C
	CALL GRPNEI(NTYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM,
     1  NGBR,NEIGHB,NUMNEI,OK)
	IF (.NOT.OK) THEN
	   CLOSE(UNIT=2)
	   RETURN
	END IF
	ZNBRE=ZNUMBE(NTYPE)
C
C.......CHANGE FOR ES
C
        IF(ZNBRE.EQ.0.D0) THEN
           EXFACT=EXAFCO
        ELSE
           EXFACT=ALPHAP(ZNBRE)
        ENDIF
	PROTO=.TRUE.
        N=NTYPE+1
	CALL WRIDAT(XV,YV,ZV,NTYPE,ZNBRE,NGBR,EXFACT,GROUPN,
     1  NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N)
300	CONTINUE
C
C* * * * * Write non prototypical atom description * * * * * *
C
	IF (NATOMSM.GT.NTYPES) THEN
	   DO 400 I=NTYPES+1,NATOMSM
	   XV=XCOORD(I)/BOHRAD
	   YV=YCOORD(I)/BOHRAD
 	   ZV=ZCOORD(I)/BOHRAD
	   ZNBRE=ZNUMBE(I)
C
C.......CHANGE FOR ES
C
        IF(ZNBRE.EQ.0.D0) THEN
           EXFACT=EXAFCO
        ELSE
           EXFACT=ALPHAP(ZNBRE)
        ENDIF
	   CALL GRPNEI(I,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM,
     1     NGBR,NEIGHB,NUMNEI,OK)
	   IF (.NOT.OK) THEN
C	      CLOSE(UNIT=2)
	      RETURN
	   END IF
	   PROTO=.FALSE.
           N = I + 1
	   CALL WRIDAT(XV,YV,ZV,I,ZNBRE,NGBR,EXFACT,GROUPN,
     1     NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N)
400	   CONTINUE
	END IF
C	CLOSE (UNIT=2)
C
C * * * * * * * Create MOLSYM.COO * * * * * * * *
C
C   Now we create a file called MOLSYM.COO which lists the coordinates
C   and the number of each atom in the cluster, according to the
C   FORMAT required by MOLSYM. This file will be used later on to
C   make the input file of MOLSYM. In this file, the atoms must be
C   ordered according to their group (all equivalent atoms must follow
C   each other), and numbered according to the way their are declared
C   in the input of MOLPOT. If an outer sphere is to be used, it must
C   be declared to be atom number 1.
C   According to the FORMAT required by MOLSYM, the atoms must
C   be written in pairs. The logical variable DEUX is here to say
C   that two atoms are available and it is time to write them.
C
	OPEN(UNIT=2,FILE='div/molsym.coo',STATUS='unknown')
C***************************************************
C***************************************************
	DEUX=.TRUE.
C****	IF (OUTER) THEN
C****	   XX1=0.
C****	   YY1=0.
C**	   ZZ1=0.
C**	   NN1=1
C**	   DEUX=.FALSE.
C**	END IF
C
        X0 = XCOORD(1)
        Y0 = YCOORD(1)
        Z0 = ZCOORD(1)
C
	DO 500 ITYPE=1,NTYPES
	DO 500 I=1,NATOMSM
C
C   Order atoms according to their groups
C
	IF (GROUPN(I).EQ.ITYPE) THEN
	   IF (DEUX) THEN
	      XX1=XCOORD(I)/BOHRAD - X0
	      YY1=YCOORD(I)/BOHRAD - Y0
	      ZZ1=ZCOORD(I)/BOHRAD - Z0
C***	      IF (OUTER) THEN
C***	         NN1=I+1
C***	      ELSE
	         NN1=I
C***	      END IF
	      DEUX=.FALSE.
	   ELSE
	      XX2=XCOORD(I)/BOHRAD - X0
	      YY2=YCOORD(I)/BOHRAD - Y0
	      ZZ2=ZCOORD(I)/BOHRAD - Z0
C***	      IF (OUTER) THEN
C***	         NN2=I+1
C***	      ELSE
	         NN2=I
C***	      END IF
	      WRITE (2,3000) XX1,YY1,ZZ1,NN1,XX2,YY2,ZZ2,NN2
3000	      FORMAT(2(3F10.6,I5,5X))
	      DEUX=.TRUE.
	   END IF
	END IF
500	CONTINUE
C
C   If the number of atoms written in the file (including possibly
C   the outer sphere) is not even, there is an atom that is left
C   to be written, so write it. In any case, close the file.
C
	IF (.NOT.DEUX) THEN
	   WRITE (2,3010) XX1,YY1,ZZ1,NN1
3010	   FORMAT(3F10.6,I5,5X)
	END IF
	CLOSE (UNIT=2)
	RETURN
	END
C
C***********************************************************************
C
	SUBROUTINE GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM,
     1  NGBR,NEIGHB,NUMNEI,OK)
C
C   9-dec-86 C.Brouder
C   This subroutine finds the groups of neighbours of atom number ITYPE
C   A group of neighbours of atom ITYPE is a set of all atoms
C   at the same distance from atom ITYPE and belonging to the same group
C   (i.e. equivalent to the same prototypical atom, i.e.having the same
C   group number GROUPN).
C   At the end, the groups of neigbours are sorted according to increasi
C   distances.
C
C  Arguments description :
C  ITYPE	# of atom (0 if outer sphere) whose neighbours
C		are to be determined.
C  XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms.
C  GROUPN	Array of the number of the group to which the
C               atoms belong. (A group is a class of atoms equivalent
C               by the symmetry operations of the symmetry group).
C   NATOMSM	Number of atoms
C   NGBR	Number of groups of neighbours
C   NEIGHB	# of an atom in the group of neigbours
C   NUMNEI	Number of atoms in the group of neighbours
C   NEIMAX      Maximum number of groups of neighbours.
C
C   DISTAN	Array of distances of neigbours
C   EPSILO	If the distances are smaller than EPSILO, they are
C               supposed to be identical.
C
C*********************************************************************
C
        INCLUDE 'msxas3.inc'
C
	PARAMETER (NEIMAX=nat_)
	REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS)
	REAL DISTAN(NEIMAX)
	INTEGER GROUPN(NATOMS),NEIGHB(NEIMAX),NUMNEI(NEIMAX)
	LOGICAL OK,NEW
	DATA EPSILO/1.E-5/
	NGBR=1
C
C   Initialize arrays
C
	DO 100 I=1,NATOMSM
	NEIGHB(I)=0
	NUMNEI(I)=0
100	CONTINUE
	IF (ITYPE.EQ.0) THEN
	   X0=0.
	   Y0=0.
	   Z0=0.
	ELSE
	   X0=XCOORD(ITYPE)
	   Y0=YCOORD(ITYPE)
	   Z0=ZCOORD(ITYPE)
	END IF
C
C   Scan all other atoms
C
	DO 200 I=1,NATOMSM
	IF (I.NE.ITYPE) THEN
C
C   Compute distance
C
	   NEW=.TRUE.
	   DISTAN(NGBR)=(XCOORD(I)-X0)*(XCOORD(I)-X0)
	   DISTAN(NGBR)=DISTAN(NGBR)+(YCOORD(I)-Y0)*(YCOORD(I)-Y0)
	   DISTAN(NGBR)=DISTAN(NGBR)+(ZCOORD(I)-Z0)*(ZCOORD(I)-Z0)
	   DISTAN(NGBR)=SQRT(DISTAN(NGBR))
	   IF (NGBR.NE.1) THEN
C
C   Check whether this distance already exists and the corresponding
C   atom belongs to the same group.
C
	      DO 210 I2=1,NGBR-1
	      IF ((ABS(DISTAN(I2)-DISTAN(NGBR)).LT.EPSILO).AND.
     1           (GROUPN(NEIGHB(I2)).EQ.GROUPN(I))) THEN
	         NEW=.FALSE.
	         NUMNEI(I2)=NUMNEI(I2)+1
	      END IF
210	      CONTINUE
	   END IF
C
C   If it does not, this is a new group
C
	   IF (NEW) THEN
	      NUMNEI(NGBR)=1
	      NEIGHB(NGBR)=I
	      NGBR=NGBR+1
	      IF (NGBR.GT.NEIMAX) THEN
	         PRINT 4000
4000	         FORMAT(' Too many neighbours, increase NEIMAX in',
     1                  ' subroutines GRPNEI and MOLDAT')
	         OK=.FALSE.
	         RETURN
	      END IF
	   END IF
	END IF
200	CONTINUE
	NGBR=NGBR-1
C
C   Order groups of neighbours according to increasing distances
C
	DO 300 I=1,NGBR
C
C   Look for the smallest remaining distance
C
	DISMIN=1.E20
	IDISMI=I
	DO 310 J=I,NGBR
	IF (DISTAN(J).LT.DISMIN) THEN
	   DISMIN=DISTAN(J)
	   IDISMI=J
	END IF
310	CONTINUE
C
C   Transpose values
C
	IF (IDISMI.NE.I) THEN
	   N1TEMP=NEIGHB(I)
	   N2TEMP=NUMNEI(I)
	   DTEMPO=DISTAN(I)
	   NEIGHB(I)=NEIGHB(IDISMI)
	   NUMNEI(I)=NUMNEI(IDISMI)
	   DISTAN(I)=DISTAN(IDISMI)
	   NEIGHB(IDISMI)=N1TEMP
	   NUMNEI(IDISMI)=N2TEMP
	   DISTAN(IDISMI)=DTEMPO
	END IF
300	CONTINUE
	RETURN
	END
C
C***********************************************************************
C
	SUBROUTINE WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN,
     1                    NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N)
C
C   This subroutine writes on file 2 the data collected by MOLDAT,
C   for each atom. There are many cases to consider : the outer sphere
C   (ITYPE=0), prototypical atoms (PROTO=.TRUE.), non prototypical atoms
C   (PROTO=.FALSE.) and in the latter cases, the outputs are different
C   if there is an outer sphere (OUTER=.TRUE.) or not.
C   Variable description
C   XV,YV,ZV	Position
C   ITYPE	# of atom whose data are involved
C   ZNBRE	Z number of atom
C   NGBR	Number of neighbours
C   EXFACT	Alpha parametre
C   GROUPN	Group numbers
C   NUMNEI	Number of neighbours
C   NEIGHB	Example of neighbour
C   NATOMSM	Number of atoms
C   OUTER	.TRUE. if there is an outer sphere
C   PROTO	.TRUE. if this is a prototypical atom
C
C   NSYMBL	Symbol
C
C********************************************************************
C
        INCLUDE 'msxas3.inc'
C
        REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM
C
        COMMON/MOLINP/
     1  EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM,
     1  NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_),
     1  NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2
C
	PARAMETER (NEIMAX=nat_)
	INTEGER GROUPN(NATOMS),ZNBRE
	INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX)
	LOGICAL PROTO,OUTER
        CHARACTER*5 NWR1,NWR2
C
C* * * * * * Initialize data * * * * * * *
C
C
C   NEQ (0 if prototypical atom, NTYPE of prototypical atom otherwise
C
	IF (PROTO) THEN
	   NEQ=0
	ELSE
	   IF (OUTER) THEN
	      NEQ=GROUPN(ITYPE)+1
	   ELSE
	      NEQ=GROUPN(ITYPE)
	   END IF
	END IF
C
C   NTYPE (if outer sphere, outer sphere is number 1, so add 1 to
C   all group numbers)
C
	IF (PROTO) THEN
	   IF (OUTER) THEN
	      NTYPE=ITYPE+1
	   ELSE
	      NTYPE=ITYPE
	   END IF
	ELSE
	   NTYPE=NEQ
	END IF
C
C* * * Initialize variables for subroutine molpot * * *
C
        NGBRM(N)=NGBR
        NTYPEM(N)=NTYPE
        EXFCTM(N)=DBLE(EXFACT)
C
C* * * Initialize variables for subroutine molpot * * *
C
        IF (PROTO) THEN
          DO 300 K=1,NGBR
          IF (OUTER) THEN
             NATAN(K,N) = GROUPN(NEIGHB(K)) + 1
             NAT1(K,N) = NEIGHB(K) + 1
          ELSE
             NATAN(K,N) = GROUPN(NEIGHB(K))
             NAT1(K,N) = NEIGHB(K)
          ENDIF
300       NA(K,N) = NUMNEI(K)
        ENDIF
C
	RETURN
	END
C
C***********************************************************************
C
      SUBROUTINE MOLPOT
C
C     SPIN-RESTRICTED MOLECULAR POTENTIAL PROGRAM
C     GENERATES SUPERPOSED-ATOM POTENTIAL USED TO START SCF CALCULATION
C
      implicit real*8 (a-h,o-z)
      include 'msxas3.inc'
c
      include 'msxasc3.inc'
c
      character*8 nsymbl
c..
c     common/dimens/nats,ndat,nout,lmaxx,irreps
      common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms),
     u  nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms),
     u  lmaxat(natoms)
      common/aparms_extra/rs_(natoms),redf_(natoms),ovlf
c
      integer trans
      common/transform/trans(natoms)
C
      COMMON/MOLINP/
     *          EXFAC0,EXFACT(NAT_),OVLFM,CHPERC,NTYPES,NATOMSM,
     *          NGBR(NAT_),NTYPE(NAT_),NATAN(NAT_,UA_),
     *          NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2
C
      COMMON/CRHOAT/ RO(441,UA_,1)
C
      COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT
C
      COMMON/MTRAD/ RS(NAT_)
C
      COMMON/STRUCT/NTNABS(NAT_),NGBRABS
C
      DIMENSION R(441,UA_),V(441,1),RV(441,UA_),Q(441),ALPHA(441),
     1          BETA(441),GAMMA(441,1),SNLO(441),XI(441),XJ(441),
     2          ZPALPH(441),ROTOTL(441,1),ROT(441)
C
      DIMENSION ZM(NAT_),NZM(NAT_),NIMAX(NAT_),AN(NAT_,NAT_),
     *          FAC2(NAT_),RSC(NAT_)
C
      CHARACTER*5 NWR1,NWR2
C
c      DATA PI/3.14159265358979/
c     DATA PI4/12.56637061435916/,THIRD/.333333333333333/
C
      LOGICAL SKIP
      PI=3.14159265358979D0
      PI4=12.56637061435916D0
      THIRD=.333333333333333D0
      NRUNS = 1
      DO 999 IRUNS=1,NRUNS
1002  FORMAT(15I5)
      SKIP=.FALSE.
C
C.....MOUT:   CONTROLS THE OUTPUT OF PROGRAM INPOT. IF MOUT=1 THIS
C.....        OUTPUT WILL CONTAIN THE OUTER SPHERE. IF MOUT=0 IT
C.....        WILL NOT. THIS VERSION INITIALIZED TO MOUT=0
C.....0VLF:   THIS IS THE OVERLAP FACTOR FOR THE MUFFIN-TIN RADII
C.....        DEFAULT=0.1 IN SUBROUTINE MOLDAT
C.....CHPERC: THIS IS THE PERCENTAGE OF ATOMIC CHARGE INSIDE THE
C.....        ATOMIC SPHERES WHEN APPLYING NORMAN CRITERIUM
C.....        DEFAULT=0.005 IN SUBROUTINE MOLDAT
C
      MOUT=0
      NOUT=1
      NSPINS=1
      NSAT=1
      NCUT=1
      FAC1=NSPINS
      NDAT=NATOMSM
      OPEN (UNIT=7,FILE='div/molinpot3.out',STATUS='unknown')
      DO 43 N=1,NATOMSM
C     READ(5,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N),
C    1  EXFACT(N)
 1001 FORMAT(1X,A8,3I5,4F10.6)
      WRITE(7,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N),
     1  EXFACT(N)
      FAC2(N)=6.D0*EXFACT(N)*(FAC1*3.D0/(32.D0*PI*PI))**THIRD
      IF(NEQ(N).NE.0) GO TO 443
      NGBRS=NGBR(N)
C     READ(5,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS)
C     NATAN=TYPE OF NEIGHBOR  NA=NUMBER OF ATOMS IN GROUP  NAT1=LABEL OF
C      ONE OF THE NEIGHBORS
C
      WRITE(7,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS)
      IF(SKIP) GO TO 4511
      GO TO 43
 4511 WRITE(7,1045)
 1045 FORMAT('   DIFFERENT ATOMS MUST COME FIRST')
      SKIP=.FALSE.
      GO TO 43
  443 IF(SKIP) GO TO 43
      SKIP=.TRUE.
      NDAT=N-1
   43 CONTINUE
C
C     AN(I,N): DISTANCE OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I
C
      WRITE(7,*)
      WRITE(7,*) 'DIST. OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I'
      ANMAX = 0.0D0
      DO 44 N=1,NDAT
      ANPR=0.0D0
      NGBRS=NGBR(N)
      IF(N.EQ.2) NGBRABS=NGBRS
      DO 44 I=1,NGBRS
      NT = NATAN(I,N)
      IF(N.EQ.2) NTNABS(I)=NT-1
C      write(6,*) i,nt,ntnabs(i),ngbrabs
      NB=NAT1(I,N)
      AN(I,N)=DSQRT((XV(NB)-XV(N))**2+(YV(NB)-YV(N))**2+(ZV(NB)-ZV(N))**
     1 2)
      WRITE(7,*) N, NT, AN(I,N)
      IF(I.EQ.1) THEN
        ANPR=AN(I,N)
        GO TO 440
      ENDIF
      IF(AN(I,N).LT.ANPR) THEN
        WRITE(7,30) I,N
   30   FORMAT(' **WARNING** : NEIGHBOR OF TYPE',I3,' TO ATOM',I3,
     *         ' NOT ARRANGED IN ASCENDING ORDER OF DISTANCE')
C
C      CALL EXIT
C
      ENDIF
  440 IF(N.NE.1) GO TO 44
      IF(AN(I,N).GT.ANMAX) ANMAX = AN(I,N)
   44 CONTINUE
      SKIP=NOUT.NE.0
      WRITE(7,104) NATOMSM,NDAT,FAC1
  104 FORMAT(30X,I3,7H ATOMS,,I3,17H DIFFERENT, FAC1=,F11.7)
      WRITE(7,105) (NSYMBL(N),NEQ(N),XV(N),YV(N),ZV(N),EXFACT(N),N=1,
     1 NATOMSM)
  105 FORMAT(//28X,6HSYMBOL,4X,2HEQ,5X,1HX,11X,1HY,11X,1HZ,7X,6HEXFACT
     1  /(30X,A5,I6,4F11.7))
      DO 1 N=1,NTYPES
      IF(SKIP) GO TO 89
      WRITE(7,2002) NZEQ(N),NSAT
 2002 FORMAT(6I4)
      KMAX=441
      ZM(N)=NZEQ(N)
      NZM(N)=NZEQ(N)
      TZ=2.D0*ZM(N)
      GO TO 90
   89 DELTAR=.88534138D0*.0025D0
      NZM(1)=1
      GO TO 91
   90 IF(ZM(N).EQ.0.D0) THEN
         DELTAR=.88534138D0*.0025D0
      ELSE
         DELTAR=.88534138D0*.0025D0/ZM(N)**THIRD
      ENDIF
   91 I=1
      R(1,N)=0.D0
      DO 87 J=1,11
      DO 88 K=1,40
      I=I+1
   88 R(I,N)=R(I-1,N)+DELTAR
   87 DELTAR=2.0D0*DELTAR
      IF(SKIP) GO TO 49
      DO 52 K=1,441
   52 ROT(K)=RO(K,N,1)
      CALL MINTEGR(ROT,XI,R(1,N),441)
      Q(1)=0.D0
      DO 10 I=2,441
   10 Q(I)=ROT(I)/R(I,N)
      CALL MINTEGR(Q,XJ,R(1,N),441)
C
C     RV=R*(  COULOMB POTENTIAL  )
C
      DO 12 I=1,441
   12 RV(I,N)=-TZ+2.D0*(XI(I)+R(I,N)*(XJ(441)-XJ(I)))
      IF(NSPINS.EQ.1.AND.ZM(N).NE.0)
     1 WRITE(7,101) N,(I,R(I,N),RV(I,N),ROT(I),XI(I),I=1,KMAX)
  101 FORMAT(1H1,40X,22HATOMIC DATA FOR CENTER,I3,4X,/,
     &      2(9X,1HR,15X,2HRV,
     1  14X,3HRHO,11X,6HCHARGE,3X),/,2(I4,1P4E15.6))
      GO TO 1
   49 DO 50 J=1,441
   50 RV(J,N)=0.D0
    1 SKIP=.FALSE.
      IF(NWR1.NE.'  PCH') GO TO 1041
      OPEN (UNIT=4,FORM='UNFORMATTED',STATUS='unknown')
      REWIND(4)
      WRITE(4) NATOMSM,NDAT,NOUT,EXFAC0,NSPINS
      KC=2
 1041 DO 1000 M=1,NDAT
      N=NTYPE(M)
      NZM(M)=NZM(N)
      NIMAX(M)=441
      IF(M.EQ.1.AND.NOUT.NE.0) GO TO 450
      DO 1043 J=1,441
      IF(R(J,N).LT.AN(1,M)) GO TO 1043
      NIMAX(M)=J
      GO TO 450
 1043 CONTINUE
  450 NBRS=NGBR(M)
      IMAX=NIMAX(M)
      DO 600 I=1,441
      ZPALPH(I)=0.D0
      BETA(I)=0.D0
      DO 600 ISPIN=1,NSPINS
      ROTOTL(I,ISPIN)=0.D0
  600 GAMMA(I,ISPIN)=0.D0
      DO 45 I=1,NBRS
      MVAL=NATAN(I,M)
      IF(NOUT.NE.0.AND.MVAL.EQ.1) GO TO 45
C
C     ITH SET OF NEIGHBORS TO CENTER M
C     N IS TYPE OF CENTER M
C     MVAL IS THE TYPE OF ITH SET OF NEIGHBORS TO CENTER M
C
      IF(AN(I,M).GT..00001D0) GO TO 650
C
C     FOR A CENTER COINCIDING WITH THE MOLECULAR CENTER
C     AVERAGE VALUES ARE EQUAL TO THE VALUES AT THE POINT
C
      DO 652 J=2,IMAX
      CALL MINTERP(R(J,N),RV(1,MVAL),XVAL,R(1,MVAL))
      ZPALPH(J)=ZPALPH(J)+NA(I,M)*XVAL
      BETA(J)=BETA(J)-0.5D0*XVAL*NA(I,M)*R(J,N)**2
      DO 652 ISPIN=1,NSPINS
      CALL MINTERP(R(J,N),RO(1,MVAL,ISPIN),XVAL,R(1,MVAL))
      ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*XVAL/R(J,N)
  652 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)-0.5D0*XVAL*NA(I,M)*R(J,N)
      DO 451 ISPIN=1,NSPINS
      CALL MINTEGR(RO(1,MVAL,ISPIN),SNLO,R(1,MVAL),441)
      DO 451 J=1,441
      CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL))
      XJ(J)=R(J,MVAL)*RV(J,MVAL)
  451 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*XVAL
      CALL MINTEGR(XJ,SNLO,R(1,MVAL),441)
      DO 452 J=1,441
      CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL))
  452 BETA(J)=BETA(J)+NA(I,M)*XVAL
      GO TO 45
C
C     FOR SEPARATED CENTERS CALCULATE SPHERICAL AVERAGES AROUND CENTER M
C
  650 CALL MINTEGR(RV(1,MVAL),SNLO,R(1,MVAL),441)
      CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL)
      DO 65 J=2,IMAX
   65 ZPALPH(J)=NA(I,M)*ALPHA(J)+ZPALPH(J)
      Q(1)=0.D0
C
C     SPHERICAL AVERAGE CHARGE DENSITY
C
      DO 95 ISPIN=1,NSPINS
      DO 901 J=2,441
  901 Q(J)=RO(J,MVAL,ISPIN)/R(J,MVAL)
      CALL MINTEGR(Q,SNLO,R(1,MVAL),441)
      CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL)
      DO 95 J=2,IMAX
   95 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*ALPHA(J)
      IF(N.NE.1.OR.NOUT.EQ.0) GO TO 45
      XJ(1)=0.D0
C
C     TOTAL CHARGE FOR OUTER SPHERE
C
      DO 37 ISPIN=1,NSPINS
      DO 36 J=2,441
   36 XJ(J)=-RO(J,MVAL,ISPIN)*(R(J,MVAL)-AN(I,M))**2/R(J,MVAL)
      CALL MINTEGR(XJ,SNLO,R(1,MVAL),441)
      CALL ALPHA0(AN(I,M),SNLO,Q,R,441,N,MVAL)
      CALL MINTEGR(RO(1,MVAL,ISPIN),XJ,R(1,MVAL),441)
      DO 37 J=2,441
      CALL MINTERP(R(J,N)-AN(I,M),XJ,XVAL,R(1,MVAL))
   37 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*(XVAL+0.5D0*Q(J))
C
C     INTEGRATED POTENTIAL FOR OUTER SPHERE
C
      XI(1)=0.D0
      XJ(1)=-RV(1,MVAL)*AN(I,M)**2
      DO 46 J=2,441
      XI(J)=RV(J,MVAL)*R(J,MVAL)
   46 XJ(J)=-RV(J,MVAL)*(R(J,MVAL)-AN(I,M))**2
      CALL MINTEGR(XI,Q,R(1,MVAL),441)
      CALL MINTEGR(XJ,SNLO,R(1,MVAL),441)
      CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,441,N,MVAL)
      DO 47 J=2,441
      CALL MINTERP(R(J,N)-AN(I,M),Q,XVAL,R(1,MVAL))
   47 BETA(J)=BETA(J)+NA(I,M)*(XVAL+0.5D0*ALPHA(J))
   45 CONTINUE
      IF(N.NE.1.OR.NOUT.EQ.0) GO TO 2003
      DO 2005 J=1,IMAX
      BETA(J)=(BETA(J)+0.5D0*ZPALPH(J)*R(J,N)**2)*PI4
      DO 2005 ISPIN=1,NSPINS
      ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N)
 2005 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+0.5D0*ROTOTL(J,ISPIN)*R(J,N)
      GO TO 112
C
C     INTEGRATED POTENTIAL AND TOTAL CHARGE FOR MUFFIN-TIN SPHERE
C     GAMMA(I,ISPIN) IS TOTAL INTEGRATED CHARGE, BETA(I) IS INTEGRATED
C     POTENTIAL, ZPALPH(I) IS R*VCOULOMB CALCULATED WITH PROJECTED
C     DENSITY
C
 2003 DO 2001 J=1,IMAX
      ZPALPH(J)=ZPALPH(J)+RV(J,N)
      Q(J)=PI4*R(J,N)*ZPALPH(J)
      DO 2001 ISPIN=1,NSPINS
 2001 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N)+RO(J,N,ISPIN)
      DO 2004 ISPIN=1,NSPINS
 2004 CALL MINTEGR(ROTOTL(1,ISPIN),GAMMA(1,ISPIN),R(1,N),IMAX)
      CALL MINTEGR(Q,BETA,R(1,N),IMAX)
  112 DO 111 ISPIN=1,NSPINS
      V(1,ISPIN)=0
      DO 111 J=2,IMAX
C
C      VC(J) = ZPALPH(J)/R(J,N)
C
  111 V(J,ISPIN)=(ZPALPH(J)-FAC2(M)*(R(J,N)*DABS(ROTOTL(J,ISPIN)))**THIR
     1D)/R(J,N)
C
C...FIND RADIUS CONTAINING THE ATOMIC NUMBER OF ELECTRONS WITHIN CHPERC
C
      RSC(M) = AN(1,M)/2.D0
      IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 14
      IF(NZM(M).EQ.0) GO TO 14
      DO 13 I=1,IMAX
C      IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 13
      CHPCI=(ZM(M)-GAMMA(I,1))/ZM(M)
      IF(CHPCI.GT.CHPERC)GO TO 13
      RSC(M) = R(I,M)
      GO TO 14
   13 CONTINUE
   14 IF(NWR2.NE.'  PRT') GO TO 1032
      WRITE(7,6)M
    6 FORMAT(1H1,35X,11HATOM NUMBER,I6)
      WRITE(7,7) (NA(I,M),NATAN(I,M),AN(I,M),I=1,NBRS)
    7 FORMAT(/     23H NO. OF CENTERS    TYPE,7X,8HDISTANCE/(5X,I4,10X,I
     1  4,F17.8))
      IF(NSPINS.EQ.1) WRITE(7,9)(J,R(J,N),ZPALPH(J),BETA(J),GAMMA(J,1),V
     1 (J,1),ROTOTL(J,1),J=1,IMAX)
    9 FORMAT(16X,1HR,16X,6HZPALPH,5X,20HINTEGRATED POTENTIAL,7X,12HTOTAL
     1 CHARGE,13X,1HV,18X,3HRHO/(I4,6E20.8))
 1032 IF(NWR1.NE.'  PCH') GO TO 1000
      NIMAX(M)=NIMAX(M)-1
      WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M),
     1  ZV(M),EXFACT(M),KC
      KC=KC+1
      DO 1014 ISPIN=1,NSPINS
      DO 1014 K=2,IMAX,5
      KCARD=MIN0(IMAX,K+4)
      WRITE(4) KC,( V(I,ISPIN),I=K,KCARD)
 1014 KC=KC+1
C      DO 1020 K=2,IMAX,5
C      KCARD=MIN0(IMAX,K+4)
C      WRITE(4,1015) KC,( VC(I),I=K,KCARD)
C 1020 KC=KC+1
      DO 2214 ISPIN=1,NSPINS
      DO 2214 K=2,IMAX,5
      KCARD=MIN0(IMAX,K+4)
      WRITE(4) KC,(ROTOTL(I,ISPIN)   ,I=K,KCARD)
 2214 KC=KC+1
      DO 1016 K=2,IMAX,5
      KCARD=MIN0(IMAX,K+4)
      WRITE(4) KC,(BETA(I),I=K,KCARD)
 1016 KC=KC+1
      DO 1019 ISPIN=1,NSPINS
      DO 1019 K=2,IMAX,5
      KCARD=MIN0(IMAX,K+4)
      WRITE(4) KC,(GAMMA(I,ISPIN)   ,I=K,KCARD)
 1019 KC=KC+1
 1000 CONTINUE
C
      WRITE(7,*)  'CHECKING MUFFIN-TIN RADII'
      IF(OPTRSH.EQ.'y') THEN 
         WRITE(6,*) ' MT radii for Hydrogen atoms set to rsh'
         WRITE(7,*) ' MT radii for Hydrogen atoms set to rsh =', RSH
      ELSE
         WRITE(6,*) ' MT radii for Hydrogen atoms determined by stdcrm',
     &              ' unless other options are specified' 
         WRITE(7,*) ' MT radii for Hydrogen atoms determined by stdcrm',
     &              ' unless other options are specified' 
      ENDIF 
      WRITE(7,*) '   M, Z(M),  MN, Z(MN), AN(MN,M),',
     &           '  RSC(M), RSC(MN),  RS(M),  RS(MN)'
C
C     FIND MUFFIN-TIN RADIUS FOR PAIR IJ ACCORDING TO NORMAN CRITERIUM (STDCRM)
C
      DO 18 M=1,NDAT
      IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 18
      NBRS=NGBR(M)
      IF(NZM(M).NE.0) THEN
	   DO NG = 1, NBRS
            MN=NATAN(NG,M)
	      IF(NZM(MN).NE.0) GO TO 191
	   ENDDO
191      RS(M)=AN(NG,M)*(1.D0+OVLF)/(1.D0+RSC(MN)/RSC(M))
C
C     IF OPTRSH='y' MT RADIUS FOR H ATOMs SET TO RSH IN INPUT  !  Added 16 Jul 2013
C
         IF(NZM(M).EQ.1.AND.OPTRSH.EQ.'y') THEN 
            WRITE(6,*) ' MT radius', RS(M),' for H atom', M,
     &                 ' set to', RSH
            RS(M) = RSH
         ENDIF
         WRITE(7,190)  M, NZM(M), MN, NZM(MN), AN(NG,M),
     &                 RSC(M), RSC(MN), RS(M), RS(MN)
         GO TO 18
      ENDIF
      MN = NATAN(1,M)
      IF (NZM(MN).EQ.0.D0) THEN
      	 RS(M) = AN(1,M)*(1.D0+OVLF)/2.D0
      ELSE
         RS(M) = (AN(1,M)-RS(MN))*(1.D0+OVLF)
      ENDIF
      WRITE(7,190)  M, NZM(M), MN, NZM(MN), AN(1,M),
     &              RSC(M), RSC(MN), RS(M), RS(MN)
190   FORMAT(4I5, 5F10.5)
      IF(NORMAN.EQ.'stdfac'.OR.NORMAN.EQ.'scaled')
     *RS(M)=REDF_(M)*RSC(M)
   18 CONTINUE
      IF(NOUT.EQ.1) RS(1) = ANMAX + RS(NDAT)
      IF(NDAT.EQ.NATOMSM) GO TO 5001
      NDAT1=NDAT+1
      DO 221 M=NDAT1,NATOMSM
      NZM(M)= NZM(NEQ(M))
      RS(M)= RS(NEQ(M))
      NIMAX(M)=0
      WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M),
     1  ZV(M),EXFACT(M),KC
  221 KC=KC+1
 5001 CONTINUE
      IF (NORMAN.EQ.'extrad') THEN
         RS(1) = ANMAX + RS_(NDAT)
         DO 5002 M=2,NATOMSM
 5002    RS(M)=RS_(M)
      END IF
      IF (NORMAN.NE.'extrad') THEN
         WRITE(6,*)
         WRITE(6,5003)
 5003    FORMAT(1X,65('-'))
         WRITE(6,*) ' i    rs(i)   i=1,natoms      '
         WRITE(6,5004) (I, RS(I), I=1,NATOMSM)
         WRITE(6,*) ' N.B.: Order of atoms as reshuffled by',
     *              ' symmetry routines '
 5004    FORMAT(8(I5,1X,F7.2))
         WRITE(6,5003)
         WRITE(6,*)
      END IF
      IF(NWR1.NE.'  PCH') GO TO 999
      WRITE(7,*)
      WRITE(7,*) ' Radion, qion, ncut, rs(i), i=1,nat'
      WRITE(7,19) RADION,QION,NCUT,(RS(M),M=1,NATOMSM)
   19 FORMAT(/,1X,2F10.5,I5/(8F10.5),//)
  999 CONTINUE
C
      REWIND(4)
C
      RETURN
      END
C
CLAGRNG
      SUBROUTINE LAGRNG(F,LPLACE,B,RES)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION F(4),B(4)
      RES=0.D0
      DO 5 N=1,4
      M=LPLACE-2+N
    5 RES=RES+B(N)*F(M)
      RETURN
      END
CBSET
      SUBROUTINE BSET(PINTRP,B)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION B(4)
      PM=PINTRP*(PINTRP**2-1.D0)*(PINTRP-2.D0)
      B(1)=-PM/(6.D0*(PINTRP+1.D0))
      B(2)= PM/(2.D0*PINTRP)
      B(3)=-PM/(2.D0*(PINTRP-1.D0))
      B(4)= PM/(6.D0*(PINTRP-2.D0))
      RETURN
      END
CINTERP
C     L.F. MATTHEISS SUBROUTINE INTERP(B,X1,M2,D,R)
C     B IS THE RADIAL DISTANCE
C     X1 IS THE INTEGRATED FUNCTION
C     D IS THE INTERPOLATED VALUE OF THE INTEGRAL FROM 0 TO B.
C     R IS THE RADIAL MESH
C
      SUBROUTINE MINTERP(B,X1,D,R)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X1(441),R(441),B1(4),C(4)
      IF(B-R(2   ))10,11,12
 10   D=0.0D0
      GOTO 100
   11 D=X1(2)
      GOTO 100
 12   IF(B-R(440   ))15,14,13
   13 D=X1(441)
      GOTO 100
   14 D=X1(440)
      GOTO 100
 15   DO 22 I=1,441
      L=441+1-I
      IF(R(L)-B) 23,24,22
 22   CONTINUE
 23   LPLACE=L
      DO 29 N=1,11
      ISCALE=41+40*(N-1)-LPLACE
      IF(ISCALE)25,46,25
 25   IF(ISCALE-1)29,48,29
 29   CONTINUE
      B1(1)=X1(LPLACE-1)
      B1(2)=X1(LPLACE)
      B1(3)=X1(LPLACE+1)
      B1(4)=X1(LPLACE+2)
      H=R(LPLACE+1   )-R(LPLACE   )
 50   PINTRP=(B-R(LPLACE   ))/H
   51 CALL BSET(PINTRP,C)
      CALL LAGRNG(B1,2,C,D)
 100  RETURN
   24 D=X1(L)
      RETURN
 46   B1(1)=X1(LPLACE-2)
      B1(2)=X1(LPLACE)
      B1(3)=X1(LPLACE+1)
      B1(4)=X1(LPLACE+2)
      H=R(LPLACE+1   )-R(LPLACE   )
      GOTO 50
 48   B1(1)=X1(LPLACE-3)
      B1(2)=X1(LPLACE-1)
      B1(3)=X1(LPLACE+1)
      B1(4)=X1(LPLACE+2)
      H=R(LPLACE+2   )-R(LPLACE+1   )
      PINTRP=(B-R(LPLACE-1   ))/H
      GO TO 51
      END
CINTEGR
C     SIMPSON'S RULE INTEGRATION
C
      SUBROUTINE MINTEGR(X,Y,R,M2)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(441),Y(441),R(441)
      H=R(2)
      Y(1)=0.D0
      Y(2)=H*(5.D0*X(1   )+8.D0*X(2   )-X(3   ))/12.D0
      DO 20 J=1,11
      DO 10 K=1,40
      I=40*(J-1)+K
      IF(I.GT.M2) RETURN
      IF(I-440) 5,10,10
    5 Y(I+2)=Y(I)+H*(X(I   )+4.D0*X(I+1   )+X(I+2   ))/3.D0
   10 CONTINUE
      H=H+H
      IF (I-440) 15,20,15
   15 Y(I+2)=Y(I+1)+H*(5.D0*X(I+1   )+8.D0*X(I+2   )-X(I+3   ))/12.D0
   20 CONTINUE
      RETURN
      END
CALPHAO
C     L.F. MATTHEISS SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2)
C     AP IS THE DISTANCE OF THE NEIGHBORING ATOM
C     ZINT IS THE INDEFINITE INTEGRAL
C     ALPHA IS A TABLE OF THE DESIRED ALPHA FUNCTIONS
C     R IS THE RADIAL DISTANCE
C     IMAX IS THE NUMBER OF ALPHA FUNCTIONS TO BE COMPUTED
C     M1 IS THE ATOM NO. AT THE ORIGIN
C     M2 IS THE ATOM NO. AT AP
C
      SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      include 'msxas3.inc'
C
      DIMENSION ZINT(441),ALPHA(441),R(441,UA_)
      DO 100 I=2,IMAX
      APLUSR=AP+R(I,M1)
      AMINSR=DABS(AP-R(I,M1))
      CALL MINTERP(APLUSR,ZINT,XVAL1,R(1,M2))
      CALL MINTERP(AMINSR,ZINT,XVAL2,R(1,M2))
      ALPHA(I)=(XVAL1-XVAL2)/(2.0D0*AP)
 100  CONTINUE
      RETURN
      END
C
      SUBROUTINE INPOT
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      INCLUDE 'msxas3.inc'
C
      character*2 potgen
      character*4 coor
      character*5 potype
      character*7 ionzst
      character*2 edge,charelx
      character*6 norman
      integer absorber,hole
      logical*4 vinput


      common/options/rsh,ovlpfac,vc0,rs0,vinput,absorber,hole,mode,
     &      ionzst,potype,norman,coor,charelx,edge,potgen  

C
C**** CONT_SUB DIMENSIONING VARIABLES
C
      INTEGER   AT_,D_,RD_,SD_
      PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1)
C
C****
C
      COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT
C
      COMMON/MTRAD/ RS(NAT_)
C
      DIMENSION XV(NAT_),YV(NAT_),ZV(NAT_),Z(NAT_),NEQ1(NAT_),
     1EXFACT(NAT_),NZ(NAT_),NSYMBL(NAT_),NEQ(NAT_),H(NAT_),
     2VCONS(2),R(441,UA_),V(441,UA_),ICHG(10,UA_),KPLACE(NAT_),
     3KMAX(NAT_),VINT(UA_),CHARGE(UA_,2),ROCON(2),RHO(441,UA_)
C     4,VC(441,UA_)
C
      DIMENSION RTEMP(440),VTEMP(441,2),GAMMA(440,2),DENSTEMP(441,2)
      EQUIVALENCE (VTEMP(1,1),BETA(1)),(ROTEMP(1,1),GAMMA(1,1))
      DIMENSION BETA(440),ROTEMP(440,2)
C      DIMENSION VCTEMP(441)
C
C
CC**** CONT_SUB COMMON BLOCKS
C
      COMMON /DENS/ IRHO2,RHOTOT2(RD_,SD_),RHOINT2(2),
     $ vcoul(rd_,sd_),vcoulint(2)
      REAL*4 RHOTOT2,RHOINT2,vcoul,vcoulint
C
      COMMON /FCNR/KXE2, H2(D_),VCONS2(2),R2(RD_,D_),V2(2,RD_,SD_),
     $ ICHG2(10,D_),KPLACE2(AT_),KMAX2(AT_)
      REAL*4 H2,R2,V2
      COMPLEX VCONS2
C
      COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM,
     1 IMVHL,NEDHLP
C
      CHARACTER*8 NAME0 ,NSYMBL2
C
      REAL*4 EFTR2,GAMMA2,E2,RS2,XV2,YV2,ZV2
      REAL*4 EXFACT2,Z2,CIP,EMAX,EMIN,DE
      COMPLEX VCON2,XE2,EV2
      COMMON/PARAM/EFTR2,GAMMA2,VCON2,XE2,EV2,E2,IOUT2,NAT2,
     1 NDAT2,NSPINS2,NAS2,RS2(AT_),XV2(AT_),YV2(AT_),ZV2(AT_),
     2 EXFACT2(AT_),Z2(AT_),LMAXX2(AT_),NZ2(AT_),NSYMBL2(AT_),
     4 NEQ2(AT_),NAME0,CIP,EMAX,EMIN,DE
C
C     ############MODIFIED TO INCLUDE THE TWO CORE STATE WAVE FUNCTIONS
c     ############FOR THE AUGER CALCULATION
c
	common/pot_type/i_absorber,i_absorber_hole,
     1                   i_absorber_hole1,i_absorber_hole2,
     2                   i_norman,i_alpha,i_outer_sphere,
     3                   i_exc_pot,i_mode






C
C*****
C
C
      CHARACTER*8 NSYMBL
C
      DATA PI/3.14159265358979D0/,THIRD/.333333333333333D0/
C
C     FORMAT FOR ALL FUNCTIONS OF RADIAL MESH POINTS
C     FORMAT FOR ERROR MESSAGE IF INPUT CARD IS OUT OF ORDER
C
  400 FORMAT('   CARD',I5,'    OUT OF SEQUENCE')
      LOGICAL OUTER
      READ(4) NAT,NDAT,NOUT,EXFAC0,NSPINS
C     READ(10,8853)RADION,QION,NCUT,MOUT


      IF(NCUT.EQ.0) NCUT=2
C     READ(10,8854)(RS(I),I=1,NAT)
      IF (NAT.EQ.0) STOP 4602
      FAC1=NSPINS
      IF(NOUT.EQ.0) WRITE(7,110) NAT
      ROCON(2)=0
      ROCON(1)=0
      VCON=0.0D0
      IN = 0
C
C     IN=1 SECTION.  INPUT DATA FROM MOLECULAR POTENTIAL PROGRAM
C
      IF (IN.GT.1) GO TO 4300
      NC0=1
  113 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,26H  OUTER SPHERE AT CENTE
     *R 1   )
  110 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,17H  NO OUTER SPHERE)
      IF(NOUT.NE.0) WRITE(7,113)NAT
      WRITE(7,8852)NCUT,RADION,QION
8852  FORMAT(30X,'NCUT=',I3,' RADION=',F7.3,' QION=', F7.1)
      VOLUME=0.0D0
      DO 422 N=1,NAT
      OUTER=NOUT.NE.0.AND.N.EQ.1
      READ(4)       NSYMBL(N),NEQ(N),NZ(N),KMAX(N),XV(N),YV(N),
     U  ZV(N),EXFACT(N),NC
      IF(NC.EQ.NC0+1) GO TO 423
      WRITE(7,400) NC
  423 NC0=NC
      Z(N)=NZ(N)
      IF(NEQ(N).NE.0) GO TO 439
      KMAXN=KMAX(N)
      KMAXL=KMAXN
C
C     CALCULATE RADIAL MESH FOR INPUT DATA
C
       ZINO=Z(N)
       IF(NZ(N) .EQ. 0) ZINO=1.D0
      HH=.0025D0*.88534138D0/ZINO**THIRD
      RTEMP(1)=HH
      KK=1
      K0=2
      DO 4285 I=1,11
      DO 4286 K=K0,40
      KK=KK+1
      IF(KK.GT.KMAXN) GO TO 1014
 4286 RTEMP(KK)=RTEMP(KK-1)+HH
      K0=1
 4285 HH=2.0D0*HH
 1014 DO 1020 ISPIN=1,NSPINS
C
C     READ STARTING POTENTIAL
C
      DO 1019 K=1,KMAXN,5
      KCARD=MIN0(K+4,KMAXN)
      READ(4) NC,( VTEMP(I,ISPIN),I=K,KCARD)
      IF(NC.EQ.NC0+1) GO TO 1019
      WRITE(7,400) NC
 1019 NC0=NC
 1020 CONTINUE
C      DO 1200 K=1,KMAXN,5
C      KCARD=MIN0(K+4,KMAXN)
C      READ(4,1015) NC,( VCTEMP(I),I=K,KCARD)
C      IF(NC.EQ.NC0+1) GO TO 1200
C      WRITE(7,400) NC
C      ERROR=.TRUE.
C 1200 NC0=NC
      DO 2720 ISPIN=1,NSPINS
C
C     READ STARTING CH[AARGE DENSITY
C
      DO 2723 K=1,KMAXN,5
      KCARD=MIN0(K+4,KMAXN)
      READ(4) NC,(DENSTEMP(I,ISPIN),I=K,KCARD)
      IF(NC.EQ.NC0+1) GO TO 2723
      WRITE(7,400) NC
 2723 NC0=NC
 2720 CONTINUE
C
C     CONVERT INPUT DATA TO FORM FOR MOLECULAR CALCULATION
C
      KMIN=1
  428 KPL=(KMAXN+KMIN)/2
      IF(RTEMP(KPL)-RS(N)) 424,434,426
  424 KMIN=KPL
      IF(KMAXN-KMIN-1) 427,427,428
  426 KMAXN=KPL
      IF(KMAXN-KMIN-1) 427,427,428
  427 KPL=KMIN
  434 KPL0=KPL
      N40=40/NCUT
      KPL=KPL/NCUT
      IF(RTEMP(KPL*NCUT+NCUT)+RTEMP(KPL*NCUT)-2.D0*RS(N)) 429,430,430
  429 KPL=KPL+1
  430 IF(OUTER) GO TO 433
      KMAX(N)=KPL+3
      KMAXN=KMAX(N)
      NMOD=MOD(KMAXN,N40)
      IF(NMOD.GE.5.OR.NMOD.EQ.0) GO TO 431
      KMAXN=KMAXN-NMOD
  431 ICHGN=KMAXN
      DO 432 K=1,KMAXN
      KN=NCUT*K
      R(K,N)=RTEMP(KN)
      NS=N
      DO 4320 IS=1,NSPINS
      V(K,NS)=VTEMP(KN,IS)
C      VC(K,NS)=VCTEMP(KN)
      RHO(K,NS)=DENSTEMP(KN,IS)
 4320 NS=NS+NDAT
  432 CONTINUE
      IF(KMAXN.EQ.KMAX(N)) GO TO 441
      KX1=KMAXN+1
      KMAXN=KMAX(N)+1
      IF(NCUT.EQ.1) GO TO 435
      DO 436 K=KX1,KMAXN
      KN=(KX1+K-1)*NCUT/2
      R(K,N)=RTEMP(KN)
      NS=N
      DO 4360 IS=1,NSPINS
      V(K,NS)=VTEMP(KN,IS)
C      VC(K,NS)=VCTEMP(KN)
      RHO(K,NS)=DENSTEMP(KN,IS)
 4360 NS=NS+NDAT
  436 CONTINUE
      GO TO 440
  435 DO 437 K=KX1,KMAXN
      KN=(KX1+K-1)/2
      IF(2*((K-KX1+1)/2).EQ.(K-KX1+1)) GO TO 438
      R(K,N)=.5D0*(RTEMP(KN)+RTEMP(KN+1))
      NS=N
      DO 4310 IS=1,NSPINS
      CALL DINTERP(RTEMP(KN-3),VTEMP(KN-3 ,IS),7,R(K,N),V(K,NS),DUMMY,
     1  .FALSE.)
C      CALL DINTERP(RTEMP(KN-3),VCTEMP(KN-3 ),7,R(K,N),VC(K,NS),DUMMY,
C     1  .FALSE.)
      CALL DINTERP(RTEMP(KN-3),DENSTEMP(KN-3 ,IS),7,R(K,N),
     1  RHO(K,NS),DUMMY,.FALSE.)
 4310 NS=NS+NDAT
      GO TO 437
  438 R(K,N)=RTEMP(KN)
      NS=N
      DO 4311 IS=1,NSPINS
      V(K,NS)=VTEMP(KN,IS)
C      VC(K,NS)=VCTEMP(KN)
      RHO(K,NS)=DENSTEMP(KN,IS)
 4311 NS=NS+NDAT
  437 CONTINUE
  440 IF( ABS(R(KPL,N)-RS(N)).LE. ABS(R(KPL+1,N)-RS(N))) GO TO 441
      KPL=KPL+1
      KMAX(N)=KMAX(N)+1
  441 KPLACE(N)=KPL
      ICHG(1,N)=N40
      DO 443 K=2,10
      ICHG(K,N)=ICHG(K-1,N)+N40
      IF(ICHG(K,N).GE.ICHGN) ICHG(K,N)=400/NCUT
  443 CONTINUE
      GO TO 448
C
C.....FOR OUTER REGION
C
  433 KMIN=(KPL-3)*NCUT
      KMAX(N)=MIN0((440/NCUT-KPL+4),200)
      ICHG(1,N)=(40-MOD(KMIN,40))/NCUT+1
      ICHGN=1
      IF(ICHG(1,N).GT.4) GO TO 444
      ICHGN=ICHG(1,N)-1
      DO 445 K=1,ICHGN
      KN=KMIN+NCUT*(2*K-ICHG(1,N)-1)
      R(K,N)=RTEMP(KN)
      NS=N
      DO 445 IS=1,NSPINS
      V(K,NS)=VTEMP(KN,IS)
C      VC(K,NS)=VCTEMP(KN)
      RHO(K,NS)=DENSTEMP(KN,IS)
  445 NS=NS+NDAT
      ICHG(1,N)=ICHG(1,N)+N40
      ICHGN=ICHGN+1
  444 KMAXN=KMAX(N)
      DO 446 K=ICHGN,KMAXN
      KN=KMIN+(K-1)*NCUT
      R(K,N)=RTEMP(KN)
      NS=N
      DO 446 IS=1,NSPINS
      V(K,NS)=VTEMP(KN,IS)
C      VC(K,NS)=VCTEMP(KN)
      RHO(K,NS)=DENSTEMP(KN,IS)
  446 NS=NS+NDAT
      DO 447 K=2,10
  447 ICHG(K,N)=ICHG(K-1,N)+N40
      KPLACE(N)=4
C
C.....FOR ATOMIC SPHERES
C
  448 NQ=N
      K=KPL0
      IF(RTEMP(K+1)+RTEMP(K)-2.D0*RS(N).LT.0.0D0 ) K=KPL0+1
C
C     READ INTEGRATED POTENTIAL AND INTERPOLATE FOR VALUE ON BOUNDARY
C
      DO 1016 KK=1,KMAXL,5
      KCARD=MIN0(KK+4,KMAXL)
      READ(4)      NC,(BETA(I),I=KK,KCARD)
      IF(NC.EQ.NC0+1) GO TO 1016
      WRITE(7,400) NC
 1016 NC0=NC
      CALL DINTERP(RTEMP(K-3), BETA(K-3),7,RS(N), VINT(N),DUMMY,.FALSE.)
C
C     READ TOTAL CHARGE AND INTERPOLATE FOR VALUE ON BOUNDARY
C
      DO 1022 ISPIN=1,NSPINS
      DO 1021 KK=1,KMAXL,5
      KCARD=MIN0(KK+4,KMAXL)
      READ(4)      NC, (GAMMA(I,ISPIN),I=KK,KCARD)
      IF(NC.EQ.NC0+1) GO TO 1021
      WRITE(7,400) NC
 1021 NC0=NC
 1022 CALL DINTERP(RTEMP(K-3),GAMMA(K-3,ISPIN),7,RS(N),CHARGE(N,ISPIN),
     1  DUMMY,.FALSE.)
      GO TO 4281
C
C.....FOR EQUIVALENT ATOMS
C
  439 NQ=NEQ(N)
      KPLACE(N)=KPLACE(NQ)
 4281 IF(OUTER) GO TO 4280
      VOLUME=VOLUME-RS(N)**3
      VCON=VCON-VINT(NQ)
      DO 455 IS=1,NSPINS
  455 ROCON(IS)=ROCON(IS)-CHARGE(NQ,IS)
      IF(NEQ(N).NE.0) GO TO 422
      GO TO 4221
 4280 VCON=VCON+VINT(NQ)
      VOLUME=VOLUME+RS(N)**3
      DO 456 IS=1,NSPINS
  456 ROCON(IS)=ROCON(IS)+CHARGE(NQ,IS)
 4221 H(N)=R(2,N)-R(1,N)
  422 CONTINUE
      VOLUME=1.3333333333333D0*PI*VOLUME
      VCON=VCON/VOLUME
      VCONC=VCON
      IF (RADION.NE.0)  THEN
         DVSPH = -2.D0*QION/RADION
         VCONC = VCONC + DVSPH
      ENDIF
      NS=1
      RH0 = 3.D0 / (NSPINS*4.D0*PI*RS0**3)
c      write (*,*) ' vc0 =', vc0, ' rs0 =',rs0
      DO 453 IS=1,NSPINS
      ROCON(IS)=ROCON(IS)/VOLUME
      VCONS(IS)=VCON-6*EXFAC0*(3*FAC1*ROCON(IS)/(8*PI))**THIRD
      VC0X = VC0 - 6*EXFAC0*(3*FAC1*RH0/(8*PI))**THIRD
      IF(RADION.EQ.0) GO TO 453
      VCONS(IS)=VCONS(IS)+DVSPH
      KX=KMAX(1)
      DO 451 K=1,KX
      IF(R(K,1).LT.RADION) GO TO 452
      V(K,NS)=V(K,NS)-2.D0*QION/R(K,1)
C      VC(K,NS)=VC(K,NS)-2.*QION/R(K,1)
      GO TO 451
  452 V(K,NS)=V(K,NS)+DVSPH
C      VC(K,NS)=VC(K,NS)+DVSPH
  451 CONTINUE
      NS=NS+1
      DO 454 N=2,NDAT
      KX=KMAX(N)
      DO 450 K=1,KX
C      VC(K,NS)=VC(K,NS)+DVSPH
  450 V(K,NS)=V(K,NS)+DVSPH
  454 NS=NS+1
  453 CONTINUE
      GO TO 4220
 4300 WRITE(7,105)
 105  FORMAT(' IN IS EQUAL 2')
C
C     OUTPUT AND CHECK FOR CONSISTENCY OF INPUT DATA
C
 4220 WRITE(7,111)
  111 FORMAT(30X,10HATOM   NO.,12X,8HPOSITION,14X,13HRADIUS     EQ  )
      WRITE(7,112) (I,NSYMBL(I),NZ(I),XV(I),YV(I),ZV(I),RS(I),NEQ(I),
     1   I=1,NAT)
  112 FORMAT(26X,I3,A6,I6,4F10.4,I6)
C     IF(NOUT.NE.0.AND.NOUT.NE.1) GO TO 205
C     GO TO 1130
C 205 WRITE(7,200) I,J
C     ERROR=.TRUE.
      DO 211 I=1,NAT
      IF(RS(I).LT.0.0D0) GO TO 213
      IF(NEQ(I).EQ.0)GO TO 210
      IF(NEQ(I).GE.I) GO TO 213
  210 I1=I+1
      IF(NOUT.EQ.0) GO TO 212
      IF(NEQ(I).EQ.1) GO TO 213
  212 IF(I1.GT.NAT) GO TO 216
      GO TO 2135
  213 CONTINUE
C     WRITE(6,200) I,J
 2135 DO 211 J=I1,NAT
      RIJ = SQRT((XV(J)-XV(I))**2+(YV(J)-YV(I))**2+(ZV(J)-ZV(I))**2)
      IF(NOUT.EQ.1.AND.I.EQ.1) GO TO 214
      RSUM = RS(I)+RS(J)
      IF (RSUM.GT.RIJ) GO TO 215
      GO TO 211
  214 RSUM = RIJ+RS(J)
      IF (RSUM.GT.RS(1)) GO TO 215
      GO TO 211
  215 CONTINUE
C     WRITE (6,200) I,J,RSUM,RIJ,RDIF
  211 CONTINUE
  216 IF(RADION.EQ.0.0D0) GO TO 217
      IF(RADION.EQ.RS(1)) GO TO 217
      KX=KMAX(1)
      DO 219 K=1,KX
      IF(RADION.GT.R(K,1)) GO TO 219
  219 CONTINUE
  217 CONTINUE
      NDUMMY = 0
C
C SHIFT BACK ORIGIN TO PHOTOABSORBER
C
         X0=XV(2)
         Y0=YV(2)
         Z0=ZV(2)
C
         DO 150 N=1,NAT
         XV(N)=XV(N)-X0
         YV(N)=YV(N)-Y0
         ZV(N)=ZV(N)-Z0
         NEQ1(N)=0
         IF(NEQ(N).NE.0) NEQ1(N)=NEQ(N)-1
  150    CONTINUE
C
C WRITE OUT POTENTIAL AND DENSITY FILES
C
      IF (potype.EQ.'xalph') THEN
	      OPEN (19, FILE = 'div/XALPHA.POT', STATUS = 'unknown')
      ELSE
	      OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown')
	      OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown')
      ENDIF
C
      INV = 20
      IF (potype.EQ.'xalph') INV = 19
      INRHO= 9
      NST=2
      NC=2
      DO 4401 N=NST,NAT
      WRITE(INV,311) NSYMBL(N),NEQ1(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N),
     1               XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC
  311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5)
      NC=NC+1
      IF(NEQ(N).NE.0) GO TO 4401
      WRITE(INV,308) (ICHG(I,N),I= 1,10),NC
  308 FORMAT(10I5,T76,I5)
      NC=NC+1
      WRITE(INV,319) NC,(R(I,N),I=1,5)
  319 FORMAT(T76,I5,T2,1P5E14.7)
      NS=N
      NC=NC+1
      KX=KMAX(N)
      NS = N
      DO 142 ISPIN=1,NSPINS
      DO 141 K=1,KX,5
      KCARD=MIN0(KX,K+4)
      WRITE(INV,319) NC,(V(I,NS),I=K,KCARD)
  141 NC=NC+1
  142 NS=NS+NDAT
      NS=N
      IF (potype.NE.'xalph') THEN
         DO 555 ISPIN=1,NSPINS
	 DO 551 K=1,KX,5
	 KCARD=MIN0(KX,K+4)
	 WRITE(INRHO,319) NC,(RHO(I,NS),I=K,KCARD)
  551    NC=NC+1
  555    NS=NS+NDAT
      ENDIF
 4401 CONTINUE
C
      IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS)
C
      IF (INV.EQ.20) THEN
         WRITE(INV,319) NC, VCONC

         WRITE( INRHO,319) NC,(ROCON(IS),IS=1,NSPINS)
      ENDIF
C
c     CLOSE (4)
      IF(potype.EQ.'xalph') THEN
	      CLOSE (UNIT=19)
      ELSE
	      CLOSE (UNIT=20)
	      CLOSE (UNIT=9)
      ENDIF
C
C      CLOSE (UNIT=7)
C
C-----------------------------------------------------------------------
C
C     PASS POTENTIAL AND/OR CHARGE DENSITY TO CONT_SUB.
C
C990    IF(IOUT_ASCII.NE.2) GO TO 999
C
C-----------------------------------------------------------------------
       NAT2=NAT-NOUT
       NDAT2=NDAT-NOUT
       NSPINS2=NSPINS
c
c A.Kuzmin 10.06.93
c Correction of the atomic coordinates due to the outer
c sphere non central position
c
       xv0=0.D0
       yv0=0.D0
       zv0=0.D0
c       if(nout.eq.1)then
c         xv0=xv(1)
c         yv0=yv(1)
c         zv0=zv(1)
c       endif
c
c  End of correction
c
       DO 780 I=1,NAT2
C
C       SKIP OUTER SPHERE
C
	  J=I+NOUT
	  NSYMBL2(I)=NSYMBL(J)
	  NZ2(I)=NZ(J)


	  IF(NEQ(J).EQ.0)THEN
	      NEQ2(I)=0
	  ELSE
	      NEQ2(I)=NEQ(J)-NOUT
	  END IF
	  XV2(I)=SNGL(XV(J)-xv0)
	  YV2(I)=SNGL(YV(J)-yv0)
	  ZV2(I)=SNGL(ZV(J)-zv0)
	  Z2(I)=SNGL(Z(J))
	  RS2(I)=SNGL(RS(J))
	  EXFACT2(I)=SNGL(EXFACT(J))
          KMAX2(I)=KMAX(J)
	  KPLACE2(I)=KPLACE(J)
	  IF(NEQ(J).NE.0)GOTO 780
	  DO 735 K=1,10
	      ICHG2(K,I)=ICHG(K,J)
735       CONTINUE
	  H2(I)=SNGL(R(2,J)-R(1,J))
	  ISDA=I
	  JSDA=J
	  DO 745 IS=1,NSPINS
	       DO 740 K=1,KMAX(J)
		 IF(IS.EQ.1)R2(K,ISDA)=SNGL(R(K,JSDA))
		 RHOTOT2(K,ISDA)=SNGL(RHO(K,JSDA))
		 V2(1,K,ISDA)=SNGL(V(K,JSDA))
		 V2(2,K,ISDA)=0.0
740           CONTINUE
	      ISDA=ISDA+NDAT2
	      JSDA=JSDA+NDAT
745       CONTINUE
780    CONTINUE
C
       RHKM1 = DBLE(RHOTOT2(KMAX2(1),1))/
     1              (4.D0*PI*DBLE(R2(KMAX2(1),1))**2)
       RHKM2 = DBLE(RHOTOT2(KMAX2(2),2))/
     1              (4.D0*PI*DBLE(R2(KMAX2(2),2))**2)
       RHKM = ( RHKM1 + RHKM2 ) / 2.D0
       RSKM = (3.D0 / ( 4.D0 * PI * RHKM * NSPINS ) ) ** THIRD
       VCKM = DBLE((V2(1,KMAX2(1),1)+V2(1,KMAX2(2),2)))/2.D0

       WRITE(*,*) ' input value for coulomb interst. potential =',
     1             real(vc0)
       WRITE(*,*) ' and interstitial rs =', real(rs0)
       WRITE(*,*) ' lower bound for coulomb interst. potential =',
     1            real(vckm)
       WRITE(*,*) ' and for interst. rs =',real(rskm)

       DO 790 M=1,NSPINS
           IF (VINPUT) THEN
              VCONS2(M) = CMPLX(VC0X)
              RHOINT2(M) = REAL(RH0)
           ELSE
              VCONS2(M)=CMPLX(SNGL(VCONS(M)))
              RHOINT2(M)=SNGL(ROCON(M))
           ENDIF
 790   CONTINUE
C
C
C BRANCH POINT
C
      RETURN
      END
C
      SUBROUTINE DINTERP(R,P,N,RS,PS,DPS,DERIV)
      IMPLICIT REAL*8 (A-H,O-Z)
      LOGICAL DERIV,NODRIV
      DIMENSION R(N),P(N)
      NODRIV=.NOT.DERIV
      DPS=0.0D0
      PS=0.0D0
      DO 1 J=1,N
      TERM=1.0D0
      DENOM=1.0D0
      DTERM=0.0D0
      DO 2 I=1,N
      IF(I.EQ.J) GO TO 2
      DENOM=DENOM*(R(J)-R(I))
      TERM=TERM*(RS-R(I))
      IF(NODRIV) GO TO 2
      DTERM1=1.0D0
      DO 3 K=1,N
      IF(K.EQ.J.OR.K.EQ.I) GO TO 3
      DTERM1=DTERM1*(RS-R(K))
    3 CONTINUE
      DTERM=DTERM+DTERM1
    2 CONTINUE
      IF(NODRIV) GO TO 1
      DPS=DPS+DTERM*P(J)/DENOM
    1 PS=PS+TERM*P(J)/DENOM
      RETURN
      END
c-----------------------------------------------------------------------
C
      SUBROUTINE CSBF(X0,Y0,MAX,SBF,DSBF)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 XF1
      COMPLEX*8  X0,Y0
      COMPLEX*16 X,Y,RAT,DSBF1,Z,SBFJ,B,A
      COMPLEX*16 SBFK,SBF1,SBF2
      COMPLEX*16 SBF,DSBF
      INTEGER MAX,K,JMIN,KMAX
      DIMENSION SBF(MAX), DSBF(MAX)
C
C
C     GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR
C     FIRST DERIVATIVES WITH RESPECT TO R.  X=ARGUMENT= Y*R.
C     IF Y=0, NO DERIVATIVES ARE CALCULATED.  MAX MUST BE AT LEAST 3.
C     OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS.  MSBF - MODI-
C     FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS;
C     MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS
C
C
C
      X=DCMPLX(X0)
      Y=DCMPLX(Y0)

      IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99
      IF(ABS(X).LT.0.50D0 ) GO TO 18
C
C     BESSEL FUNCTIONS BY DOWNWARD RECURSION
C
      SBF2=(0.0D0,0.0D0)
      SBF1=1.0D-25*(0.5D0,0.5D0)
      IF(ABS(X).LT.2.0D0) SBF1=1.0D-38*(0.5D0,0.5D0)
      JMIN=10+INT(ABS(X))
      KMAX=MAX+JMIN-1
      K=MAX
      XF1=2*KMAX+1
      DO  10  J=1,KMAX
      SBFK=XF1*SBF1/X-SBF2
      SBF2=SBF1
      SBF1=SBFK
      XF1=XF1-2.0D0
      IF (J.LT.JMIN) GO TO 10
      SBF(K)=SBFK
      K=K-1
10    CONTINUE
      RAT=SIN(X)/(X*SBF(1))
      DO 17 K=1,MAX
   17 SBF(K)=RAT*SBF(K)
      DSBF1=-SBF(2)
      GO TO 26
C
C     SMALL ARGUMENTS
C
   18 Z=-(X*X*0.50D0)
      A=(1.0D0,0.0D0)
      MMX=MAX
      IF (MAX.EQ.1.AND.Y.NE.(0.0D0,0.0D0)) MMX=2
      DO  30  J=1,MMX
      SBFJ=A
      B=A
      DO 31 I=1,20
      B=B*Z/(I*(2*(J+I)-1))
      SBFJ=SBFJ+B
      IF (ABS(B).LE.1.0D-07*ABS(SBFJ)) GO TO 29
   31 CONTINUE
29    IF (J.EQ.2) DSBF1=-SBFJ
      IF (J.LE.MAX) SBF(J)=SBFJ
   30 A=A*X/DCMPLX(FLOAT(2*J+1))
C
C
26    IF (Y.EQ.(0.0D0,0.0D0))  RETURN
      DSBF(1)=Y*DSBF1
      IF (MAX.EQ.1)  RETURN
      DO 9 I=2,MAX
    9 DSBF(I)=Y*(SBF(I-1)- DCMPLX(FLOAT(I))*SBF(I)/X)
      RETURN
99    WRITE(6,100) MAX
100   FORMAT ('       SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8)
      STOP
      END
C
c
      subroutine cshf2(x0,y0,max,sbf,dsbf)
      implicit real*8(a-h,o-z)
      real*8 xf1
      complex*8  x0,y0
      complex*16 x,y,rat,z,sbfj,b,a
      complex*16 sbfk,sbf1,sbf2,cplu
      complex*16 sbf,dsbf
      integer max,k,jmin,kmax
      dimension sbf(max), dsbf(max)
c
c     cshf2 - May 1992
c     generates spherical hankel functions of type 2 of order 0 - max-1.
c     max must be at least 3. cshf2 is calculated as csbf - i*csnf, wher
c     csbf(csnf) are spherical Bessel(Neuman) functions. csbf(csnf) are
c     calculated using downward(upward) recurrence realations.
c     ***** This subroutine returns i*cshf2 = csnf + i*csbf and its
c           derivative if y0 ne. 0. In this case dsbf = i*y0*(cshf")'***
c
c
      cplu = (0.d0,1.d0)
c
      x=dcmplx(x0)
      y=dcmplx(y0)

      if (max.lt.1.or.max.gt.2000) go to 99
      if(abs(x).lt.0.50D0 ) go to 18
c
c     bessel functions sbf by downward recursion
c
      sbf2=(0.0D0,0.0D0)
      sbf1=1.0D-25*(0.5D0,0.5D0)
      if(abs(x).lt.2.0D0) sbf1=1.0d-38*(0.5D0,0.5D0)
      jmin=10+int(abs(x))
      kmax=max+jmin-1
      k=max
      xf1=2*kmax+1
      do  10  j=1,kmax
      sbfk=xf1*sbf1/x-sbf2
      sbf2=sbf1
      sbf1=sbfk
      xf1=xf1-2.0d0
      if (j.lt.jmin) go to 10
      sbf(k)=sbfk
      k=k-1
10    continue
      rat=sin(x)/(x*sbf(1))
      do 17 k=1,max
   17 sbf(k)=rat*sbf(k)
      go to 2
c
c     sbf for small arguments
c
   18 z=-(x*x*0.50D0)
      a=(1.0D0,0.0D0)
      mmx=max
      if (max.eq.1.and.y.ne.(0.0D0,0.0D0)) mmx=2
      do  30  j=1,mmx
      sbfj=a
      b=a
      do 31 i=1,20
      b=b*z/(i*(2*(j+i)-1))
      sbfj=sbfj+b
      if (abs(b).le.1.0d-07*abs(sbfj)) go to 29
   31 continue
   29 if (j.le.max) sbf(j)=sbfj
   30 a=a*x/ dcmplx(float(2*j+1))
c
c     spherical neumann functions snf by upward recursion
c     damped in dsbf
c
   2  sbf2=-cos(x)/x
      sbf1=(sbf2-sin(x))/x
      dsbf(1)=sbf2
      if (max.eq.1) go to 26
      dsbf(2)=sbf1
      if (max.eq.2) go to 26
      xf1=3.0d0
      do  22  i=3,max
      sbfk=xf1*sbf1/x-sbf2
      dsbf(i)=sbfk
      sbf2=sbf1
      sbf1=sbfk
22    xf1=xf1+2.0d0
c
c     hankel functions as sbf + i*snf
c
      do 3 i=1,max
    3 sbf(i) = cplu*sbf(i) + dsbf(i)

26    if (y.eq.(0.0D0,0.0D0))  return
c
c     calculate derivative of shf
c
      dsbf(1) = -y*sbf(2)
      if (max.eq.1)  return
      do 9 i=2,max
    9 dsbf(i)=y*(sbf(i-1)- dcmplx(float(i))*sbf(i)/x)
      return
99    write(6,100) max
100   format ('       spherical bessel function routine - max=',i8)
      stop
      end
c
      SUBROUTINE DEFINT(F,R,KMAX,ICHG,A,ID)
      DIMENSION F(KMAX),R(KMAX),ICHG(10)
      COMPLEX F,A,F0
C
      DATA S720,S251,S646,S264 /720.,251.,646.,264./
C
      DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/
C
      H=R(2)-R(1)
      A0=0.0
      K0=0
      IF (ID.NE.1) GO TO 11
      F0=(0.0,0.0)
      GO TO 12
   11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5)
12    KX=KMAX
      N=1
      A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*
     1  F(K0+4))/S720
      A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11*
     1  F(K0+4))/S720
      A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19*
     1  F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      KICH=K-ICHG(N)
      IF (KICH.EQ.1)  GO TO  30
      IF (KICH.EQ.2)  GO TO  40
      A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+    F(K-3))/24.0
      GO TO 50
30    H=H+H
      A=A+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+    F(K-3))/ 6.0
      GO TO 50
40    N=N+1
      A=A+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0
50    CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE defint0(F,DX,KMAX,A,ID)
      COMPLEX F, A, A0, F0
      DIMENSION F(KMAX)
C
      DATA S720,S251,S646,S264 /720.,251.,646.,264./
C
      DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/
C
      H=DX
      A0=0.0
      K0=0
      IF (ID.NE.1) GO TO 11
      F0=(0.0,0.0)
      GO TO 12
   11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5)
c   11 F0 = F(1)
c      K0 = 1
c      write(6,*) 'defint', f0
12    KX=KMAX
      N=1
      A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*
     1        F(K0+4))/S720
      A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11*
     1        F(K0+4))/S720
      A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19*
     1        F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+    F(K-3))/24.0
50    CONTINUE
      RETURN
C
      END
C
C
      SUBROUTINE defint1(F,DX,KMAX,A,ID)
      COMPLEX F, A, A0, F0
      DIMENSION F(KMAX)
C
      DATA S720,S251,S646,S264 /720.,251.,646.,264./
C
      DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/
C
      H=DX
      A0=0.0
      K0=0
      IF (ID.NE.1) GO TO 11
      F0=(0.0,0.0)
      GO TO 12
c   11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5)
   11 F0 = F(1)
      K0 = 1
12    KX=KMAX
      N=1
      A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*
     1        F(K0+4))/S720
      A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11*
     1        F(K0+4))/S720
      A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19*
     1        F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+    F(K-3))/24.0
50    CONTINUE
      RETURN
C
      END
C
C
      SUBROUTINE INTEGR(F,R,KMAX,ICHG,A,ID)
      DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX)
C
      DATA S720,S251,S646,S264 /720.,251.,646.,264./
C
      DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/
C
      H=R(2)-R(1)
      A0=0.0
      IF (ID.NE.1) GO TO 11
      K0=0
      F0=0.0
      GO TO 12
   11 K0=1
      A(1)=0.0
      F0=F(1)
12    KX=KMAX
      N=1
      A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F
     1  (K0+4))/S720
      A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S
     1  11*F(K0+4))/S720
      A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1
     1  9*F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      KICH=K-ICHG(N)
      IF (KICH.EQ.1)  GO TO  30
      IF (KICH.EQ.2)  GO TO  40
      A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+    F(K-3))/24.0
      GO TO 50
30    H=H+H
      A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+    F(K-3))/ 6.0
      GO TO 50
40    N=N+1
      A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0
50    CONTINUE
      IF (MOD(ID,2).NE.0)  RETURN
      DO  150  K=1,KMAX
150   A(K)=A(KMAX)-A(K)
      RETURN
C                                                                    #
      END
C
      SUBROUTINE CINTEGR(F,R,KMAX,ICHG,A,ID)
      COMPLEX F,A,F0
      DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX)
C
      DATA S720,S251,S646,S264 /720.,251.,646.,264./
C
      DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/
C
      H=R(2)-R(1)
      A0=0.0
      IF (ID.NE.1) GO TO 11
      K0=0
      F0=(0.0,0.0)
      GO TO 12
   11 K0=1
      A(1)=(0.0,0.0)
      F0=F(1)
12    KX=KMAX
      N=1
      A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F
     1  (K0+4))/S720
      A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S
     1  11*F(K0+4))/S720
      A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1
     1  9*F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      KICH=K-ICHG(N)
      IF (KICH.EQ.1)  GO TO  30
      IF (KICH.EQ.2)  GO TO  40
      A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+    F(K-3))/24.0
      GO TO 50
30    H=H+H
      A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+    F(K-3))/ 6.0
      GO TO 50
40    N=N+1
      A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0
50    CONTINUE
      IF (MOD(ID,2).NE.0)  RETURN
      DO  150  K=1,KMAX
150   A(K)=A(KMAX)-A(K)
      RETURN
C                                                                    #
      END
C
C
      SUBROUTINE INTEGRCM(F,DX,KMAX,A,ID)
      COMPLEX F,A,F0
      DIMENSION F(KMAX),A(KMAX)
C
      DATA S720,S251,S646,S264 /720.,251.,646.,264./
C
      DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/
C
      H=DX
      A0=0.0
      IF (ID.NE.1) GO TO 11
      K0=0
      F0=(0.0,0.0)
      GO TO 12
   11 K0=1
      A(1)=(0.0,0.0)
      F0=F(1)
12    KX=KMAX
      A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F
     1  (K0+4))/S720
      A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S
     1  11*F(K0+4))/S720
      A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1
     1  9*F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+    F(K-3))/24.0
50    CONTINUE
      IF (MOD(ID,2).NE.0)  RETURN
      DO  150  K=1,KMAX
150   A(K)=A(KMAX)-A(K)
      RETURN
C                                                                    #
      END
C
C
      SUBROUTINE INTEGRCMDP(F,DX,KMAX,A,ID)
      COMPLEX*16 F,A,F0
      REAL*8 S106,S19,S346,S456,S74,S11,S720,S251,S646,S264,A0
      DIMENSION F(KMAX),A(KMAX)
C
      DATA S720,S251,S646,S264        /720.D0,251.D0,646.,264.D0/
C
      DATA S106,S19,S346,S456,S74,S11 /106.0D0,19.0D0,346.0D0,456.0D0,
     1                                 74.0D0,11.0D0/
C
      H=DX
      A0=0.0D0
      IF (ID.NE.1) GO TO 11
      K0=0
      F0=(0.0D0,0.0D0)
      GO TO 12
   11 K0=1
      A(1)=(0.0D0,0.0D0)
      F0=F(1)
12    KX=KMAX
      A(K0+1)=A0+DBLE(H)*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+
     1                    S106*F(K0+3)-S19*F(K0+4))/S720
      A(K0+2)=A(K0+1)+DBLE(H)*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-
     1                          S74*F(K0+3)+S11*F(K0+4))/S720
      A(K0+3)=A(K0+2)+DBLE(H)*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+
     1                         S346*F(K0+3)-S19*F(K0+4))/S720
      K0=K0+4
      DO  50  K=K0,KX
      A(K)=A(K-1)+DBLE(H)*( 9.0D0*F(K)+19.0D0*F(K-1)-5.0D0*F(K-2)+
     1            F(K-3))/24.0D0
50    CONTINUE
      IF (MOD(ID,2).NE.0)  RETURN
      DO  150  K=1,KMAX
150   A(K)=A(KMAX)-A(K)
      RETURN
C                                                                    #
      END
C
C
      SUBROUTINE INTERP(R,P,N,RS,PS,DPS,DERIV)
      LOGICAL DERIV,NODRIV
      DIMENSION R(N),P(N)
      COMPLEX P,PS,DPS
      NODRIV=.NOT.DERIV
      DPS=(0.0,0.0)
      PS=(0.0,0.0)
      DO 1 J=1,N
      TERM=1.0
      DENOM=1.0
      DTERM=0.0
      DO 2 I=1,N
      IF(I.EQ.J) GO TO 2
      DENOM=DENOM*(R(J)-R(I))
      TERM=TERM*(RS-R(I))
      IF(NODRIV) GO TO 2
      DTERM1=1.0
      DO 3 K=1,N
      IF(K.EQ.J.OR.K.EQ.I) GO TO 3
      DTERM1=DTERM1*(RS-R(K))
    3 CONTINUE
      DTERM=DTERM+DTERM1
    2 CONTINUE
      IF(NODRIV) GO TO 1
      DPS=DPS+DTERM*P(J)/DENOM
    1 PS=PS+TERM *P(J)/DENOM
      RETURN
C
      END
C
      SUBROUTINE INTERPR(R,P,N,RS,PS,DPS,DERIV)
      LOGICAL DERIV,NODRIV
      DIMENSION R(N),P(N)
      NODRIV=.NOT.DERIV
      DPS=0.0
      PS=0.0
      DO 1 J=1,N
      TERM=1.0
      DENOM=1.0
      DTERM=0.0
      DO 2 I=1,N
      IF(I.EQ.J) GO TO 2
      DENOM=DENOM*(R(J)-R(I))
      TERM=TERM*(RS-R(I))
      IF(NODRIV) GO TO 2
      DTERM1=1.0
      DO 3 K=1,N
      IF(K.EQ.J.OR.K.EQ.I) GO TO 3
      DTERM1=DTERM1*(RS-R(K))
    3 CONTINUE
      DTERM=DTERM+DTERM1
    2 CONTINUE
      IF(NODRIV) GO TO 1
      DPS=DPS+DTERM*P(J)/DENOM
    1 PS=PS+TERM *P(J)/DENOM
      RETURN
C
      END
C
C
C
      SUBROUTINE SORT(NINI,VALIN,NFIN,VALFIN)
C
C  Given a set of **real** numbers VALINI, this routine orders them and
C       suppresses the values appearing more than once. The remaining
C       values are stored in VALFIN.
C
C       VALINI(K+1).GT.VALINI(K) : decreasing order
C       VALINI(K+1).LT.VALINI(K) : increasing order
C
C
      DIMENSION VALIN(NINI),VALINI(NINI),VALFIN(NINI)
C
      LOGICAL BUBBLE
C
      DATA SMALL /0.00001/
C
C.....STORE INPUT ARRAY
C
      DO I=1,NINI
	VALINI(I)=VALIN(I)
      ENDDO
C
      DO J=1,NINI-1
         K=J
         BUBBLE=.TRUE.
150      IF(K.GE.1.AND.BUBBLE) THEN
            IF(VALINI(K+1).LT.VALINI(K)) THEN
              R1=VALINI(K)
              VALINI(K)=VALINI(K+1)
              VALINI(K+1)=R1
           ELSE
             BUBBLE=.FALSE.
           END IF
           K=K-1
           GOTO 150
         ENDIF
      ENDDO
C
      JFIN=1
      VALFIN(1)=VALINI(1)
      DO J=1,NINI-1
        IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN
          JFIN=JFIN+1
          VALFIN(JFIN)=VALINI(J+1)
        ENDIF
      ENDDO
      NFIN=JFIN
C
      RETURN
C
      END
C
C
      SUBROUTINE STARTP(ZZ0,L,E,R,V,KMAX,KI,P)
C
      IMPLICIT COMPLEX*16 (A-B)
      REAL*4 ZZ0,R
      REAL*8 XL,Z0,H,RC
C
      COMPLEX*8 V
      COMPLEX*16 P,Z
C
      DIMENSION R(KMAX),V(KMAX),Z(300),P(KMAX)
C    1,ZA(150)
C
      Z0=DBLE(ZZ0)
      RC = 1.0D0
C      IF(L.GT.10) RC = 0.01/R(1)
      KM=KI/4
      IF(KI.EQ.1) KM=1
      KI1=KI+2
      DO 1 K=1,KI1
    1 Z(K)=DCMPLX(R(K)*V(K))
      XL=DFLOAT(L)
      H=DBLE(KM*R(1))
      B1=-2.0D0*Z0
      B2=(22.D0*Z0+18.D0*Z(KM)-9.D0*Z(2*KM)+2.D0*Z(3*KM))/(6.D0*H)-
     1    DBLE(E)
      B3=(-12.D0*Z0-15.D0*Z(KM)+12.D0*Z(2*KM)-3.D0*Z(3*KM))/(6.D0*H*H)
      B4=(2.D0*Z0+3.D0*Z(KM)-3.D0*Z(2*KM)+Z(3*KM))/(6.D0*H**3)
      A1=-Z0/(XL+1.0D0)
      A2=(B1*A1+B2)/(4.0D0*XL+6.0D0)
      A3=(B1*A2+B2*A1+B3)/(6.0D0*XL+12.0D0)
      A4=(B1*A3+B2*A2+B3*A1+B4)/(8.0D0*XL+20.0D0)
      A5=(B1*A4+B2*A3+B3*A2+B4*A1)/(10.D0*XL+30.D0)
      A6=(B1*A5+B2*A4+B3*A3+B4*A2)/(12.D0*XL+42.D0)
      A7=(B1*A6+B2*A5+B3*A4+B4*A3)/(14.D0*XL+56.D0)
      DO 4 K=1,KI1
    4 P(K)=DCMPLX((1.0D0+DBLE(R(K))*(A1+DBLE(R(K))*(A2+DBLE(R(K))*
     1            (A3+DBLE(R(K))*(A4+DBLE(R(K))*(A5+DBLE(R(K))*
     2            (A6+DBLE(R(K))*A7)))))))*(DBLE(R(K))*RC)**(L+1))
C     DO 2 K=1,KI1
C   2 ZA(K)=B1+R(K)*(B2+(R(K)*(B3+R(K)*B4)))
C     WRITE(6,3) (I,(R(I+J-1),Z(I+J-1),ZA(I+J-1),J=1,2),I=1,KI1,2)
      RETURN
      END
C
      subroutine rhl(erl,eim,pi)
c
c
c       this is a new hl subroutine, using interpolation for the
c       real part while calculating  the imaginary part is calculated
c       analitically.
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
      implicit double precision (a-h,o-z)
      common /corr/ rs,blt,xk1,vii,index2
      common /hlin/ xk
      common /cusp/ icusp
c
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
c
      parameter (lrs=4,nrs=3,nleft=4,nright=2)
      dimension rcfl(lrs,nrs,nleft),rcfr(lrs,nrs,nright)
      dimension cleft(nleft),cright(nright)
      data conv /1.9191583/
      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         calcualte hl using interplation coefficients
c
      rkf=conv/rs
      ef=rkf*rkf*0.5D0
      wp=sqrt(3.0D0/rs**3)
      call imhl (erl,eim,pi)
      eim=eim
c
c  eim already has a factor of ef in it j.m.
c eim also gives the position of the cusp
c
      xx=xk1/rkf
c
c       calculate right hand side coefficients
c
      if (rs .lt. 0.2D0) then
      mrs=1
      go to 209
      endif
      if (rs .ge. 0.2D0 .and. rs .lt. 1.0D0) then
      mrs=2
      go to 209
      endif
      if (rs .ge. 1.0D0 .and. rs .lt. 5.0D0) then
      mrs=3
      go to 209
      endif
      if (rs .ge. 5.0D0) mrs=4
  209 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*rs
c
c     jm written this way to calculate powers of rs quicker.
c      cright(j)=0.0
c      do 205 k=1,nrs
c  205 cright(j)=cright(j)+rcfr(mrs,k,j)*rs**((k+1.)/2.)
  210 continue
      eee=-pi*wp/(4.0D0*rkf*ef)
c
       if (icusp .ne. 1) then
	do 230 j=1,nleft
	   cleft(j)=rcfl(mrs,1,j)*rs+rcfl(mrs,2,j)*rs*sqrt(rs)
     1     +rcfl(mrs,3,j)*rs*rs
c          cleft(j)=0.0
c          do 225 k=1,nrs
c  225     cleft(j)=cleft(j)+rcfl(mrs,k,j)*rs**((k+1.)/2.)
  230   continue
c
	erl=cleft(1)
	do 250 j=2,nleft
  250   erl=erl+cleft(j)*xx**(j-1)
c
      else
c
c         right branch
c
	erl=eee/xx
	do 280 j=1,nright
  280   erl=erl+cright(j)/xx**(j+1)
      endif
c
      erl=erl*ef
      return
      end
c
c
c
      subroutine imhl(erl,eim,pi)
C
c**********************************************************************
c**********************************************************************
C
c writen by j. mustre march 1988 based on analytical expression derived
c by john rehr.
c it leaves the real part unchanged.
C
c**********************************************************************
c**********************************************************************
      implicit double precision (a-h,o-z)
      common /corr/rs,blt,xk1,vii,index2
      common/hlin/xk
      common /cusp/ icusp
      common/inter/wp,alph,ef,xf
      common/cube/a0,a1,a2
      external ffq
      icusp=0
      fa=1.9191583D0
      xf=fa/rs
      ef=xf*xf/2.0D0
      xk=xk1
      xk=xk/xf
c
c wp is given in units of the fermi energy in the formula below.
c
      wp=sqrt(3.0D0/(rs*rs*rs))/ef
      alph=4.0D0/3.0D0
c      write(*,225)
c 225  format(1x'xk,wp')
c      write(*,*)xk,wp
      xs=wp*wp-(xk*xk-1.0D0)**2
c      write (*,*)xs
      if (xs .ge. 0.D0) go to 10
      q2=sqrt((sqrt(alph*alph-4.0D0*xs)-alph)/2.0D0)
      qu=min(q2,(1.0D0+xk))
      d1=qu-(xk-1.0D0)
      if(d1.gt.0.D0) goto 11
  10  eim=0.0D0
      go to 20
  11  eim=ffq(qu)-ffq((xk-1.0D0))

c      write(*,223)
c 223  format(1x'xk,eim,d1')
c      write(*,*)xk,eim,d1
  20  call cubic (rad,qplus,qminus)
c       write(*,224)
c 224  format(1x'xk,rad,qplus,qminus')
c      write(*,*)xk,rad,qplus,qminus
      if (rad.gt. 0.0D0) goto 32
      d2=qplus-(xk+1.0D0)
      if(d2.gt.0.D0)go to 21
      eim=eim
      go to 30
  21  eim=eim+ffq(qplus)-ffq((xk+1.0D0))
c      write(*,221)
c 221  format(1x'xk,eim,d2')
c      write (*,*)xk,eim,d2
  30  d3=(xk-1.0D0)-qminus
      if(d3.gt.0.D0)go to 31
      return
  31  eim=eim+ffq((xk-1.0D0))-ffq(qminus)
c
c beginning of the imaginary part and position of the cusp x0
c
       icusp=1
c      write(*,222)
c 222  format(1x'xk,eim,d3')
c      write (*,*)xk,eim,d3
  32  return
      end
c
c
c
      subroutine cubic ( rad,qplus,qminus)
      implicit double precision (a-h, o-z)
      complex*16 s1,s13
      common/hlin/xk
      common/inter/wp,alph,ef,xf
      common/cube/a0,a1,a2
c
c this subroutine finds the roots of the equation
c     4xk*q^3+(alph-4xk^2)q^2+wp^2=0.
c     see abramowitz and stegun for formulae.

      a2=(alph/(4.0D0*xk*xk)-1.0D0)*xk
      a0=wp*wp/(4.0D0*xk)
      a1=0.0D0
      q=a1/3.0D0-a2**2/9.0D0
      r=(a1*a2-3.0D0*a0)/6.0D0-a2**3/27.0D0
      rad=q**3+r**2
      if (rad .gt. 0.0D0) then
      qplus=0.0D0
      qminus=0.0D0
      return
      endif
      s13=dcmplx(r,sqrt(-rad))
      s1=s13**(1.0D0/3.0D0)
      qz1=2.0D0*dreal(s1)-a2/3.0D0
      qz3=-(dreal(s1)-dsqrt(3.0D0)*dimag(s1)+a2/3.0D0)
      qplus=qz1
      qminus=qz3
      return
      end
c
c
c
      double precision function ffq(q)
      implicit double precision (a-h,o-z)
      common /corr/rs,blt,xk1,vii,index2
      common /hlin/xk
      common /inter/wp,alph,ef,xf
      wq=sqrt(wp*wp+alph*q*q+q*q*q*q)
      ffq=(wp+wq)/(q*q)+alph/(2.0D0*wp)
c
c check prefactor (wp/4xk) to see if units are correct.
c
      ffq=(ef*wp/(4.0D0*xk1))*log(ffq)
      return
      end

      subroutine cont_sub(potype,potgen,lmax_mode,lmaxt,relc,
     &                    eikappr,db)
c
c.... continuum program version for phase shift calculation:
c.... february 1990
c
      include 'msxas3.inc'
c      include 'msxasc3.inc'


      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $ n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      common /dens/ irho,rhotot(rd_,sd_),rhoint(2),
     $ vcoul(rd_,sd_),vcoulint(2)
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode

      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex v,vcons
c
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
      COMMON /LLM/ ALPHA, BETA
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c

      character*8 name0 ,nsymbl
c
      common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de

      complex vcon,xe,ev
c
      common /pdq/ p(rd_,f_),ps(n_),dps(n_),
     *	ramf(n_),pss(6),dpss(6)
      complex p,ps,dps,ramf,pss,dpss
c
c     ##############common /pdqi/ modified to include the two wavefuncti
c     ############### for the final two holes state in the Auger decay r
c
      common /pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_)
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
c
      character*2 potgen,relc
      character*3 eikappr
      character*5 potype
c
      logical do_r_in 
c
c      write(6,11) jat,jd,jf,jlmax,jn,jrd,jsd,j1d
c
c  11  format('0    final state parameters:'
c     $ /'0  jat =',i6,2x,'number of centers (tb)'
c     $ /'0   jd =',i6,2x,'number of inequivalent centers (nun)'
c     $ /'0   jf =',i6,2x,'storage location for radial functions:=10'
c     $ /'0jlmax =',i6,2x,'maximum l-value on any atomic sphere'
c     $ /'0   jn =',i6,2x,'number of basis functions on all atoms'
c     $ /'0  jrd =',i6,2x,'maximum number of radial mesh points (npt)'
c     $ /'0  jsd =',i6,2x,'nspins*jd (for spin restriction)'
c     $ /'0  j1d =',i6,2x,'is jd+1')
c
c
c
ctn      write(30,13)
ctn   13 format(2x,'      e               xe          natom  l         '
ctn     $       '           atmat ')
c
C     WARNING: COMMONS /FCNR/ AND /PARAM/ ARE AVAILABLE ONLY AFTER SUBROUTINE 
C              INPUT_CONT IS CALLED
c
c  do not change in this version!
      nns=1
c***********************************************************************
c   get initial state radial function
c***********************************************************************
c
      print 660
660   format( 1x,' generating core state wavefunction ')
c
      call get_core_state
c
c***********************************************************************
c   compute parameters for final state and call subroutine cont
c***********************************************************************
c
      id=1
c

      call input_cont(id,potype,potgen,lmax_mode,lmaxt)

      call output_cont(id)
c
      call setup
c
      vcon=vcons(nns)
c
      write(6,10) eftr
   10 format(/,1x,' fermi level =', f10.5,/)
c
      emmef=emin-eftr
      if(emmef.lt.0.0) write(6,556) emin,eftr
  556 format(/,' ***warning***: emin=',f10.5,' less than the fermi ',
     *         'level eftr=',f10.5, 'a stop is caused in the case ',
     *         'of hedin-lundqvist potential')
      if(emmef.lt.0.0.and.irho.ne.0) then
      print 780
780   format (//,1x, 'emin less than the Fermi level; see file: ',
     *             ' results.dat',//)
      stop
      endif
c
	  print 770
770       format( 1x,' generating t_l (for030) and',
     &' atomic cross section (for050)')
c
c     construct log-linear x mesh 
c
      call llmesh
c
c     and generate core state wavefunction on log-linear x-mesh
c
      call corewf(nas,nz(nas),i_absorber_hole)
c
      call cont(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db)
c

      return
      end
c
c
      subroutine cont(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db)
c
c      include 'mscalc.inc'
      include 'msxas3.inc'

      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
c
      common/bessel/sbf(ltot_),dsbf(ltot_),snf(ltot_),dsnf(ltot_)
      complex*16 sbf,dsbf,snf,dsnf
c
      common /dens/ irho,rhotot(rd_,sd_),rhoint(2),
     $ vcoul(rd_,sd_),vcoulint(2)
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex vcons,v
c
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
      COMMON /LLM/ ALPHA, BETA
c
      COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), 
     &             PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_),
     &             RAMFSOA(N_)
      COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA
c
      common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_)
      complex atmnr, atmsr, atmsop, atmsoa
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3),
     $               dxdir,dxexc,nfis,nfis1,nfis2
      real nfis,nfis2,nfis1
      complex dmx,dmx1,qmx,qmx1,dxdir,dxexc
c
      common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2),
     &                qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3),
     &                dxxdir,dxxexc
      complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1,
     &        dxxdir,dxxexc
c
      character*8 name0 ,nsymbl
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,xe,ev
c
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,argc,yc,p3irreg,
     &        p2irreg
      real*4 einc,esct,scangl,qt,lambda
c
      common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa
      dimension msbfi(lexp_), mshfk(lexp_), ylc(lexp_*(lexp_+1))
      dimension dmsbfi(lexp_), dmshfk(lexp_)
      real*8 kappa, arg, y, msbfi, mshfk, il, kl, dmsbfi, dmshfk
c
      common/struct/ntnabs(nat_),ngbrabs
c
c	############# I include the common auger to take into account also the
c    ############# to make the auger calculation
c

	common/auger/calctype,expmode,edge1,edge2

  	character*3 calctype, expmode
	character*2 edge1,edge2

      common /pdq/ p(rd_,f_),ps(n_),dps(n_),
     *	ramf(n_),pss(6),dpss(6)
      complex p,ps,dps,ramf,pss,dpss

c	 ###################common /pdqi/ modified to include the two core hole
c      ##################of the electrons which interacts and give rise
c
      common /pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_)
c
      common /seculr/ atm(n_)
      complex*16 atm
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
c
      common/lparam/lmax2(nat_),l0i
c
      common/typot/ ipot
c
      complex amem,amem1,pamel,pamel0,cofct,vrr,qcofct,rexsrme,rexssme
c
      dimension es(nep_),xkrn(rd_),xkri(rd_),xkrs(d_),cofct(nep_,2)
      dimension qcofct(nep_,3)
c
      logical*4 doit, do_r_in
      logical*4 xasxpd
c
c fortran units
c
      common/funit/idat,iwr,iphas,iedl0,iwf

c
      complex atmd
c
      dimension distin(d_), distor(d_), ntnabs1(nat_)
      character*20 correction
      character*9 reg_type,irr_type
      character*5 potype
      character*4 spectro
      character*2 potgen,relc
      character*8 filename
      character*3 eikappr
c
      data facts/8.067/,ot/.3333333/,pai/3.1415927/
      data fsc,fscs4 /7.29735e-3,1.331283e-5/
c
c.....facts=4.*(pi)**2/137*(0.529)**2*100.0 if cross section is expresse
c.....                                      in megabarns = 10.e-18 cm**2
c
c
c start energy do loop:
c
c   67 if( irho .eq. 0 ) write(6,40) vcon
c   40 format(//,' interstitial potential vcon = (',E12.6,E12.6,')',//)
c
      reg_type='regular  '
      irr_type='irregular'
c
      if(relc.eq.'nr') then
        correction='non relativistic    '
      elseif(relc.eq.'sr') then
        correction='scalar relativistic '
      elseif(relc.eq.'so') then
        correction='spin-orbit          '
      else
        correction='                    '
      endif
c
      if (calctype.eq.'xpd') then
        spectro='PED '
      elseif (calctype.eq.'xas') then
        spectro='XAS '
      elseif (calctype.eq.'aed') then
        spectro='AED '
      elseif (calctype.eq.'led') then
        spectro='LEED'
      elseif (calctype.eq.'rex') then
        spectro='REXS'
      elseif (calctype.eq.'els') then
        spectro='EELS'
      elseif (calctype.eq.'e2e') then
        spectro='E,2E'
      endif
c
      if (emin.lt.real(vcon)) then
	 write(6,45)
	 stop
      endif
c
   45 format(//,' emin less than the interstitial potential vcon',//)
c
      xasxpd = (calctype.eq.'xpd'.or.calctype.eq.'xas')
c
      if(irho.eq.0) go to 68
      ot = 1./3.
      rsint = (3./(4.*pai*rhoint(1)))**ot
      write(6,41) gamma,rsint
   41 format(/,1x,' gamma =',f10.6,'   rsint =',f10.6,/)
   68 doit = .true.
      if(calctype.eq.'xas') then
         write(50,803)
      elseif(calctype.eq.'rex') then
         write(50,804)
      elseif(calctype.eq.'xpd') then
         write(50,807)
      endif
c
 803  format(2x,'      e             vcon             mfp  ',
     $      '      sigma0                regrme              singrme ')
c
 804  format(2x,'      e             vcon             mfp  ',
     $      '      rexsrme     rexssme ')
c
 807  format(2x,'      e             vcon             mfp  ',
     $      '      sigma0                regrme ')
c
c
c      de = alog(emax - emin + 1.)/(kxe - 1.)
c      con = 27.2116/7.62
c      wvb = sqrt(con*emin)
c      wve = sqrt(con*emax)
c      kxe = nint((wve-wvb)/0.05 + 1.)
       kxe = nint((emax-emin)/de + 1.)
c
      nval=1
      do jat=1,nuatom
        nval=max0(nval,nterms(jat))
      enddo
      write(35,111) nuatom,kxe,1,ipot,lmax_mode
      write(95,111) nuatom,kxe,1,ipot,lmax_mode
      write(70,111) nuatom,kxe,1,ipot,lmax_mode
      write(80,111) nuatom,kxe,1,ipot,lmax_mode
      write(90,111) nuatom,kxe,1,ipot,lmax_mode
  111 format(5(5x,i4))
c
      if(potgen.eq.'in') then
        write(6,*) ' check in subroutine cont'
c
        write(6,*) ' order of neighb. -- symb. -- dist. from absorber'
        write(6,*) ' '
c
c.....check with molpot data: ok (14/12/2007)
c
      do i=1,ngbrabs
	nb=ntnabs(i)
	dist=sqrt((xv(nb)-xv(1))**2+(yv(nb)-yv(1))**2+(zv(nb)-zv(1))**2)
	write(6,*) nb, nsymbl(nb), dist
      enddo
c
      endif
c
      write(6,*) ' ---------------------------------------------------',
     1           '--------------'
c
      do nb=1,ndat
	dist=sqrt((xv(nb)-xv(1))**2+(yv(nb)-yv(1))**2+(zv(nb)-zv(1))**2)
        distin(nb) = dist
      enddo
c
c      endif
c
c.....Order prototypical atoms in order of increased distance from absor
c
      call sort(ndat,distin,ndiff,distor)
      small=0.00001
c      nbrs=ngbrabs
      nbrs = ndiff
c      nbrs=8
c
       do i=1,nbrs
        do j=1,ndat
          if(abs(distin(j)-distor(i)).lt.small) then
            ntnabs1(i)=j
            write(6,12) j, nsymbl(j), distin(j)
          endif
        enddo
       enddo
 12    format(5X,I4,12X,A2,10X,F10.6)
c
c       do i=2,nbrs
c        write(6,*) ntnabs1(i), ntnabs(i-1)
c       enddo
c

c
c      write(6,*) 'irho =', irho
c     write(6,*) '----------------------------------'
      nunit=40
      nunit1=nunit+1
c
c.....write out potential and density file for first neighbors to absorb
c
100   format(1x,a5,a5,a6,f10.5,a10,3f10.5)
c
      if(irho.ne.0) then
c
      open(unit=nunit,file='plot/plot_vc.dat',status='unknown')
      open(unit=nunit1,file='plot/plot_dens.dat',status='unknown')
c
       do i=1,nbrs
c
          j = ntnabs1(i)
          write(6,12) j, nsymbl(j), distin(j)
          write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord = ', xv(j), yv(j), zv(j)
          write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord ', xv(j), yv(j), zv(j)
          do k=1,kmax(j)
             write(nunit,*) r(k,j), vcoul(k,j)
c
c              do ith=0,nthe
c               theta = dthe*float(ith)
c               do iph=0,nphi
c                  phi = dphi*float(iph)
c                 write(nunit1,*) r(k,j), theta, phi, rhotot(k,j)
                 write(nunit1,*) r(k,j), rhotot(k,j)
c               enddo
c              enddo
c
          enddo
c       close(nunit)
c       close(nunit1)
c       nunit=nunit+2
c       nunit1=nunit1+2
       enddo
c
      else
c
      open(unit=nunit,file='plot/plot_v.dat',status='unknown')
      open(unit=nunit1,file='plot/plot_dens.dat',status='unknown')
       do i=1,nbrs
c
          j = ntnabs1(i)
          write(6,12) j, nsymbl(j), distin(j)
          write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord = ', xv(j), yv(j), zv(j)
          write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord ', xv(j), yv(j), zv(j)
          do k=1,kmax(j)
             write(nunit,*) r(k,j), real(v(k,j))
c
c              do ith=0,nthe
c               theta = dthe*float(ith)
c               do iph=0,nphi
c                  phi = dphi*float(iph)
c                 write(nunit1,*) r(k,j), theta, phi, rhotot(k,j)
                 write(nunit1,*) r(k,j), rhotot(k,j)
c               enddo
c              enddo
c

          enddo
c       close(nunit)
c       close(nunit1)
c       nunit=nunit+2
c       nunit1=nunit1+2
       enddo
c
c
      endif
c
      close(nunit)
      close(nunit1)
c
c     endif
c      write(6,*) '----------------------------------'
c      do i=1,ndat
c        write(6,*) i, nsymbl(i),distin(i),distor(i)
c      enddo
C
c
c
      cl = (l0i + 1.5)**2
      nid = 1
      write(6,*)  '   '
c
c      nels = 1
      if(calctype.eq.'els'.or.calctype.eq.'e2e') then 
c         nels = 3
c
c     calculate cluster size for effective integration of eels tme
c
         kappa = 1.d0/dble(lambda) ! to account for thomas-fermi screening 
                                   ! length = 2.9*0.529/(r_s)^(1/2) 
                                   ! default = 1/20 = 0.05 (au)^{-1}
c
         do i = 1, ndat
            rcut = distor(i)
            scrcoul = exp(-real(kappa)*rcut)/rcut
            if(scrcoul.le.0.05) go to 11
         enddo
   11    neff = i - 1
c
      ltc = lexp_
      y = 0.0d0
      do na = 1, ndat
         do k = 1, kmx(na)
            arg = kappa*dble(rx(k,na))
            call msbf(arg,y,ltc,msbfi,dmsbfi)
            call mshf(arg,y,ltc,mshfk,dmshfk)
            do l = 1, ltc
               il(k,l,na) = msbfi(l)
               kl(k,l,na) = mshfk(l)*(-1)**(l-1)*kappa  !correction 15 march 2014
            enddo
         enddo
      enddo
c
      scangl = scangl/180.0*pai
      qt2 = einc + esct - 2.0*sqrt(einc*esct)*cos(scangl)
      qt = sqrt(qt2)
      write(6,*) '  '
      write(6,*)' Calculating eels in DWBA. einc =',einc,
     &                ' esct =', esct,' einl =', einc - esct - cip
      write(6,*)' Momentum transfer qt =', qt, ' au^{-1}'
      write(6,*)' Scattering angle', scangl, 'radians'
      write(6,*)' Scattering angle', scangl*180.0/pai, 'degrees'
      write(6,*) '  '
      write(6,*) ' Coulomb screening inverse length kappa =', kappa
      write(6,*) '  '
c
      endif
c
c.....Calculation of tl and rme for xpd, xas and rexs
c
c
	if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     1    calctype.eq.'rex' .or. calctype.eq.'aed'.or. 
     2    calctype.eq.'led') then
c
      nks = 1 !ficticious: in this section only for writing purposes
c
c writing the headers of the rme file
c
      write(55,821)
      write(55,822) spectro,correction
      write(55,821)
c
      if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     1   calctype.eq.'rex') then
        write(55,830) 
        write(55,840) 
        write(55,850)
        write(55,840)
      endif
c
      do 9 ne=1,kxe
       es(ne) = emin + float(ne-1)*de
       e=es(ne)
       ev=e-vcon
c
c calculate energy dependent potential:
c
      if( irho .ne. 0 ) then
        if(ne.eq.1) write(6,*) ' irho =', irho, 
     &                         ' entering vxc to calculate energy',
     &                         ' dependent exchange'
        call vxc ( doit )
      else
        if(ne.eq.1.and.nks.eq.1)  then 
          write(6,*) ' irho =', irho, ' energy independent potential' 
          write(6,*)' constant interstitial potential vcon =', vcon
        endif
      endif
      ev=e-vcon 
      write(6,*) ' energy dependent vcon = ', vcon,' at energy', e  
C             
C CONSTRUCT RELATIVISTIC POTENTIAL ON LINEAR-LOG MESH
C
      CALL VREL
C
      xe=csqrt(ev)
c
c.....write out potential ans rs files for first neighbors to
c.....absorber for the first energy point
c
      nunit=40
      nunit1=nunit+1
      open(unit=nunit,file='plot/plot_v(e).dat',status='unknown')
      open(unit=nunit1,file='plot/plot_rs.dat',status='unknown')
c
      if(ne.eq.1) then
c
       do i=1,nbrs
c
          j = ntnabs1(i)

c            write(6,*) j, nsymbl(j), distin(j)
            write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord = ', xv(j), yv(j), zv(j)
            write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord ', xv(j), yv(j), zv(j)
            do k=1,kmax(j)
              write(nunit,*) r(k,j), real(v(k,j))
              write(nunit1,*) r(k,j), rhotot(k,j)
            enddo
c       close(nunit)
c       close(nunit1)
c       nunit=nunit+2
c       nunit1=nunit1+2
       enddo
c
      endif
c
      close(nunit)
      close(nunit1)
c
c calculate maximum l-value lmxne(n,ne) for each prototipical atom
c at the energy e=es(ne)
c
c      if(lmax_mode.eq.2.or.calctype.eq.'els'.or.calctype.eq.'e2e') then
      if(lmax_mode.eq.2) then
         do n=1,nuatom
            lmxne(n,ne) = nint(sqrt(e)*rs(n))+2
            if(lmxne(n,ne).lt.l0i+1) lmxne(n,ne)=l0i+2
c            lmxels(nks,n) = lmxne(n,ne)
c            write(6,*) nks, n, e, rs(n), lmxne(n,ne)
         enddo
      endif
c
         NBL1=NUATOM/4
         XNBL1=FLOAT(NBL1)+0.0001
         XNBL2=FLOAT(NUATOM)/4.
         IF(XNBL1.LT.XNBL2) NBL1=NBL1+1
  112    FORMAT(4(7X,I2))
      if (lmax_mode.eq.2) then
         DO JL=1,NBL1
            JLN=4*(JL-1)+1
            write(35,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(95,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(70,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(80,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(90,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
         ENDDO
      else if (lmax_mode.eq.1) then
         DO JL=1,NBL1
            JLN=4*(JL-1)+1
            write(35,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(95,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(70,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(80,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(90,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
         ENDDO
      else
         DO JL=1,NBL1
            JLN=4*(JL-1)+1
            write(35,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(95,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(70,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(80,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(90,112) lmaxt,lmaxt,lmaxt,lmaxt
         ENDDO
      endif
c
c calculate atomic t-matrix elements atm(n)
C
c      if(ne.eq.1.and.nks.eq.1) write(6,*) 
      if(ne.eq.1) write(6,*) 
     &            ' calculating atomic t-matrix elements atm(n)'
c
      call smtx(ne,lmax_mode)
c
c calculate the radial integrals of transition matrix elements:
c   
      if(calctype.ne.'led') then   
        call radial(doit,imvhl)
      endif

c
c calculate atomic t-matrix with relativistic corrections
c
      call smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax,
     &                   ramfnr,ramfsr,ramfsop,ramfsoa)
c
c and corresponding radial integrals of transition matrix elements:
c
      call radialx(ne,relc,eikappr)
c
c modified to write the continuum radial wavefunction for eels
c
      lxp = lmxne(nas,ne)
      if(lxp.gt.f_) lxp=f_ - 1
      call writewf(lxp)
c
c energy dependent factors for dipole and quadrupole absoprtion; 
c factor 1/3 for unpolarized absorption
c
      if(ne.eq.1) 
     &   write(6,*) ' check ionization potential:', cip
      edfct= facts*(cip+e)*2./3.0
      edfctq = 2.0/5.0*3.0/16.0*edfct*((cip+e)*fsc)**2
      dafsfct = (cip+e)**4 * pai**2
c
      write(6,*) '  '
      write(6,*) '  '
      write(6,*) ' value of the mean free path:'
      write(6,44)
  44  format(' --------------------------------------------------',
     1         '---------------')
      if(gamma.ne.0.0.and.ne.eq.1.and.nks.eq.1) then 
         amfph = 0.529/gamma/2
         write(6,43) amfph,e
   43 format('  average mean free path due to finite gamma: mfp ='
     *       ,f10.5,'  angstrom at energy ', f10.5 ,/)
      endif
c
      if(irho.eq.0.and.imvhl.eq.0.and.nks.eq.1) then
         write(6,*)' infinite cluster mfp for real potential'
         go to 802
      endif
ctn      write(6,40) vcon,eftr
      xeim = -aimag(xe)
c
c calculate average mean free path (= amfp). define r-dependent
c wave vector xkr and its indefinite integral xkri
c


      amfpi = 0.0
      do 20 n = 1,ndat
      kxn = kmax(n)
      do 30 k = 1,kxn
      vrr = v(k,n) + cl/r(k,n)**2
      if ((e-real(vrr)).lt.0.0) then
	 xkrn(k) = 0.0
	 go to 30
      endif
      xkrn(k) = -aimag(csqrt(e-vrr))
   30 continue
c
c calculate integral of xkr
c
      call integr (xkrn(1),r(1,n),kxn,ichg(1,n),xkri,nid)
      call interpr (r(kplace(n)-3,n),xkri(kplace(n)-3),7,rs(n),
     *              xkrs(n),dummy,.false.)
      xkrs(n) = xkrs(n)/rs(n)
   20 amfpi = amfpi + xkrs(n)
c
c it is assumed that the average interstitial path is 2/3 of the total
c
      amfpi = 1./3.*amfpi/ndat + 2.0*xeim/3.
      if (amfpi.ne.0.0) then
      amfp = 0.529/amfpi/2.
         write(6,42) amfp, e
   42 format('  average mean free path in the cluster     : mfp ='
     *       ,f10.5,'  angstrom at energy ', f10.5 ,/)
      endif
  802 continue
      if(gamma.ne.0.0.and.ne.eq.1) then      
        amfpt = 0.529/(amfpi + gamma)/2.0
        write(6,46) amfpt, e
      endif
   46 format('  total mean free path due to Im V and gamma: mfp ='
     *       ,f10.5,'  angstrom at energy ', f10.5)
      if(ne.eq.1.and.amfpt.eq.0.0.and.nks.eq.1) write(6,*) 
     & ' infinite mean free path for gamma: mfp = 0.0 and Im V = 0.0 '
      write(6,44)
      write(6,*) '  '
c
c.....calculate dipole cross section and atomic matrix elements
c
      write(50,*)' ------------------------- '
      write(50,*)' &&&&&&&&&&&&&&&&&&&&&&&&& '
      write(50,*)' ------------------------- '
c
      if (xasxpd) then 
          write(50,*) ' dipole atomic cross section'
      else
          write(50,*) ' dipole rexs matrix elements'
      endif
c
      sigmasum = 0.0
c
      do 800 i=1,2
      if((l0i.eq.0).and.(i.eq.1)) goto 800
      np= l0i + (-1)**i
      amem = dmx(i)    
      amem1 = dmx1(i)  
      pamel = amem1*cmplx(atm(nstart+np))*edfct
c      write(50,*)'nr ', amem1*xe/pai/(l0i - 1 + i)
      cofct(ne,i) = amem*cmplx(atm(nstart+np))**2*edfct*xe/pai
      pamel0 = cofct(ne,i)/cmplx(atm(nstart+np))
      sigma0 = -aimag(pamel)
      sigmasum = sigmasum + sigma0
      sigma0r = -aimag(pamel0)
      rexsrme = dmx(i)*xe/pai/(l0i-1+i)
      rexssme = dmx1(i)/(l0i-1+i)
c     cofct(ne,i) = cofct(ne,i)/sigma0
c     write(6,*) sigma0,sigma0r
      if (calctype.eq.'xas') then 
         write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme
      else
         write(50,806) e,vcon,amfpt,rexsrme,rexssme 
      endif
c
      if(i.eq.2) write(98,*) e*13.6, sigma0
 800  continue
c
      do i=1,2
         cofct(ne,i) = cofct(ne,i)/sigmasum
      enddo
c
c.....calculate quadrupole atomic matrix elements for cross section (temp)
c
      if (xasxpd) then
         write(50,*) ' quadrupole atomic cross section '
      else
         write(50,*) ' quadrupole rexs matrix elements '
      endif
c
      n = 0
      sigmasum = 0.0
      do 900 i=-2,2,2
      n = n + 1
      lf = l0i + i
      if(lf.le.0) go to 900
      np = l0i + i
      amem = qmx(n)   
      amem1 = qmx1(n) 
      pamel = amem1*cmplx(atm(nstart+np))*edfctq
      qcofct(ne,n) = amem*cmplx(atm(nstart+np))**2*edfctq*xe/pai
      pamel0 = qcofct(ne,n)/cmplx(atm(nstart+np))
      sigma0 = -aimag(pamel)
      sigmasum = sigmasum + sigma0
      sigma0r = -aimag(pamel0)
      rexsrme = qmx(n)*xe/pai
      rexssme = qmx1(n)
c     qcofct(ne,i) = qcofct(ne,n)/sigma0
c     write(6,*) sigma0,sigma0r
      if (calctype.eq.'xas') then
         write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme
      else
         write(50,806) e,vcon,amfpt,rexsrme,rexssme
      endif 
 900  continue
c
      if (xasxpd) then
        write(50,*)' ------------------------- '
        write(50,*) ' dipole and quadrupole cross section with ', 
     &            'relativistic corrections of type: ', relc
        write(50,*)' ------------------------- '
      else
        write(50,*)' ------------------------- '
        write(50,*) ' dipole and quadrupole rexs matrix elements', 
     &            ' with relativistic corrections of type: ', relc
        write(50,*)' ------------------------- '
      endif
c
c
      if (xasxpd) then
        write(50,*) ' dipole atomic cross section with rel. corr.s'
      else
        write(50,*) ' dipole rexs matrix elements with rel. corr.s'
      endif
c
      sigmasum = 0.0
c
      do 910 i=1,2
      if((l0i.eq.0).and.(i.eq.1)) goto 910
      np= l0i + (-1)**i
      amem = dmxx(i) 
      amem1 = dmxx1(i)
      if(relc.eq.'nr') then
         atmd = atmnr(nstart+np)
      else if (relc.eq.'sr') then
         atmd = atmsr(nstart+np)
      else
         atmd = atmsop(nstart+np)
      endif
      pamel = amem1*atmd*edfct
c      write(50,*)'nr-rc ', amem1*xe/pai/(l0i - 1 + i)
      cofct(ne,i) = amem*atmd**2*edfct*xe/pai
      pamel0 = cofct(ne,i)/atmd
      sigma0 = -aimag(pamel)
      sigmasum = sigmasum + sigma0
      sigma0r = -aimag(pamel0)
      rexsrme = dmxx(i)*xe/pai/(l0i-1+i)
      rexssme = dmxx1(i)/(l0i-1+i)
c     cofct(ne,i) = cofct(ne,i)/sigma0
c     write(6,*) sigma0,sigma0r
      if (calctype.eq.'xas') then 
         write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme
      else
         write(50,806) e,vcon,amfpt,rexsrme,rexssme
      endif
c
      if(i.eq.2) write(99,*) e*13.6, sigma0
 910  continue
c
      do i=1,2
        cofct(ne,i) = cofct(ne,i)/sigmasum
      enddo
c
c.....calculate quadrupole atomic matrix elements for cross section (temp)
c
      if (xasxpd) then
        write(50,*) ' quadrupole atomic cross section with rel. corr.s'
      else
        write(50,*) ' quadrupole rexs matrix elements with rel. corr.s'
      endif
c
      n = 0
      sigmasum = 0.0
      do 920 i=-2,2,2
      n = n + 1
      lf = l0i + i
      if(lf.le.0) go to 920
      np = l0i + i
      amem = qmxx(n)  
      amem1 = qmxx1(n)
      if(relc.eq.'nr') then
         atmd = atmnr(nstart+np)
      else if (relc.eq.'sr') then
         atmd = atmsr(nstart+np)
      else
         atmd = atmsop(nstart+np)
      endif 
      pamel = amem1*atmd*edfctq
      qcofct(ne,n) = amem*atmd**2*edfctq*xe/pai
      pamel0 = qcofct(ne,n)/atmd
      sigma0 = -aimag(pamel)
      sigmasum = sigmasum + sigma0
      sigma0r = -aimag(pamel0)
      rexsrme = qmxx(n)*xe/pai
      rexssme = qmxx1(n)
c     qcofct(ne,i) = qcofct(ne,n)/sigma0
c     write(6,*) sigma0,sigma0r
      if (calctype.eq.'xas') then
         write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme
      else
         write(50,806) e,vcon,amfpt,rexsrme,rexssme
      endif
c
 920  continue
c
      if(relc.eq.'so') then
c
      if (xasxpd) then
      write(50,*)' dipole atomic cross section for second so component'
      else
      write(50,*)' dipole rexs matrix elements for second so component'
      endif
c
      do 930 i=1,2
      if((l0i.eq.0).and.(i.eq.1)) goto 930
      np= l0i + (-1)**i
      amem = dmxxa(i) 
      amem1 = dmxxa1(i)
      atmd = atmsoa(nstart+np)
      pamel = amem1*atmd*edfct
      cofct(ne,i) = amem*atmd**2*edfct*xe/pai
      pamel0 = cofct(ne,i)/atmd
      sigma0 = -aimag(pamel)
      sigmasum = sigmasum + sigma0
      sigma0r = -aimag(pamel0)
      rexsrme = dmxxa(i)*xe/pai/(l0i-1+i)
      rexssme = dmxxa1(i)/(l0i-1+i)
c     cofct(ne,i) = cofct(ne,i)/sigma0
c     write(6,*) sigma0,sigma0r
      if (calctype.eq.'xas') then
         write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme
      else
         write(50,806) e,vcon,amfpt,rexsrme,rexssme
      endif
c
 930  continue
c
      do i=1,2
        cofct(ne,i) = cofct(ne,i)/sigmasum
      enddo
c
c.....calculate quadrupole atomic matrix elements for cross section (temp)
c
      if (xasxpd) then
        write(50,*)'quadrupole atomic cross section for second so ',
     &             'component'
      else
        write(50,*)'quadrupole rexs matrix elements for second so ',
     &             'component'
      endif
c
      n = 0
      sigmasum = 0.0
      do 940 i=-2,2,2
      n = n + 1
      lf = l0i + i
      if(lf.le.0) go to 940
      np = l0i + i
      amem = qmxxa(n)  
      amem1 = qmxxa1(n)
      atmd = atmsoa(nstart+np)
      pamel = amem1*atmd*edfctq
      qcofct(ne,n) = amem*atmd**2*edfctq*xe/pai
      pamel0 = qcofct(ne,n)/atmd
      sigma0 = -aimag(pamel)
      sigmasum = sigmasum + sigma0
      sigma0r = -aimag(pamel0)
      rexsrme = qmxxa(n)*xe/pai
      rexssme = qmxxa1(n)
c     qcofct(ne,i) = qcofct(ne,n)/sigma0
c     write(6,*) sigma0,sigma0r
      if (calctype.eq.'xas') then
         write(50,805) e,vcon,amfpt,sigma0,rexsrme,rexssme
      else
         write(50,806) e,vcon,amfpt,rexsrme,rexssme
      endif
c
 940  continue
c
      endif
C
C  Writing the radial integrals in unit 55
C  eliminated division of dmx (qmx) by nfis: 29-3-2013 due to reorganization
C  of normalization of initial core state
C
      if(l0i.eq.0) then
C
c         write(55,860) 0.0,0.0,
c     1                 csqrt(dmx(2)*xe/pai),
c     2                 0.0,0.0,
c     3                 0.0,0.0,
c     4                 csqrt(qmx(3)*xe/pai)
C
      elseif(l0i.eq.1) then 
C
c         write(55,860) csqrt(dmx(1)*xe/pai/l0i),
c     1                 csqrt(dmx(2)*xe/pai/(l0i+1)),
c     2                 0.0,0.0, 
c     3                 csqrt(qmx(2)*xe/pai), 
c     4                 csqrt(qmx(3)*xe/pai)
C
      else 
C
c         write(55,860) csqrt(dmx(1)*xe/pai/l0i),
c     1                 csqrt(dmx(2)*xe/pai/(l0i+1)),
c     2                 csqrt(qmx(1)*xe/pai),
c     3                 csqrt(qmx(2)*xe/pai),
c     4                 csqrt(qmx(3)*xe/pai)
C
      endif
C
      if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     1   calctype.eq.'rex') then
      if(l0i.eq.0) then
C
         write(55,860) 0.0,0.0,
     1                 csqrt(dmxx(2)*xe/pai),
     2                 0.0,0.0,
     3                 0.0,0.0,
     4                 csqrt(qmxx(3)*xe/pai),reg_type
C
      elseif(l0i.eq.1) then 
C
         write(55,860) csqrt(dmxx(1)*xe/pai/l0i),
     1                 csqrt(dmxx(2)*xe/pai/(l0i+1)),
     2                 0.0,0.0, 
     3                 csqrt(qmxx(2)*xe/pai), 
     4                 csqrt(qmxx(3)*xe/pai),reg_type
C
      else 
C
         write(55,860) csqrt(dmxx(1)*xe/pai/l0i),
     1                 csqrt(dmxx(2)*xe/pai/(l0i+1)),
     2                 csqrt(qmxx(1)*xe/pai),
     3                 csqrt(qmxx(2)*xe/pai),
     4                 csqrt(qmxx(3)*xe/pai),reg_type
C
      endif
c
      if(relc.eq.'so') then
         write(55,*) ' second component of so matrix element '
C
         if(l0i.eq.0) then
C
            write(55,860) 0.0,0.0,
     1                 csqrt(dmxxa(2)*xe/pai),
     2                 0.0,0.0,
     3                 0.0,0.0,
     4                 csqrt(qmxxa(3)*xe/pai)
C
         elseif(l0i.eq.1) then 
C
            write(55,860) csqrt(dmxxa(1)*xe/pai/l0i),
     1                 csqrt(dmxxa(2)*xe/pai/(l0i+1)),
     2                 0.0,0.0, 
     3                 csqrt(qmxxa(2)*xe/pai), 
     4                 csqrt(qmxxa(3)*xe/pai)
C
         else 
C
            write(55,860) csqrt(dmxxa(1)*xe/pai/l0i),
     1                 csqrt(dmxxa(2)*xe/pai/(l0i+1)),
     2                 csqrt(qmxxa(1)*xe/pai),
     3                 csqrt(qmxxa(2)*xe/pai),
     4                 csqrt(qmxxa(3)*xe/pai)
C
         endif
c
      endif
c
      if(calctype.ne.'xpd') then 
      if(l0i.eq.0) then
c      write(55,*) '========dq irregular me: hs mesh==============='
C
c         write(55,860) 0.0,0.0,
c     1                 dmx1(2)/(l0i+1),
c     2                 qmx1(1),
c     3                 qmx1(2),
c     4                 qmx1(3)
C
c      write(55,*) '========dq irregular me: ll mesh==============='
C
         write(55,860) 0.0,0.0,
     1                 dmxx1(2)/(l0i+1),
     2                 qmxx1(1),
     3                 qmxx1(2),
     4                 qmxx1(3),irr_type
      else
c      write(55,*) '========dq irregular me: hs mesh==============='
C
c         write(55,860) dmx1(1)/l0i,
c     1                 dmx1(2)/(l0i+1),
c     2                 qmx1(1),
c     3                 qmx1(2),
c     4                 qmx1(3)
C
c      write(55,*) '========dq irregular me: ll mesh==============='
C
         write(55,860) dmxx1(1)/l0i,
     1                 dmxx1(2)/(l0i+1),
     2                 qmxx1(1),
     3                 qmxx1(2),
     4                 qmxx1(3),irr_type
      endif
      endif
      endif
C
c
c 810  format(29x,2f8.5,4x,2f8.5)
c
      doit = .false.
c
    9 continue   !end energy loop
c
      write(iedl0) ((cofct(ne,i),ne=1,kxe),i=1,2)
c
      else !perform eels or e2e calculation
c
      write(6,*)' calculating eels radial matrix elements'
      write(6,*)' n. of prototypical atoms in the effective cluster',
     &          ' chosen for eels (e2e) radial matrix elements',neff
      write(6,*) '   '
      write(6,*) '   '
c
c
      write(55,821)
      write(55,822) spectro,correction
      write(55,821)
c
c
c      write(55,815)
c
c 815  format(2x,'single and two-site eels (e2e) radial matrix elements')
c
      do ne = 1, kxe
         deltae = float(ne-1)*de
         write(6,*) ' ---> start of calculation of eels (e2e) rme at',
     1              ' energy point ',ne
c
c  nks: loop on the 3 electrons involved:
c       = 1 : incoming electron
c       = 2 : scattered electron
c       = 3 : excited electron
c
         do 10 nks = 1, 3
            if(expmode.eq.'cis') then
               if(nks.eq.1) e = einc
               if(nks.eq.2) e = einc - cip - emin - deltae
               if(nks.eq.3) e = emin + deltae 
            elseif(expmode.eq.'cfs') then
               if(nks.eq.1) e = esct + cip + emin + deltae
               if(nks.eq.2) e = esct
               if(nks.eq.3) e = emin + deltae
           elseif(expmode.eq.'cel') then
               if(nks.eq.1) e = einc + deltae
               if(nks.eq.2) e = einc - cip - emin + deltae
               if(nks.eq.3) e = emin 
            endif
c
       ev=e-vcon
c
      if(nks.eq.1) write(6,*)'   einc  =',e,' Ryd'
      if(nks.eq.2) write(6,*)'   esct  =',e,' Ryd'
      if(nks.eq.3) write(6,*)'   eloss =',e,' Ryd',
     1                       ' (excluding the ion. pot.)'
c
c calculate energy dependent potential:
c
      if( irho .ne. 0 ) then
        if(ne.eq.1) write(6,*) '   irho =', irho, 
     &                         ' entering vxc to calculate energy',
     &                         ' dependent exchange'
        call vxc ( doit )
      else
        if(ne.eq.1.and.nks.eq.1)  then 
          write(6,*) '       irho =', irho, ' energy independent',
     1               ' potential' 
          write(6,*)'       constant interstitial potential vcon =',
     1              vcon
        endif
      endif
      ev=e-vcon
      if( irho .ne. 0 )  
     &  write(6,*) '       energy dependent vcon = ', vcon,
     1             ' at energy', e,' Ryd'
  
C             
C CONSTRUCT RELATIVISTIC POTENTIAL ON LINEAR-LOG MESH
C
      CALL VREL
C
      xe=csqrt(ev)
c
c.....write out potential ans rs files for first neighbors to
c.....absorber for the first energy point
c
      nunit=40
      nunit1=nunit+1
      open(unit=nunit,file='plot/plot_v(e).dat',status='unknown')
      open(unit=nunit1,file='plot/plot_rs.dat',status='unknown')
c
      if(ne.eq.1) then
c
       do i=1,nbrs
c
          j = ntnabs1(i)

c            write(6,*) j, nsymbl(j), distin(j)
            write(nunit,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord = ', xv(j), yv(j), zv(j)
            write(nunit1,100) 'atom ',nsymbl(j), 'dist =',distin(j),
     &                     ' coord ', xv(j), yv(j), zv(j)
            do k=1,kmax(j)
              write(nunit,*) r(k,j), real(v(k,j))
              write(nunit1,*) r(k,j), rhotot(k,j)
            enddo
c       close(nunit)
c       close(nunit1)
c       nunit=nunit+2
c       nunit1=nunit1+2
       enddo
c
      endif
c
      close(nunit)
      close(nunit1)
c
c calculate maximum l-value lmxne(n,ne) for each prototipical atom
c at the energy e=es(ne)
c
      if(lmax_mode.eq.2) then
         do n=1,nuatom
            lmxne(n,ne) = nint(sqrt(e)*rs(n))+2
            lmxels(nks,n) = lmxne(n,ne)
            if(lmxne(n,ne).lt.l0i+1) lmxne(n,ne)=l0i+2
            write(6,*) nks, n, e, rs(n), lmxne(n,ne)
         enddo
      endif
c
         NBL1=NUATOM/4
         XNBL1=FLOAT(NBL1)+0.0001
         XNBL2=FLOAT(NUATOM)/4.
         IF(XNBL1.LT.XNBL2) NBL1=NBL1+1
c  112    FORMAT(4(7X,I2))
      if (lmax_mode.eq.2) then
         DO JL=1,NBL1
            JLN=4*(JL-1)+1
            write(35,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(95,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(70,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(80,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
            write(90,112) lmxne(jln,ne),lmxne(jln+1,ne),
     &                    lmxne(jln+2,ne),lmxne(jln+3,ne)
         ENDDO
      else if (lmax_mode.eq.1) then
         DO JL=1,NBL1
            JLN=4*(JL-1)+1
            write(35,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(95,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(70,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(80,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
            write(90,112) lmax2(jln),lmax2(jln+1),
     &                    lmax2(jln+2),lmax2(jln+3)
         ENDDO
      else
         DO JL=1,NBL1
            JLN=4*(JL-1)+1
            write(35,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(95,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(70,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(80,112) lmaxt,lmaxt,lmaxt,lmaxt
            write(90,112) lmaxt,lmaxt,lmaxt,lmaxt
         ENDDO
      endif
c
c
c calculate atomic t-matrix with relativistic corrections
c
      call smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax,
     &                   ramfnr,ramfsr,ramfsop,ramfsoa)
c
      if(eikappr.eq.'yes') then
         write(6,*) '  '
         write(6,*) ' calculating phases in the eikonal approximation'
         call eikonal(nuatom,xe,z,rs,db)
      endif
c
c and corresponding radial integrals of transition matrix elements:
c
      if(nks.eq.3) then 
         write(55,823)  ne      ! energy point
         call radialx_eels(neff)
         call writeelswf
      endif
c
c
      doit = .false.
c
   10    continue   !end loop for eels
c
         write(6,*) ' ---> end  of  calculation of eels (e2e) rme',
     1              ' at energy point ',ne
         write(6,*) '         '
c
      enddo !end energy do loop
c
c
      endif     !end of if clause beginning at line 5606
c
c
 801  format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,f10.5,2x,2f10.5)
 805  format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,f10.5,2x,2e15.6,2x,2e15.6)
 806  format(1x,f10.5,2x,2f10.5,2x,f10.5,2x,2e15.6,2x,2e15.6)
 810  FORMAT(29X,F8.5,1X,F8.5,4X,F8.5,1X,F8.5)
 820  FORMAT(29X,f8.5,1X,f8.5,4X,f8.5,1X,f8.5,4X,f8.5,1X,f8.5)
 821  FORMAT(138('-'))
 822  FORMAT(35x,'matrix elements of ',a4,' with corrections of type: ',
     1       a20)
 823  FORMAT(50x,'---> energy point number ',i5,' <---')
 830  FORMAT('                electric dipole radial integrals       +',
     1       '                      electric quadrupole radial ',
     2       'integrals')
 840  FORMAT('------------------------------------------------------',
     1       '-+----------------------------------------------------',
     2       '------------------------------')
 850  FORMAT('      R(li --> li - 1)           R(li --> li + 1)      +',
     1       '      R(li --> li - 2)           R(li --> li)       ',
     2       '        R(li --> li + 2)')
 860  FORMAT(1X,e12.5,1X,e12.5,2X,e12.5,1X,e12.5,4X,e12.5,1X,e12.5,
     1       2X,e12.5,1X,e12.5,2X,e12.5,1X,e12.5,4x,a9)
c
c ######### the auger matrix elements are written in the output file
c           radaed.dat directly from the subroutine radial, since they m
c           for each interaction momentum lk


c
      return
c
      end
c
c
c
      subroutine output_cont(iq)
c	   include 'mscalc.inc'
       include 'msxas3.inc'
      integer   at_,d_,rd_,sd_
      parameter (at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1)
c
c modified output subroutine for complex potentials
c
      common /dens/ irho,rhotot(rd_,sd_),rhoint(2),
     $ vcoul(rd_,sd_),vcoulint(2)
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex vcons
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      character*8 name0 ,nsymbl
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex ev,xe,vcon
c
c
      character*4 label(2)
      logical pott,rhoo
      data label/'down',' up '/
c
      pott=(irho .ne. 1)
      rhoo=(irho .ne. 0)
c
      write (6,5) iovrho
    5 format(1x,' starting potentials and/or charge densities',
     x ' written to file',i3)
ctn      if(radion.ne.0.0. and . nout.eq.1) write(6,10) radion,qion
   15 format(7x,'constant potential=(',1pe14.6,' , ',1pe14.6,')')
   20 format(7x,'interstitial charge=',1pe14.6)
c
c
      do 300 ispin=1,nspins
      if(nspins.eq.2) write(6,25) label(ispin)
   25 format(///40x,'spin ',a4,' potential')
      if( pott )  write (iovrho,15) vcons(ispin)
      if( rhoo )  write (iovrho,20) rhoint(ispin)
      do 200 n=1,nat
      if(neq(n).eq.0) goto  35
      write(iovrho,30) n,neq(n)
   30 format(' mesh and potential for',i4,' same as for',i4)
      goto  200
   35 write(iovrho,40) n,h(n),(ichg(i,n),i=1,10),kplace(n),exfact(n)
   40 format(///i8,'   h=',f10.4,'   change points:',10i4,'   kplace='
     1 ,i4,'   exchange=',f8.6)
      kmaxn=kmax(n)
      m=n+(ispin-1)*ndat
      if( rhoo ) goto  55
      write(iovrho,45)
   45 format(72x/12x,4('r',11x,'real(v)',11x))
      write(iovrho,50) (i,(r(i+j-1,n),v(1,i+j-1,m),j=1,4),i=1,kmaxn,4)
   50 format(1x,i3,8e15.7)
      goto  200
   55 if( pott ) goto  65
      write(iovrho,60)
   60 format(72x/12x,4('r',13x,'rho',13x))
      write(iovrho,50) (i,(r(i+j-1,n),rhotot(i+j-1,m),j=1,4),
     x i=1,kmaxn,4)
      goto 200
   65 write(iovrho,70)
   70 format(72x/27x,2('r',11x,'real(v)',10x,'rho',13x))
      write(iovrho,75) (i,(r(i+j-1,n),v(1,i+j-1,m),rhotot(i+j-1,m),
     x j=1,2),i=1,kmaxn,2)
   75 format(16x,i3,6e15.7)
      goto 200
c   80 if( rhoo ) goto  90
c      write(iovrho,85)
c   85 format(72x/27x,2('r',11x,'real(v)',9x,'lcore',12x))
c      write(iovrho,75) (i,(r(i+j-1,n),v(1,i+j-1,m),
c     x j=1,2),i=1,kmaxn,2)
c      goto  200
c   90 if( pott ) goto  100
c      write(iovrho,95)
c   95 format(72x/27x,2('r',13x,'rho',11x,'lcore',12x))
c      write(iovrho,75) (i,(r(i+j-1,n),rhotot(i+j-1,m),
c     x j=1,2),i=1,kmaxn,2)
c      goto  200
c  100 write(iovrho,105)
c  105 format(72x/27x,2('r',11x,'real(v)',10x,'rho',
c     x 10x))
c      write(iovrho,50) (i,(r(i+j-1,n),v(1,i+j-1,m),
c     x rhotot(i+j-1,m),j=1,2),i=1,kmaxn,2)
  200 continue
  300 continue
c
c
      return
c
      end
c
c
      subroutine radial(doit,imvhl)
c
c      include 'mscalc.inc'
      include 'msxas3.inc'

      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
c
c.....this subroutine calculates the radial matrix elements d(i)
c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for
c.....the regular (dmx) and irregular solution (dmx1)
c
      common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
c
      common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3),
     $               dxdir,dxexc,nfis,nfis1,nfis2
      real nfis,nfis2,nfis1
      complex dmx,dmx1,qmx,qmx1,dxdir,dxexc
c
c     ######### I introduce a new common with the orbital momentum of
c     ######### the two electrons which interacts and give rise to
c     ######### to the auger decay; these two momentum are necessary
c     ######### to do the loop over the interaction momentum when I perf
c               the integrals
c
      common/l2holes/l01i,l02i
      integer l01i,l02i

      character*8 name0 ,nsymbl
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,ev,xe
c
      common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6)
      complex p,ps,dps,ramf,pss,dpss
c
c     ########## common pdqi modified to include also the Auger two
c                wavefunctions
      common/pdqi/rpi(rd_),rpi1(rd_),rpi2(rd_)
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)

c
c     ######### common pottype modified to consider also the Auger calcu
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode





	common/auger/calctype,expmode,edge1,edge2

    	character*3 calctype, expmode
	character*2 edge1,edge2
    	integer nct,l2hmin,l2hmax

	data pai/3.1415927/
c
        common /lparam/lmax2(nat_),l0i
c
c
c
        dimension rid(rd_),rid0(rd_),riq0(rd_),cri(rd_),cri1(rd_)
	dimension rid2(rd_),cri2(rd_)
        complex rid,cri,cri1,dx,qx,dx1,dx2,dx3,dx4



c
        logical*4 doit
c
	integer nchannel,lkmaxdir1,lkmaxdir2,lkminexc2
	integer lkmindir1,lkmindir2,lkmaxexc1,lkmaxexc2,lkminexc1
	integer lamin,lamax,lkmin,lkmin1,lkmax,lkmax1,lkm,lkmn



c
c     iout = 5


      id=1
      n = nas
c
c      kx = kmax(n)  ! value used in older versions (contains the 3 points 
C                      outside the muffin-tin radius that were used for interpolation)
c
      kx = kmax(n) - 3
c
c	################# Modified the subsequent "if" to take into account
c                         also  the possibility to make an auger calcula
c
      if(.not.doit) go to 21

c	go to 20

c
c***********************************************************************
c     find normalization factor for initial state: nfis
c***********************************************************************
c
c

c      if (calctype.eq.'xpd') then
	if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     &    calctype.eq.'rex') then
c      n=nas
c      kx=kmax(n)
      do 156 k=1,kx
  156 rid(k)=rpi(k)**2
      call defint(rid,r(1,n),kx,ichg(1,n),dx,id)
      nfis=sqrt(real(dx))
	  if(iout .eq. 5) write(6,*) (i, r(i,n), rpi(i)/nfis, i=1,kx)




      WRITE(33,*) CIP
      write(33,*) l0i
      do i=1,kx
        write(33,*) r(i,n), rpi(i)/(nfis*r(i,n))
      enddo
      nfis = nfis**2


       else
c
c     ######## normalization of primary core hole wave function
c
c	 n=nas
c      kx=kmax(n)
      do 1560 k=1,kx
 1560 rid(k)=rpi(k)**2

c
      call defint(rid,r(1,n),kx,ichg(1,n),dx,id)
c
      nfis=sqrt(real(dx))
	  if(iout .eq. 5) write(6,*) (i, r(i,n), rpi(i)/nfis, i=1,kx)




c      WRITE(33,*) CIP
c      write(33,*) l0i
      do i=1,kx
        write(33,*) r(i,n), rpi(i)/(nfis*r(i,n))
      enddo




c
c      ######### Auger normalization
c
      rid(k)=rpi1(k)**2
      call defint(rid,r(1,n),kx,ichg(1,n),dx1,id)
      rid(k)=rpi2(k)**2
      call defint(rid,r(1,n),kx,ichg(1,n),dx2,id)
c
          nfis1=sqrt(real(dx1))
	  nfis2=sqrt(real(dx2))

    	end if


c
c***********************************************************************
c     note that for the initial state rpi(k) = r*pi(k)
c***********************************************************************
c
c     ################ I introduce an if condition to take into account
c     ################ also the possibility to make an Auger calculation
c
c  21  if(calctype.eq.'xpd') then
   21 if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     &    calctype.eq.'rex') then
C
      do 30 k=1,kx
      rid0(k) = r(k,n)**2*rpi(k)
  30  riq0(k) = r(k,n)*rid0(k)
c
c.....calculate regular and irregular dipole matrix elements
c
      do 100 i=1,2
      dmx(i)=(0.,0.)
      dmx1(i)=(0.,0.)
      if((l0i.eq.0).and.(i.eq.1))goto 100
      np = l0i + (-1)**i
      do 110 k=1,kx
  110 rid(k) = rid0(k)*p(k,np+1)
      call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id)
      dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i)/nfis
      do 120 k=1,kx
  120 rid(k) = rid0(k)*p(k,np+1+npss)
      call cintegr(rid,r(1,n),kx,ichg(1,n),cri1,id)
      do 130 k=1,kx
  130 rid(k) = rid(k)*cri(k)
      call defint(rid,r(1,n),kx,ichg(1,n),dx,id)
      do 140 k=1,kx
  140 rid(k) = rid0(k)*p(k,np+1)*(cri1(kx)-cri1(k))
      call defint(rid,r(1,n),kx,ichg(1,n),dx1,id)
      dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np)/nfis
  100 continue
C
c      write(6,*) 'radial matrix elements from shell li = ', l0i
c      write(6,*) (real(dmx(l)),aimag(dmx(l)),l=1,2)
c      write(6,*) (real(dmx1(l)),aimag(dmx1(l)),l=1,2)
c.....calculate regular and irregular quadrupole matrix elements
c
      m = 0
      do 10 i=-2,2,2
      m = m + 1
      qmx(m)=(0.,0.)
      qmx1(m)=(0.,0.)
      lf = l0i + i
      if(lf.le.0) go to 10
      np = l0i + i
      do 11 k=1,kx
   11 rid(k) = riq0(k)*p(k,np+1)
      call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id)
      qmx(m) = (cri(kx)/ramf(nstart+np))**2/nfis
      do 12 k=1,kx
   12 rid(k) = riq0(k)*p(k,np+1+npss)
      call cintegr(rid,r(1,n),kx,ichg(1,n),cri1,id)
      do 13 k=1,kx
   13 rid(k) = rid(k)*cri(k)
      call defint(rid,r(1,n),kx,ichg(1,n),dx,id)
      do 14 k=1,kx
   14 rid(k) = riq0(k)*p(k,np+1)*(cri1(kx)-cri1(k))
      call defint(rid,r(1,n),kx,ichg(1,n),dx1,id)
      qmx1(m) = (dx+dx1)/ramf(nstart+np)/nfis
   10 continue
C
      else
c
c     ########  start the auger part; first write
c     ########  the orbital momentum of the electrons involved
c
      write(55,8110)l0i,l01i,l02i
8110  format(5x,i2,5x,i2,5x,i2)

c
c    ######### Start calculation of auger matrix elements
C    ######### rpi is the wavefunction of the primary core hole
C    ######### rpi1 and rpi2 are the wavefunction for the two holes in t
c    ######### nchannel is the number of channels allowed for
c    ######### the Auger continuum electron;
c    ######### l2h is the orbital angular momentum given by the coupling
c    ######### two orbital momentum of the two final holes
c    ######### lk is the 'angular momentum' of the interaction-transferr
c    ######### here we count the u_er and lower bound for l of the cont
c


       l2hmin=abs(l01i-l02i)
       l2hmax=l01i+l02i
       lamin=abs(l0i-l2hmin)
       lamax=l0i+l2hmax
c
c     here we count the number of the channels for the continuum auger e
c
      nchannel=0
      do 101 np=lamin,lamax
	   nchannel=nchannel+1
101   continue

      write(55,8120) lamin,nchannel
 8120 format(12x,i2,5x,i2)
c
c     loop over the number of continuum channels
c
       nct=0
	do 1 i=1,nchannel
	   np=lamin+(i-1)


c
c     ###### establish the range for the interaction momentum for
c     ###### the direct integral
c     ###### from the selection rules we have:
c     ###### abs(np-l01i)<lk<np+l01i and abs(l0i-l02i)<lk<l0i+l02i
c     ###### and moreover lk must run with a step of 2
c
	lkmaxdir1=np+l01i
	lkmaxdir2=l0i+l02i
	lkmindir1=abs(np-l01i)
	lkmindir2=abs(l0i-l02i)

	lkmax=min(lkmaxdir1,lkmaxdir2)
	lkmin=max(lkmindir2,lkmindir1)

c
c     ###### establish the range for the interaction momentum for
c     ###### the exchange integral
c     ###### from the selection rules we have:
c     ###### abs(np-l02i)<lk<np+l02i and abs(l0i-l01i)<lk<l0i+l01i
c     ###### and moreover lk must run with a step of 2
c
	lkmaxexc1=np+l02i
	lkmaxexc2=l0i+l01i
	lkminexc1=abs(np-l02i)
	lkminexc2=abs(l0i-l01i)
	lkmax1=min(lkmaxexc1,lkmaxexc2)
	lkmin1=max(lkminexc2,lkminexc1)

c
c     ####### establish the bigger range for the interaction momentum be
c             the range for the direct integral and the range for the
c             exchange integral
c

	lkm=max(lkmax,lkmax1)
	lkmn=min(lkmin,lkmin1)

         write(55,8119)' L =',np,'  LB_MIN = ',lkmn,'  LB_MAX = ',lkm

8119  format(a4,1x,i2,1x,a11,i2,a11,i2)

	do 2 lk=lkmn,lkm
c
c     ###### count the number of total channels, below this number is st
c            in the file nchannels.dat
c
	nct=nct+1
c
c     ###### initialize the integrals
c
	  dxdir=(0.,0.)
	  dxexc=(0.,0.)
c
c     ###### calculation of the direct integral; if selection rules are
c            satisfied then the integral is set equal to zero
c
	lsum1=np+lk+l01i
	lsum2=l0i+lk+l02i


      if((lk.lt.lkmin).or.(lk.gt.lkmax).or.
     *	   ((lsum1/2)*2.ne.lsum1).or.((lsum2/2)*2.ne.lsum2)) then
        dxdir=(0.,0.)
	else

        do 1020 k=1,kx
1020	  rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*(r(k,n)**lk)
c
        call cintegr(rid,r(1,n),kx,ichg(1,n),cri,id)
c
	  do 1030 k=1,kx
1030    rid(k)=rpi(k)*rpi2(k)*cri(k)/(r(k,n)**(lk+1))
	  call defint(rid,r(1,n),kx,ichg(1,n),dx,id)
c
c     ####### now the other region where r'>r
c
	  do 1040 k=1,kx
1040	  rid2(k)=rpi(k)*rpi2(k)*(r(k,n)**lk)
        call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id)


	  do 1050 k=1,kx
1050    rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1))
	  call defint(rid,r(1,n),kx,ichg(1,n),dx1,id)
	  dxdir=(dx+dx1)*2*
     *  sqrt(xe/pai)/(nfis*nfis1*nfis2*ramf(nstart+np))


	  end if
c
c     ###### now the exchange integral
c

	lsum3=np+lk+l02i
	lsum4=l0i+lk+l01i

	  if((lk.lt.lkmin1).or.(lk.gt.lkmax1).or.
     *    (((lsum3/2)*2).ne.lsum3).or.(((lsum4/2)*2).ne.lsum4)) then
	  dxexc=(0.,0.)

	  else

	  do 1060 k=1,kx
1060	  rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*(r(k,n)**lk)
        call cintegr (rid,r(1,n),kx,ichg(1,n),cri,id)


    	  do 1070 k=1,kx

1070    rid(k)=rpi(k)*rpi1(k)*cri(k)/(r(k,n)**(lk+1))

	  call defint(rid,r(1,n),kx,ichg(1,n),dx3,id)

c
c     ####### now the other region where r'>r
c
	  do 1788 k=1,kx
1788	  rid2(k)=rpi(k)*rpi1(k)*(r(k,n)**lk)
        call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id)



	  do 1799 k=1,kx
1799    rid(k)=r(k,n)*rpi2(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1))

	  call defint(rid,r(1,n),kx,ichg(1,n),dx4,id)


	  dxexc=(dx3+dx4)*2*
     *  sqrt(xe/pai)/(nfis1*nfis2*nfis*ramf(nstart+np))

	  end if
c
c      ############## Write the auger matrix elements
c

c       write(55,8111) 'L =',np,'LB =',lk,dxdir,dxexc
c8111   format(2x,a3,i2,4x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5)
	 write(55,8111) 'LB =',lk,dxdir,dxexc
8111   format(12x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5)




2     continue

1     continue

c      write(55,*) 'nct=',nct

      end if

      return
      end
c
      subroutine radialx_eels(neff)
c
      include 'msxas3.inc'
c
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
C
c.....this subroutine calculates the radial matrix elements
c.....necessary for eels cross-section 
c.....using a linear-log mesh
c
      common/mtxele/ nstart,nlast
c
      common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2),
     &                qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3),
     &                dxxdir,dxxexc
      complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1,
     &        dxxdir,dxxexc
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,ev,xe
      character*8 nsymbl,name0
c
      common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_)
      complex*16 sbf,dsbf,shf,dshf
C
      COMMON /LLM/ ALPHA, BETA
C
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
C      COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_)
C      COMPLEX PX,DPX,PSX,DPSX,RAMFX
c
      COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), 
     &             PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_),
     &             RAMFSOA(N_)
      COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA
c
C
      COMMON/PDQIX/RPIX(RDX_), FNISX
      COMPLEX RPIX
C
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
C
c     ######### common pottype modified to consider also the Auger calcu
c

      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode
c
	common/auger/calctype,expmode,edge1,edge2
c
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,ramfprd,ramfprx,
     &        p3irreg,p2irreg,trop1(rdx_)
      complex*16 trop(rdx_)
      real*4 einc,esct,scangl,qt,lambda
      complex qtc, arg, ydf, scprod
c
      common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa
      double precision kappa, il, kl
c
    	character*3 calctype, expmode, eikappr
	character*2 edge1,edge2
C
      common /lparam/lmax2(nat_),l0i
c
      DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_)
      DIMENSION RID1(RDX_),RID2(RDX_),RID3(RDX_),RID4(RDX_)
      COMPLEX RID,RID1,RID2,RID3,RID4
      COMPLEX VC,VCX,VCD,VCDX,VCDR,VCDXR
C
      CHARACTER*2 RELC
C
C
c***************************************************************************
c     note that here rpix(k) = r**3*pi(k). 
c     wf rpix(k) is already normalized
c     (see subroutine corewf)
c***************************************************************************
c
      pi = 3.1415926
c
      id = 1
      na = nas
c
c.....calculate direct and exchange Coulomb integral on absorber and different 
c.....spheres 
c
         nt0a=n0(na)            
         ntxa=nt0a+nterms(na)-1
         dxa = hx(na)
         nstart = nt0a
         nlast = ntxa
c      write(6,*) 'in radialx_eels', nt0a, ntxa 
c
      write(6,*) '  '
      write(6,*)'   writing eels (e2e) regular direct terms'
      write(55,100)
      write(55,821)
c
      do 20 n1 = nt0a, ntxa
         l=ln(n1)
         if(l.gt.lmxels(3,na)) goto 20
         do k = 1, kmx(na)
            rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta)
         enddo
c
         do 30 nat2 = 1, neff
            nb = nat2
            if(neq(nat2).ne.0) nb = neq(nat2)            
            nt0b=n0(nb)            
            ntxb=nt0b+nterms(nb)-1
            dxb = hx(nb)
         do 40 n2 = nt0b, ntxb
            lp = ln(n2)
            if(lp.gt.lmxels(1,nb)) goto 40
            do 50 n3 = nt0b, ntxb
               ls = ln(n3)
               if(ls.gt.lmxels(2,nb)) goto 50
               do k = 1, kmx(nb)
                  rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3
     &                      /(alpha*rx(k,nb) + beta)
               enddo
c
             ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb)
               lc_min=max(abs(l-l0i), abs(lp-ls))
               lc_max=min(l+l0i, lp+ls)
c
               if(na.eq.nb) then
                  do lc = lc_min, lc_max, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                     call coulss(rid1,rid2,il(1,l1,na),
     &                           kl(1,l1,na),kmx(na),dxa,pi,vc) 
                     write(55,10) na, l, lp, ls, lc, vc/ramfprd  !, vc
                  enddo
               endif
c
   50       continue         
c
   40    continue
c
   30    continue

   20 continue
c
      write(55,821)
      write(55,104)
      write(55,821)
c
      do 120 n1 = nt0a, ntxa
         l=ln(n1)
         if(l.gt.lmxels(3,na)) goto 120
         do k = 1, kmx(na)
            rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta)
         enddo
c
         do 130 nat2 = 1, neff
            nb = nat2
            if(neq(nat2).ne.0) nb = neq(nat2)            
            nt0b=n0(nb)            
            ntxb=nt0b+nterms(nb)-1
            dxb = hx(nb)
         do 140 n2 = nt0b, ntxb
            lp = ln(n2)
            if(lp.gt.lmxels(1,nb)) goto 140
            do 150 n3 = nt0b, ntxb
               ls = ln(n3)
               if(ls.gt.lmxels(2,nb)) goto 150
               do k = 1, kmx(nb)
                  rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3
     &                      /(alpha*rx(k,nb) + beta)
               enddo
c
            ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb)
               lc_min=max(abs(l-l0i), abs(lp-ls))
               lc_max=min(l+l0i, lp+ls)
c
               if(na.ne.nb) then
                 do lc=abs(l-l0i), l+l0i, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                     do lcp=abs(lp-ls), lp+ls, 2
                        l1p = lcp + 1
                        if(l1p.gt.lexp_) cycle
                        call coulds(rid1,rid2,dxa,dxb,il(1,l1,na),
     &                        il(1,l1p,nb),kmx(na),kmx(nb),pi,vcd)
                     vcdr = vcd/ramfprd
                     if(abs(vcdr).lt.1.e-9) cycle
                     write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr
                     enddo
                  enddo                       
               endif
c
  150       continue         
c
  140    continue
c
  130    continue

  120 continue
c
      write(6,*)'   writing eels (e2e) regular exchange terms'
      write(55,821)
      write(55,102)
      write(55,821)
c
      do 21 n1 = nt0a, ntxa
         l=ln(n1)
         if(l.gt.lmxels(2,na)) goto 21
         do k = 1, kmx(na)
            rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta)
         enddo
c
         do 31 nat2 = 1, neff
            nb = nat2
            if(neq(nat2).ne.0) nb = neq(nat2)            
            nt0b=n0(nb)            
            ntxb=nt0b+nterms(nb)-1
            dxb = hx(nb)
         do 41 n2 = nt0b, ntxb
            lp = ln(n2)
            if(lp.gt.lmxels(1,nb)) goto 41
            do 51 n3 = nt0b, ntxb
               ls = ln(n3)
               if(ls.gt.lmxels(3,nb)) goto 51
               do k = 1, kmx(nb)
                  rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3
     &                      /(alpha*rx(k,nb) + beta)
               enddo
c
            ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na)
               lc_min=max(abs(l-l0i), abs(lp-ls))
               lc_max=min(l+l0i, lp+ls)
c
               if(na.eq.nb) then
                  do lc = lc_min, lc_max, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle 
                     call coulss(rid3,rid4,il(1,l1,na),
     &                        kl(1,l1,na),kmx(na),dxa,pi,vcx)
                     write(55,10) na, l, lp, ls, lc, vcx/ramfprx
                  enddo
               endif
c
   51       continue         
c
   41    continue
c
   31    continue

   21 continue
c
      write(55,821)
      write(55,106)
      write(55,821)
C
      do 121 n1 = nt0a, ntxa
         l=ln(n1)
         if(l.gt.lmxels(2,na)) goto 121
         do k = 1, kmx(na)
            rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta)
         enddo
c
         do 131 nat2 = 1, neff
            nb = nat2
            if(neq(nat2).ne.0) nb = neq(nat2)            
            nt0b=n0(nb)            
            ntxb=nt0b+nterms(nb)-1
            dxb = hx(nb)
         do 141 n2 = nt0b, ntxb
            lp = ln(n2)
            if(lp.gt.lmxels(1,nb)) goto 141
            do 151 n3 = nt0b, ntxb
               ls = ln(n3)
               if(ls.gt.lmxels(3,nb)) goto 151
               do k = 1, kmx(nb)
                  rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3
     &                      /(alpha*rx(k,nb) + beta)
               enddo
c
            ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na)
               lc_min=max(abs(l-l0i), abs(lp-ls))
               lc_max=min(l+l0i, lp+ls)
c
               if(na.ne.nb) then
                  do lc=abs(l-l0i), l+l0i, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                     do lcp=abs(lp-ls), lp+ls, 2
                        l1p = lcp + 1
                        if(l1p.gt.lexp_) cycle
                        call coulds(rid3,rid4,dxa,dxb,il(1,l1,na),
     &                        il(1,l1p,nb),kmx(na),kmx(nb),pi,vcdx)
                        vcdxr = vcdx/ramfprx
                        if(abs(vcdxr).lt.1.e-9) cycle
                     write(55,11) na, nb, l, lp, ls, lc, lcp, vcdxr
                     enddo
                  enddo
               endif
c
  151     continue         
c
  141  continue
c
  131  continue

  121 continue
c
   10 format(5i5,4e15.7)
   11 format(7i5,4e15.7)
c
c      write(6,*) alpha, beta
c
      if(calctype.eq.'els') then
      write(6,*) '  '
      write(6,*)'   writing eels irregular direct terms'
      write(55,821)
      write(55,101)
      write(55,821)
c
      do 22 n1 = nt0a, ntxa
         l=ln(n1)
         if(l.gt.lmxels(3,na)) goto 22
         do k = 1, kmx(na)
            rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta)
            if(l.le.5) then
               rid(k) = rpix(k)*p3irreg(k,l+1)/(alpha*rx(k,na) + beta)
            else
               rid(k) = (0.0,0.0)
            endif
         enddo
c
         do 32 nat2 = 1, neff
            nb = nat2
            if(neq(nat2).ne.0) nb = neq(nat2)            
            nt0b=n0(nb)            
            ntxb=nt0b+nterms(nb)-1
            dxb = hx(nb)
         do 42 n2 = nt0b, ntxb
            lp = ln(n2)
            if(lp.gt.lmxels(1,nb)) goto 42
            do 52 n3 = nt0b, ntxb
               ls = ln(n3)
               if(ls.gt.lmxels(2,nb)) goto 52
c
               do k = 1, kmx(nb)
                  rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3
     &                      /(alpha*rx(k,nb) + beta)
     &                      /ramfsr1(lp+1,nb)/ramfsr2(ls+1,nb)
               enddo
c
c            ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb)
c
               lc_min=max(abs(l-l0i), abs(lp-ls))
               lc_max=min(l+l0i, lp+ls)
c
               if(na.eq.nb) then
                  do lc = lc_min, lc_max, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                      call sstrop(rid2,il(1,l1,na),
     &                            kl(1,l1,na),kmx(na),dxa,pi,trop)
                      do k = 1, kmx(na)
                         rid4(k) = rid1(k)*trop(k) 
                         rid3(k) = rid(k)*trop(k)    
                      enddo
                  call irregint1(rid3,rid4,kmx(na),dxa,vc)
                  if(abs(vc/ramfsr3(l+1,na)).lt.1.e-10) cycle
                  write(55,10) na, l, lp, ls, lc, vc/ramfsr3(l+1,na)    
                  enddo
               else
                  do lc=abs(l-l0i), l+l0i, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                     do lcp=abs(lp-ls), lp+ls, 2
                        l1p = lcp + 1
                        if(l1p.gt.lexp_) cycle
                        call dstrop(rid2,dx2,il(1,l1,na),
     &                       il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1)
                      do k = 1, kmx(na)
                         rid4(k) = rid1(k)*trop1(k)
                         rid3(k) = rid(k)*trop1(k)
                      enddo
                      call irregint1(rid3,rid4,kmx(na),dxa,vcd)
                     vcdr = vcd/ramfsr3(l+1,na)
                     if(abs(vcdr).lt.1.e-10) cycle
                     write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr
                     enddo
                  enddo                       
               endif
c
   52       continue         
c
   42    continue
c
   32    continue

   22 continue
c
c
      write(6,*)'   writing eels irregular exchange terms'
      write(55,821)
      write(55,103)
      write(55,821)
c
      do 23 n1 = nt0a, ntxa
         l=ln(n1)
         if(l.gt.lmxels(2,na)) goto 23
         do k = 1, kmx(na)
            rid1(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta)
            if(l.le.5) then
               rid(k) = rpix(k)*p2irreg(k,l+1)/(alpha*rx(k,na) + beta)
            else
               rid(k) = (0.0,0.0)
            endif
         enddo
c
         do 33 nat2 = 1, neff
            nb = nat2
            if(neq(nat2).ne.0) nb = neq(nat2)            
            nt0b=n0(nb)            
            ntxb=nt0b+nterms(nb)-1
            dxb = hx(nb)
         do 43 n2 = nt0b, ntxb
            lp = ln(n2)
            if(lp.gt.lmxels(1,nb)) goto 43
            do 53 n3 = nt0b, ntxb
               ls = ln(n3)
               if(ls.gt.lmxels(3,nb)) goto 53
c
               do k = 1, kmx(nb)
                  rid2(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3
     &                      /(alpha*rx(k,nb) + beta)
     &                      /ramfsr1(lp+1,nb)/ramfsr3(ls+1,nb)
               enddo
c
c            ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb)
c
               lc_min=max(abs(l-l0i), abs(lp-ls))
               lc_max=min(l+l0i, lp+ls)
c
               if(na.eq.nb) then
                  do lc = lc_min, lc_max, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                      call sstrop(rid2,il(1,l1,na),
     &                            kl(1,l1,na),kmx(na),dxa,pi,trop)
                      do k = 1, kmx(na)
                         rid4(k) = rid1(k)*trop(k) 
                         rid3(k) = rid(k)*trop(k)    
                      enddo
                  call irregint1(rid3,rid4,kmx(na),dxa,vc)
                  if(abs(vc/ramfsr2(l+1,na)).lt.1.e-10) cycle
                  write(55,10) na, l, lp, ls, lc, vc/ramfsr2(l+1,na)    
                  enddo
               else
                  do lc=abs(l-l0i), l+l0i, 2
                     l1 = lc + 1
                     if(l1.gt.lexp_) cycle
                     do lcp=abs(lp-ls), lp+ls, 2
                        l1p = lcp + 1
                        if(l1p.gt.lexp_) cycle
                        call dstrop(rid2,dx2,il(1,l1,na),
     &                       il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1)
                      do k = 1, kmx(na)
                         rid4(k) = rid1(k)*trop1(k)
                         rid3(k) = rid(k)*trop1(k)
                      enddo
                      call irregint1(rid3,rid4,kmx(na),dxa,vcd)
                     vcdr = vcd/ramfsr2(l+1,na)
                     if(abs(vcdr).lt.1.e-10) cycle
                     write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr
                     enddo
                  enddo                       
               endif
c
   53       continue         
c
   43    continue
c
   33    continue

   23 continue
c
      endif !end of if clause to write irregular terms in case of calctype = els
c
      write(55,821)
c
 100  format(10x,'single site regular direct terms:')
 101  format(10x,'irregular direct terms:')
 102  format(10x,'single site regular exchange terms:')
 103  format(10x,'irregular exchange terms')
 104  format(10x,'two-site regular direct terms:')
 106  format(10x,'two-site regular exchange terms:')
 821  FORMAT(138('-'))
c
      return
      end
c
c
      subroutine coulss(rho1,rho2,il,kl,kmx,dx,pi,vc)
c
      include 'msxas3.inc'
c
      dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx)
      dimension rid(rdx_), a(rdx_), p(rdx_)
      complex rho1, rho2, vc, vc1, vc2
      complex*16 rid, a, p 
      real*8 il, kl
c
      id = 1
      do k = 1, kmx
         rid(k) = il(k)*dcmplx(rho2(k))
      enddo      
      call integrcmdp(rid,dx,kmx,a,id)
      do k = 1, kmx
         rid(k) = kl(k)*dcmplx(rho2(k))
      enddo
      call integrcmdp(rid,dx,kmx,p,id)
c
      do k = 1, kmx
         rid(k) = (p(kmx)-p(k))*il(k)*dcmplx(rho1(k))
      enddo
      call integrcmdp(rid,dx,kmx,p,id)
c
      vc1 = cmplx(p(kmx))
c      write(6,*) 'vc1 = ',vc1
      do k = 1, kmx
         rid(k) = a(k)*kl(k)*dcmplx(rho1(k))
      enddo
      call integrcmdp(rid,dx,kmx,p,id)
c
      vc2 = cmplx(p(kmx))
c      write(6,*) 'vc2 = ',vc2
      vc = (vc1 + vc2)*8.0*pi
c
      return
      end
c
c
      subroutine coulds(rho1,rho2,dx1,dx2,ila,ilb,
     &                  kmx1,kmx2,pi,vc)
c
      include 'msxas3.inc'
c
      dimension rho1(kmx1), rho2(kmx2), ila(kmx1), ilb(kmx2)
      dimension a1(rdx_), a2(rdx_), rid(rdx_)
      complex rho1, rho2, a1, a2, rid, vc1, vc2, vc
      real*8 ila, ilb
c
      id = 1
      do k = 1, kmx1
         rid(k) = rho1(k)*real(ila(k))
      enddo      
      call integrcm(rid,dx1,kmx1,a1,id)
c      call interp(r1(kpl1-3),a1(kpl1-3),7,rs1,vc1,dummy,.false.)
      vc1 = a1(kmx1)
c
      id = 1
      do k = 1, kmx2
         rid(k) = rho2(k)*real(ilb(k))
      enddo
      call integrcm(rid,dx2,kmx2,a2,id)
c      call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.)
      vc2 = a2(kmx2)
c
      vc = vc1*vc2*8.0*pi        
      return
      end
c
c
      subroutine sstrop(rho2,il,kl,kmx,dx,pi,trop)
c
      include 'msxas3.inc'
c
      dimension rho2(kmx), il(kmx), kl(kmx), trop(kmx)
      dimension rid(rdx_), a(rdx_), p(rdx_)
      complex rho2
      complex*16 rid, a, p, trop 
      real*8 il, kl
c
      id = 1
      do k = 1, kmx
         rid(k) = il(k)*dcmplx(rho2(k))
      enddo      
      call integrcmdp(rid,dx,kmx,a,id)
      do k = 1, kmx
         rid(k) = kl(k)*dcmplx(rho2(k))
      enddo
      call integrcmdp(rid,dx,kmx,p,id)
c
      do k = 1, kmx
         rid(k) = (p(kmx)-p(k))*il(k)
      enddo
c
      do k = 1, kmx
         trop(k) = (rid(k) + a(k)*kl(k))*8.0*pi
      enddo
c
c
      return
      end
c
c
      subroutine dstrop(rho2,dx2,ila,ilb,kmx1,kmx2,pi,rid)
c
      include 'msxas3.inc'
c
      dimension rho2(kmx2), ila(kmx1), ilb(kmx2)
      dimension a2(rdx_), rid(rdx_)
      complex rho2, a2, rid
      real*8 ila, ilb
c
      id = 1
      do k = 1, kmx2
         rid(k) = rho2(k)*real(ilb(k))
      enddo
      call integrcm(rid,dx2,kmx2,a2,id)
c      call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.)
      do k = 1, kmx1
         rid(k) = ila(k)*a2(kmx2)*8.0*pi
      enddo
c      
      return
      end
c
c
      subroutine irregint(rho1,rho2,rl,hl,kmx,dx,vc)
c
      include 'msxas3.inc'
c
      dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx)
      dimension rid(rdx_), a(rdx_), p(rdx_)
      complex rho1, rho2, vc, vc1, vc2
      complex rid, a, p, rl, hl 
c
      id = 1
      do k = 1, kmx
         rid(k) = rl(k)*dcmplx(rho2(k))
      enddo      
      call integrcm(rid,dx,kmx,a,id)
      do k = 1, kmx
         rid(k) = hl(k)*dcmplx(rho2(k))
      enddo
      call integrcm(rid,dx,kmx,p,id)
c
      do k = 1, kmx
         rid(k) = (p(kmx)-p(k))*rl(k)*dcmplx(rho1(k))
      enddo
      call integrcm(rid,dx,kmx,p,id)
c
      vc1 = cmplx(p(kmx))
c      write(6,*) 'vc1 = ',vc1
      do k = 1, kmx
         rid(k) = a(k)*hl(k)*dcmplx(rho1(k))
      enddo
      call integrcm(rid,dx,kmx,p,id)
c
      vc2 = cmplx(p(kmx))
c      write(6,*) 'vc2 = ',vc2
      vc = (vc1 + vc2)
c
      return
      end
c
c
      subroutine irregint1(rho1,rho2,kmx,dx,vc)
c
      include 'msxas3.inc'
c
      dimension rho1(kmx), rho2(kmx)
      dimension rid(rdx_), a(rdx_), p(rdx_)
      complex rho1, rho2, vc, vc1, vc2
      complex rid, a, p
c
      id = 1
      do k = 1, kmx
         rid(k) = dcmplx(rho2(k))
      enddo      
      call integrcm(rid,dx,kmx,a,id)
      do k = 1, kmx
         rid(k) = dcmplx(rho1(k))
      enddo
      call integrcm(rid,dx,kmx,p,id)
c
      do k = 1, kmx
         rid(k) = (p(kmx)-p(k))*dcmplx(rho2(k))
      enddo
      call integrcm(rid,dx,kmx,p,id)
c
      vc1 = cmplx(p(kmx))
c      write(6,*) 'vc1 = ',vc1
      do k = 1, kmx
         rid(k) = a(k)*dcmplx(rho1(k))
      enddo
      call integrcm(rid,dx,kmx,p,id)
c
      vc2 = cmplx(p(kmx))
c
      vc = (vc1 + vc2)
c
      return
      end
c
c
       subroutine setup
c
c      include 'mscalc.inc'
      include 'msxas3.inc'
      integer   at_,ltot_
      parameter ( at_=nat_-1,ltot_=lmax_+1,n_=ltot_*ua_)
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      common/funit/idat,iwr,iphas,iedl0,iwf
c
      character*8 name0, name0i, nsymbl
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,xe,ev
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode



	  common/auger/calctype,expmode,edge1,edge2


	  character*3 calctype, expmode
	  character*2 edge1,edge2

      common/lparam/lmax2(nat_),l0i
c
c     ########## I introduce a common/l2holes to take into account the
c     ########## the orbital momentum of the two electrons which interac
c     ########## and give rise to the Auger decay; the two orbital momen
c     ########## are necessary in subroutine radial to do the loop over
c     ########## the interaction momentum
c
	  common/l2holes/l01i,l02i

	  integer l01i,l02i
c
      character*8 core_basis_name(25)
      integer core_basis_l(25)
      character*8 exc_basis_name
      integer exc_basis_l(lmax_+1),exc_basis_dim
      integer exc_basis_ndg
c
      data core_basis_name/'1s1/2','2s1/2','2p1/2','2p3/2',
     1'3s1/2','3p1/2','3p3/2','3d3/2','3d5/2','4s1/2','4p1/2',
     2 '4p3/2','4d3/2','4d5/2','4f5/2','4f7/2','5s1/2','5p1/2',
     3 '5p3/2','5d3/2','5d5/2','5f5/2','5f7/2','5g7/2','5g9/2'/
c
      data core_basis_l/0,0,1,1,0,1,1,2,2,0,1,1,2,2,3,3,0,
     1                    1,1,2,2,3,3,4,4/
c
      data exc_basis_name/'no sym'/
      data lmaximum/lmax_/

      data exc_basis_ndg/1/
c
      do 7001 i=1,lmaximum+1
	  exc_basis_l(i)=i-1
7001  continue
      exc_basis_dim=0
      do 7002 i=1,ndat
	  exc_basis_dim=exc_basis_dim+lmax2(i)+1
7002  continue
c

      do 59 n=1,nat
      lmaxx(n)=0
      n0(n)=0
      n0l(n)=0
      lmaxn(n)=0
      nterms(n)=0
   59 nls(n)=0
      nuatom=0
      write (6,327)iosym
  327 format(1x,' symmetry information generated internally'/,
     x       1x,' symmetry information  written  to file',i3)
c
      name0i=core_basis_name(i_absorber_hole)
      write(iwr,120) name0i
      write(iosym,120) name0i


  120 format(1x,//,'  core initial state of type: ',a5)
c
      ndim=exc_basis_dim
      ndg=exc_basis_ndg
      name0=exc_basis_name
c
      write (iosym,103) ndim,ndg,name0
  103 format(' # basis function including o.s. =',i4,'   degeneracy=',
     1 i3,5x,a6)
      i_l=1
      i_atom=1




      l0i = core_basis_l(i_absorber_hole)
c
c     ############## Modified to consider also the Auger part
c
      if (calctype.eq.'aed') then
	l01i = core_basis_l(i_absorber_hole1)
        l02i = core_basis_l(i_absorber_hole2)
      end if
c
c
      do 125 n=1,ndim

      ln(n)=exc_basis_l(i_l)
      write (iosym,104) n, ln(n)
104   format ( 1x,'basis function no.',i5,'   l=',i3)
      natom(n)=i_atom
      i_l=i_l+1
      if(i_l.gt.(lmax2(i_atom)+1))then
	  i_l=1
	  i_atom=i_atom+1
      endif
c
      write(iosym,106) natom(n)
  106 format (30x, ' atom no.=',i3)
c
      na=natom(n)
      lmaxn(na)=max0(lmaxn(na),ln(n))
      nuatom=max0(nuatom,na)
      nterms(na)=nterms(na)+1
      nls(na)=nls(na)+1
  125 continue
ctn      write(6,1099) ndim
      write(iosym,112) nuatom, name0
  112 format(' number of inequivalent atoms =',i4,
     *       ' for representation:',a6)
      if (nuatom.ne.ndat) then
	  write(6,122) nuatom, ndat
	  stop
      endif
  122 format(//,' fatal error: nuatom not equal ndat',2i5,//)
c
      n0(1)=1
      n0l(1)=1
      lmaxx(1)=max0(lmaxx(1),lmaxn(1))
      if(nuatom.eq.1) go to 127
      do 124 na=2,nuatom
      n0(na)=n0(na-1)+nterms(na-1)
      n0l(na)=n0l(na-1)+nls(na-1)
  124 lmaxx(na)=max0(lmaxn(na),lmaxx(na))
c branch point
  127 continue
      return
c
      end
c
c
      subroutine smtx(ne,lmax_mode)
c
c      include 'mscalc.inc'
      include 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_)
      complex*16 sbf,dsbf,shf,dshf
      complex*16 sbfrs(ltot_),dsbfrs(ltot_)
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex vcons,v
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6)
      complex p,ps,dps,ramf,pss,dpss
c
      character*8 name0 ,nsymbl
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,ev,xe
c
      common /seculr/ atm(n_)
      complex*16 atm,stmat
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
c
      common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3),
     $               dxdir,dxexc,nfis,nfis1,nfis2
      real nfis,nfis2,nfis1
      complex dmx,dmx1,qmx,qmx1,dxdir,dxexc
c
      complex csqrt,arg,ramf0
c
	common/auger/calctype,expmode,edge1,edge2
  	character*3 calctype, expmode
	character*2 edge1,edge2
c

      xe= csqrt(ev)
      ns=(nns-1)*ndat
c
      do  5  j=1,ndim
    5 atm(j)=(0.0D0,0.0D0)
c
c calculate t-matrix elements:
c                    stmat: inverse t-m elements (atomic spheres)
c                    ramf:  for normalization of ps(k) functions
c
      do 60 na=1,nuatom
      WRITE(95,77) NA
      ns=ns+1
      mout=1
      nt0a=n0(na)
      ntxa=nt0a+nterms(na)-1
	  if (na.eq.nas) then
	   nstart=nt0a
	   nlast=ntxa
	  endif
      l=-1
      nlat=-1
      arg=xe*rs(na)
      ml=lmaxn(na)+1
      call csbf(arg,xe,ml,sbf,dsbf)
      call cshf2(arg,xe,ml,shf,dshf)
      npabs=0
      do 45 nn=nt0a,ntxa
      l=ln(nn)
      nlat=nlat+1
      npabs=npabs+1
      if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss
      if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45
      call tmat(l,rs(na),kmax(na),z(na),h(na),r(1,na),v(1,ns),
     1         ichg(1,na),mout,kplace(na),p(1,npabs),stmat,ps(nn),
     2         dps(nn),ramf0)
c
      atm(nn)=stmat
      ramf(nn)=ramf0
      IF(LMAX_MODE.EQ.0) THEN
         write(95,1001)xe/0.52917715,stmat
      ELSE
         write(95,1002)xe/0.52917715,stmat
      ENDIF
c
C definition of stmat as exp(-i*delta)*sin(delta)
c
	  fasi=sign(-1.,real(cmplx(stmat)))*
     1         real(asin(sqrt(abs(dimag(stmat)))))
	  if(fasi.lt.0.0) fasi=fasi+3.1415926
       write(30,1000)e,xe,na,nlat,stmat,fasi
c      write(30)e,xe,na,nlat,stmat
c      write(*,*)e,xe,na,nlat,stmat
 1000 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3,2x,2e16.6,f10.5)
 1001 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6)
 1002 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9)
  45  continue
   60 continue
C
  77  FORMAT('--------------------------  ATOM ',I3,
     1       '  -----------------------')
c
c calculate singular solution inside muffin tin sphere for the absorbing
c atom, matching to sbf in interstitial region
c
      nl=0
      lmsing=5
      mout=4
      kp=kplace(nas)
      kpx=kmax(nas)
      do 92 k=kp-3,kpx
      if(r(k,nas)-rs(nas)) 92,93,93
   92 continue
c
c define points (first) kp1 and kp2 outside the absorbing sphere
c and use them to start computation of singular solution (s_l)
c
   93 kp1=k+1
      kpl=kp1-3
      nst=n0(nas)
      nlst=n0(nas)+nterms(nas)-1
      l=-1
      ml=lmaxn(nas)+1
      arg=xe*r(kp1,nas)
      call cshf2(arg,xe,ml,sbf,dsbf)
      arg=xe*r(kp1-1,nas)
      call cshf2(arg,xe,ml,shf,dshf)
      arg=xe*rs(nas)
      call cshf2(arg,xe,ml,sbfrs,dsbfrs)
      do 95 n=nst,nlst
      l=ln(n)
c
c skip high and divergent l-values of
c singular solution h_l
c
      if(l.gt.lmsing)go to 95
      nl=nl+1
      np=npss+nl
      np1=nl
c
      call tmat(l,rs(nas),kp1,z(nas),h(nas),r(1,nas),v(1,nas),
     $ichg(1,nas),mout,kpl,p(1,np),stmat,pss(np1),dpss(np1),ramf0)
c
c     shfp = shf(l+1)*xepi
c     dshfp = dshf(l+1)*xepi
c     print *, ps(np),dps(np),shfp,dshfp
c     do 96 k=1,kpx
c         if(k.lt.kp2)then
c             p(k,np)=p(k,np)*(sbfrs(l+1)/pss(np1))*xepi !rescale h_l
c         else                             !  to match h_l at rs
c             p(k,np)=(0.,0.)
c         end if
c  96 continue
   95 continue
c
      return
      end
c
      subroutine tmat(l,rs,kmax,z,delh,r,v,ichg,mout,kplace,p,stmat,
     1  ps,dps,ramf)
c
c      include 'mscalc.inc'
      include 'msxas3.inc'
      integer   ltot_, rd_
      parameter (ltot_=lmax_+1, rd_=440)
c
c
c
c t-matrix calculation - integrates radial schrodinger equation
c using numerov procedure - does outward and inward integration
c for atomic spheres - gives inverse of t-matrix and log deriva-
c tive at sphere surface.
c
c modified for complex potentials
c
c calculates :
c
c    mout=4       solution matching to (0.,1.)*hf2 at r=rs
c
c
c    mout=1        atomic spheres t-matrix elements
c        returns:
c           stmat=[sbfc,ps]/[shfc,ps]                 (@rs atomic sphere
c           ramf=[sbfc,ps]*xe*rs**2                   (@rc atomic sphere
c
c
c
      common/bessel/sbfc(ltot_),dsbfc(ltot_),shfc(ltot_),
     1 dshfc(ltot_)
      complex*16 sbfc,shfc,dsbfc,dshfc
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout
      complex vcon,xe,ev
c
c
      dimension v(kmax),p(kmax),r(kmax),ichg(10)
      complex v,p,ps,dps,ramf
      complex*16 stmat,x,ramff
      complex*16 pk,pk1,pkm,dkm,dk1,dk,gk,gk1,gkm
      complex*16 pn(rd_)
      data pi/3.141592653589793d0/
c
c
c
      kstop=1
      a=l*(l+1)
      if(mout.eq.4) go to 60
c
c outward integration for atomic spheres
c
      ki=1
      if(l.ge.5) ki=ichg(1)
      call startp(z,l,e,r,v,kmax,ki,pn)
      h=r(ki+1)-r(ki)
      hsq=h**2
      pkm=pn(ki)
      pk1=pn(ki+1)
      dkm=-dcmplx((e-v(ki)-a/r(ki)**2)*hsq)*pn(ki)/12.d0
      dk1=-dcmplx((e-v(ki+1)-a/r(ki+1)**2)*hsq)*pn(ki+1)/12.d0
      kis=ki+2
      n=1
      if(ki.eq.ichg(1)) n=2
      do 34 k=kis,kmax
      gk=dcmplx((e-v(k)-a/r(k)**2)*hsq)/12.d0
      pk=dcmplx((2.d0*(pk1+5.d0*dk1)-(pkm-dkm))/(1.d0+gk))
      pn(k)=pk
      if(k.lt.ichg(n)) go to 30
      n=n+1
      hsq=4.*hsq
      dkm=4.d0*dkm
      dk1=-4.d0*gk*pk
      pk1=pk
      go to 34
   30 pkm=pk1
      dkm=dk1
      dk1=-gk*pk
      pk1=pk
   34 continue
c
      go to 78
c
c inward integration to find solution matching to (0.,1.)*hf2 at r=rs
c
   60 n=11
   61 n=n-1
      if(n.eq.0) go to 66
      kn=ichg(n)
      if(kn.ge.kmax) go to 61
c
   66 kn=kmax
      pkm=sbfc(l+1)*dcmplx(xe/pi*r(kn))
      pk1=shfc(l+1)*dcmplx(xe/pi*r(kn-1))
      hsq=delh**2*4**n
      pn(kn)=pkm
      pn(kn-1)=pk1
      dkm=-dcmplx((e-a/r(kn)**2-vcon))*pkm*dble(hsq)/12.d0
      dk1=-dcmplx((e-a/r(kn-1)**2-vcon))*pk1*dble(hsq)/12.d0
      k=kn+1
      if(k.gt.kmax) go to 79
      do 76 i=k,kmax
   76 pn(i)=(0.0d0,0.0d0)
   79 k=kn-1
   73 k=k-1
   74 gk=dcmplx((e-v(k)-a/r(k)**2))*dble(hsq)/12.d0
      pk=dcmplx((2.d0*(pk1+5.d0*dk1)-pkm+dkm)/(1.d0+gk))
	  pn(k)=pk
      if(k.eq.kstop) go to 78
      if(n.eq.0) go to 69
      if(k.gt.ichg(n)) go to 69
      if(k.le.2) go to 75
      n=n-1
      dk=-pk*gk
      gk1=dcmplx((e-v(k-2)-a/r(k-2)**2))*dble(hsq)/12.d0
      pk1=dcmplx((2.d0*(pk+5.d0*dk)-pk1+dk1)/(1.d0+gk1))
      dk1=-pk1*gk1/4.d0
      hsq=hsq/4.
      gkm=dcmplx((e-v(k-1)-a/r(k-1)**2))*dble(hsq)/12.d0
      dk=dk/4.d0
      pkm=0.5d0*((pk-dk)+(pk1-dk1))/(1.d0-5.d0*gkm)
      dkm=-pkm*gkm
      k=k-3
c
c     keller modification         subroutine tmat
c
      pn(k+2)=pkm
      if(k+1.lt.kstop) go to 78
      pn(k+1) = pk1
      if(k+1.eq.kstop) go to 78
      go to 74
   69 pkm=pk1
      dkm=dk1
      dk1=-pk*gk
      pk1=pk
      go to 73
   75 write(6,103)
      stop
  103 format(//,18h error stop - tmat,//)
c
c
   78 continue
      do 77 k=1,kmax
   77 p(k)=cmplx(pn(k)/dble(r(k)))
      call interp(r(kplace-3),p(kplace-3),7,rs,ps,dps,.true.)
      if(mout.eq.4) return
	  x=dcmplx(dps/ps)
      ramff=sbfc(l+1)*x-dsbfc(l+1)

	  stmat=ramff/(shfc(l+1)*x-dshfc(l+1))
	  ramf=cmplx(ramff)*ps*rs*rs*xe
      return
c
      end
c
c
      subroutine eikonal(nuatom,xe,z,rs,db)
c
      include 'msxas3.inc'
c
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      dimension z(at_), rs(at_)
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex vcons,v
c
      complex xe
c
      open(unit=45, file='tl/tbmat.dat',status='unknown')
c
      write(45,*) 'impinging electron wave vector kappa =', real(xe)
      write(35,*) 'impinging electron wave vector kappa =', real(xe)
      write(6,*) ' impinging electron wave vector kappa =', real(xe)
c
      do na=1,nuatom
         write(45,*)'atom number ', na,'(z =', z(na),')' 
         write(35,*)'atom number ', na,'(z =', z(na),')' 
c         write(6,*)' atom number ', na,'(z =', z(na),')'
          z0 = z(na) 
         call tbmat(db,rs(na),kplace(na),z0,r(1,na),v(1,na),real(xe))
      enddo
c
      close(45)
c
c      write(6,*) ' normal exit in subroutine eikonal '
c      stop
c
      return
      end
c
c
      subroutine tbmat(db,rs,kmax,z0,r,v,xer)
c
      integer rd_
      parameter (rd_=440, nt_=1500)
c
      dimension v(kmax),r(kmax), z(rd_)
      complex v, z
c 
      dimension x(nt_), rx(nt_), rid(nt_), rid1(nt_)
c
      complex cu, tb, zb, z1, zx, dzx, d2zx, rid, rid1, dbf, dbs
c
      data pi/3.1415926/
c

      do i = 1, kmax
         z(i) = r(i)*v(i)
c         write(45,*) r(i), z(i)
      enddo
c
      id = 1   !for subroutine defint
      idr = 0  !for subroutine defint
      cu = (0.0,1.0)
c      write(6,*)
      twz = -2.0*z0
c      write(6,*) ' twz =', twz
c
c      db = 0.01
c      b0 = -5.3
c      nb = (-b0 + log(rs))/db
c      do ib = 1, nb
c         b = exp((ib-1)*db + b0)
      nb = nint(rs/db)
c         write(6,*) 'nb =', nb
      do ib = 1, nb - 1 
         b = (ib-1)*db + db
c
         dx = 0.005
         nx = nint(rs/dx)
         rmx = nx*dx
         t = rmx/b
         rt = log(t + sqrt(t**2-1.0))
c
         nt = nint(rt/dx)
c         write(6,*) 'nt =', nt,' for ib =', ib
         if(nt.gt.nt_) then
            write(6,*) '  '
            write(6,*) '  '
            write(6,*) ' stop in subroutine tbmat '
            write(6,*) ' increase dimension nt_; ',
     &                 ' it should be greater than nt =', nt
            write(6,*) '  '
            write(6,*) '  '
         call exit
         endif
         if(nt.le.4) cycle
         x(1) = dx
         rx(1) = b*(exp(dx) + exp(-dx))/2.0
c         write(2,*) x(1), rx(1)
         do i = 2, nt
            x(i) = x(i-1) + dx
            rx(i) = b*(exp(x(i)) + exp(-x(i)))/2.0
c         write(2,*) x(i), rx(i)
         enddo
c
         do i = 1, nt
            jlo = 1
            call nearest1(r, kmax, rx(i), ip1, ip2, ip3, jlo)
c
            call cinterp_quad( r(ip1), z(ip1), r(ip2), z(ip2),
     &                         r(ip3),z(ip3),rx(i),zx,dzx,d2zx)
            rid(i) = zx - twz
            rid1(i) = zx
         enddo
c
         call defint0(rid,dx,nt,zb,id)
         call defint0(rid1,dx,nt,z1,idr)
c
         zbc = twz*rt
         dbf = zb + zbc
c         write(6,*) ' coulomb eikonal phase zbc =', zbc
c         write(6,*) ' eikonal phase zb =', zb
c         write(6,*) ' total eikonal phase dbf =', dbf
c
c         write(6,*) ' integrated zx =', z1
c
         dbs = -dbf/xer/2.0
         tb = cu/pi*(cexp(2.0*cu*dbs) - 1.0)
c
c         write(6,*) ' eikonal t(b) =', tb,' at b =', b
c
         write(45,'(3e15.7)') b, tb
         write(35,'(3e15.7)') b, tb
c
      enddo
c
c
      return
      end
c
c
      subroutine vxc ( doit )
c      include 'mscalc.inc'
      include 'msxas3.inc'
      integer   at_,d_,rd_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1)
c
c     calculation of ex-correlation h-l potential
c
c
c
      common /dens/ irho,rs(rd_,sd_),rsint(2),
     $ vcoul(rd_,sd_),vcoulint(2)

      common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      common /hedin/ wp2,xk,e,eta2,pi,ot,kdens
c
c x_k_0 not divided by k_f
c
      common/corr/r_s,blt,x_k_0
c
      character*8 name0 ,nsymbl
      common/param/eftr,gamma,vcon(2),xe,ev,ekn,iout,nat,ndat,
     1 nspins,nas,rmuftin(at_),xv(at_),yv(at_),zv(at_),exfact(at_),
     3 z(at_),lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de

	  complex xe,ev
      external f1,f2,f3

      real*8 r_s,blt,x_k_0,im_vxc,re_vxc,pi_8
	  real*4 re_vxc_4,im_vxc_4

      logical doit, iskip

      nout = 0
      anns=float(nspins)
      eps=1.e-3
	  eta=1.e-3
	  eta2=eta*eta
	  ot=1./3.
	  ts2=27.*27.
      t2=32.
      sqr3=sqrt(3.)
      pi=3.1415926
      pi_8 = dble(pi)
      a=(4./(9.*pi))**ot
      eken=ekn-eftr

c
c      do na = 1, ndat
c         print *, ' atom number =', na
c         do k = 1 , kmax(na)
c            print *, k, r(k,na), rs(k,na)
c         enddo
c       enddo
c
c calculate rs from charge density first time through subroutine:
c remember that rhotot read in input is actually  4*pi*rho*r**2
c
c      print *, nspins, ndat, kmax(1), 'check point'
      if( .not. doit ) goto 100
      do 50 isp=1,nspins
      do 40  nb=1,ndat
      ns=nb+(isp-1)*ndat
      do 30 k=1,kmax(nb)
      rs(k,ns)=((3.*(r(k,nb)**2))/(rs(k,ns)*anns))**ot
c      if(ns.eq.1)
c     &  print *, 'r, rs(k,1) =', r(k,1), rs(k,1)
 30   continue
 40   continue
      rsint(isp)=(3./(pi*4.*rsint(isp)*anns))**ot
 50   continue
c
c
c calculate self-energy
c
 100  do 300 isp=1,nspins
      iskip=.false.
      do 280 nb=1,ndat+1
      ns=nb+(isp-1)*ndat
      if(.not.iskip)then
c
c       compute vxc for atomic and outer spheres
c
	  km=kmax(nb)
      else
c
c       compute vxc for interstitial region
c
	  km=1
      endif
      do 260 k=1,km
      if(.not.iskip)then
	  rsp=rs(k,ns)
      else
	  rsp=rsint(isp)
      endif
      ef=1./(a*rsp)**2
      xk=sqrt(1.0+eken/ef)
      if(eken.lt.0.0) xk=1.0
      wp2=4.*a*rsp/(3.*pi)
      wp=sqrt(wp2)
      xk2=xk*xk
      e=.5*xk2
      xkp=xk+1.
      xkm=xk-1.
      xkpi=1./xkp
      if(nedhlp.eq.2)then
c
c         define variables used by rehr's subroutine rhl
c
	  x_k_0=dble(xk/(a*rsp))
	  r_s=dble(rsp)
	  call rhl(re_vxc,im_vxc,pi_8)
c
c conversion to single precision and ryd
c
	  re_vxc_4 = 2.0*sngl(re_vxc)
c
c conversion to single precision and ryd
c
	  im_vxc_4 = 2.0*sngl(im_vxc)
	  if (iskip) goto 1200
	  v(1,k,ns)=vcoul(k,ns) + re_vxc_4
	  if(imvhl.ne.0)v(2,k,ns)=-im_vxc_4 + gamma
	  goto 1210
1200      vcons(1,isp)=vcoulint(isp) + re_vxc_4
	  if(imvhl.ne.0)vcons(2,isp)=-im_vxc_4 + gamma
1210      continue
	  if(imvhl.ne.0)goto 260
	  goto 210
      end if
c
      flg=alog((xkp+eta2)/(xkm+eta2))
      edxc=(1.-xk2)/xk*.5*flg
      vedx=1.5*wp2*(1.+edxc)
      vsex = 0.0
      vch = 0.0
      if(nedhlp.ne.0) go to 199
      if(nb.eq.1.and.nout.eq.1) go to 199
      vsex=.75*wp2**2/xk*gauss(f2,xkm,xkp,eps)
      vch1=gauss(f3,0.,xkp,eps)
      vch2=gauss(f1,0.,xkpi,eps)
      vch=.75*wp2**2/xk*(vch1+vch2)
  199 continue
      if (iskip) goto 200
      v(1,k,ns)=vcoul(k,ns) - ef*(vedx+vsex+vch)
      goto 210
 200  vcons(1,isp)=vcoulint(isp) - ef*(vedx+vsex+vch)
 210  continue
c
c calculate vim, imaginary part of self energy:
c
      if(imvhl.eq.0) goto 260
      rfct = 1.0 ! renormalizes the imaginary part
c     if((icplxv.eq.1).and.(.not.iskip)) go to 260
      if(wp2.ge.t2/ts2) go to 215
      c1=ts2*wp2/16.
      phi=acos(1.-c1)
      phit=phi*ot
      xkl=1.+2./9.*(-1.+cos(phit)+sqr3*sin(phit))
      goto  216
 215  q=(16.-ts2*wp2)/54.
      del=(ts2*wp2-t2)*wp2/4.
      srdel=sqrt(del)
      v2=-q-srdel
      v2m=abs(-q-srdel)
      xkl=7./9.+ot*((-q+srdel)**ot+sign(1.,v2)*v2m**ot)
 216  xkl2m=xkl**2-1.
      xkmm=1.+sqrt(-2./3.+sqrt(4./9.-4.*wp2+xkl2m**2))
      if(abs(xkl-xkmm).gt.1.e-4)
     x write(iovrho,221) xkl,xkmm,nb,k,rsp
 221  format(' xkl(=',e14.6,') not equal to xkmm(=',e14.6,') for ',
     x ' nb,k,rs=',2i10,e20.6)
      xmm=sqrt(1.+2.*wp)
      if(xkl.lt.xmm) write(iovrho,222) xkl,xmm,nb,k,rsp
 222  format(' xkl(=',e14.6,') less than xmm(=',e14.6,') for ',
     x 'nb,k,rs=',2i10,e20.6)
      if(.not.iskip) v(2,k,ns)=gamma
      if(iskip) vcons(2,isp)=gamma
      if(xk.le.xkl) go to 260
      del1=27.*xk2*wp2-4.*(xk2-ot)**3
      if(del1.ge.0.) write(iovrho,223) nb,k,rsp
 223  format(' discriminant del1 positive for nb,k,rs=',2i10,e20.6)
      xm2=-2*ot+sqrt(4./9.-4.*wp2+(xk2-1.)**2)
      c1=27.*xk2*wp2/(2.*(xk2-ot)**3)
      if(c1.gt.2.) write(iovrho,224) c1,nb,k,rsp
 224  format(' c1(=',e14.6,') gt 2. for nb,k,rs=',2i10,e20.6)
      phi=acos(1.-c1)
      phit=ot*phi
      xk1=(1.-cos(phit)+sqr3*sin(phit))*(xk2-ot)/(3.*xk)
      xk12=xk1*xk1
      an=xm2*(xk12*(1.-3.*wp)+6.*wp*(wp+xk*xk1))
      ad=xk12*(xm2+3.*wp*(xk2-1.+2.*wp))
      if (iskip)  goto 258
      v(2,k,ns)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma
      goto 260
 258  vcons(2,isp)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma
 260  continue
      if(nb.eq.ndat)iskip=.true.
 280  continue
 300  continue
c
c  transfer constant for interstitial potential
c
      vcon(1)=vcons(1,1)
      vcon(2)=vcons(2,1)
c
      return
      end
c
      FUNCTION F1(X)
      COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT
      YI=1./X
      YI2=YI*YI
      WQ=SQRT(WP2+OT*YI2+(.5*YI2)**2)
      T1=.5*(XK+YI)**2-E+WQ
      T2=.5*(XK-YI)**2-E+WQ
      R=(T1*T1+ETA2)/(T2*T2+ETA2)
      F1=.5*ALOG(R)*YI/WQ
      RETURN
      END
      FUNCTION F2(X)
      COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT
      X2=X*X
      WQ=SQRT(WP2+OT*X2+(.5*X2)**2)
      T1=.5-E-WQ
      T2=.5*(XK-X)**2-E-WQ
      T3=T2+2.*WQ
      T4=.5-E+WQ
      R=(T1*T1+ETA2)*(T3*T3+ETA2)/((T2*T2+ETA2)*(T4*T4+ETA2))
      F2=.5*ALOG(R)/(WQ*X)
      RETURN
      END
      FUNCTION F3(X)
      COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT
      X2=X*X
      WQ=SQRT(WP2+OT*X2+(.5*X2)**2)
      T1=.5*(XK+X)**2-E+WQ
      T2=.5*(XK-X)**2-E+WQ
      R=(T1*T1+ETA2)/(T2*T2+ETA2)
      F3=.5*ALOG(R)/(WQ*X)
      RETURN
      END
      FUNCTION GAUSS(F,A,B,EPS)
      LOGICAL MFLAG,RFLAG
      EXTERNAL F
      DIMENSION W(12),X(12)
C
C     ******************************************************************
C
C     ADAPTIVE GAUSSIAN QUADRATURE.
C
C     GAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF
C     THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER
C     EPS.
C
C     ******************************************************************
C
      DATA W
     */1.01228536E-01, 2.22381034E-01, 3.13706646E-01,
     * 3.62683783E-01, 2.71524594E-02, 6.22535239E-02,
     * 9.51585117E-02, 1.24628971E-01, 1.49595989E-01,
     * 1.69156519E-01, 1.82603415E-01, 1.89450610E-01/

      DATA X
     */9.60289856E-01, 7.96666477E-01, 5.25532410E-01,
     * 1.83434642E-01, 9.89400935E-01, 9.44575023E-01,
     * 8.65631202E-01, 7.55404408E-01, 6.17876244E-01,
     * 4.58016778E-01, 2.81603551E-01, 9.50125098E-02/
C
C     ******************************************************************
C
C  START.
C
      GAUSS=0.
      IF(B.EQ.A) RETURN
      CONST=0.005/(B-A)
      BB=A
C
C  COMPUTATIONAL LOOP.
C
    1 AA=BB
      BB=B
    2    C1=0.5*(BB+AA)
         C2=0.5*(BB-AA)
         S8=0.
         DO 3 I=1,4
            U=C2*X(I)
            S8=S8+W(I)*(F(C1+U)+F(C1-U))
    3    CONTINUE
         S8=C2*S8
         S16=0.
         DO 4 I=5,12
            U=C2*X(I)
            S16=S16+W(I)*(F(C1+U)+F(C1-U))
    4    CONTINUE
         S16=C2*S16
         IF( ABS(S16-S8) .LE. EPS*(1.+ABS(S16)) ) GO TO 5
         BB=C1
         IF( 1.+ABS(CONST*C2) .NE. 1. ) GO TO 2
      GAUSS=0.
      CALL KERMTR('D103.1',LGFILE,MFLAG,RFLAG)
      IF(MFLAG) THEN
         IF(LGFILE.EQ.0) THEN
            WRITE(*,6)
         ELSE
            WRITE(LGFILE,6)
         ENDIF
      ENDIF
      IF(.NOT. RFLAG) CALL ABEND
      RETURN
    5 GAUSS=GAUSS+S16
      IF(BB.NE.B) GO TO 1
      RETURN
C
    6 FORMAT( 4X, 'FUNCTION GAUSS ... TOO HIGH ACCURACY REQUIRED')
      END
C
          SUBROUTINE KERSET(ERCODE,LGFILE,LIMITM,LIMITR)
                    PARAMETER(KOUNTE  =  28)
          CHARACTER*6         ERCODE,   CODE(KOUNTE)
          LOGICAL             MFLAG,    RFLAG
          INTEGER             KNTM(KOUNTE),       KNTR(KOUNTE)
          DATA      LOGF      /  0  /
          DATA      CODE(1), KNTM(1), KNTR(1)  / 'C204.1', 100, 100 /
          DATA      CODE(2), KNTM(2), KNTR(2)  / 'C204.2', 100, 100 /
          DATA      CODE(3), KNTM(3), KNTR(3)  / 'C204.3', 100, 100 /
          DATA      CODE(4), KNTM(4), KNTR(4)  / 'C205.1', 100, 100 /
          DATA      CODE(5), KNTM(5), KNTR(5)  / 'C205.2', 100, 100 /
          DATA      CODE(6), KNTM(6), KNTR(6)  / 'C205.3', 100, 100 /
          DATA      CODE(7), KNTM(7), KNTR(7)  / 'C305.1', 100, 100 /
          DATA      CODE(8), KNTM(8), KNTR(8)  / 'C308.1', 100, 100 /
          DATA      CODE(9), KNTM(9), KNTR(9)  / 'C312.1', 100, 100 /
          DATA      CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 /
          DATA      CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 /
          DATA      CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 /
          DATA      CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 /
          DATA      CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 /
          DATA      CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 /
          DATA      CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 /
          DATA      CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 /
          DATA      CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 /
          DATA      CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 /
          DATA      CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 /
          DATA      CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 /
          DATA      CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 /
          DATA      CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100,   0 /
          DATA      CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100,   0 /
          DATA      CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100,   0 /
          DATA      CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100,   0 /
          DATA      CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 /
          DATA      CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 /
          LOGF  =  LGFILE
          IF(ERCODE .EQ. ' ')  THEN
             L  =  0
          ELSE
             DO 10  L = 1, 6
                IF(ERCODE(1:L) .EQ. ERCODE)  GOTO 12
  10            CONTINUE
  12         CONTINUE
          ENDIF
          DO 14     I  =  1, KOUNTE
             IF(L .EQ. 0)  GOTO 13
             IF(CODE(I)(1:L) .NE. ERCODE(1:L))  GOTO 14
  13         KNTM(I)  =  LIMITM
             KNTR(I)  =  LIMITR
  14         CONTINUE
          RETURN
          ENTRY KERMTR(ERCODE,LOG,MFLAG,RFLAG)
          LOG  =  LOGF
          DO 20     I  =  1, KOUNTE
             IF(ERCODE .EQ. CODE(I))  GOTO 21
  20         CONTINUE
          WRITE(*,1000)  ERCODE
          CALL ABEND
          RETURN
  21      RFLAG  =  KNTR(I) .GE. 1
          IF(RFLAG  .AND.  (KNTR(I) .LT. 100))  KNTR(I)  =  KNTR(I) - 1
          MFLAG  =  KNTM(I) .GE. 1
          IF(MFLAG  .AND.  (KNTM(I) .LT. 100))  KNTM(I)  =  KNTM(I) - 1
          IF(.NOT. RFLAG)  THEN
             IF(LOGF .LT. 1)  THEN
                WRITE(*,1001)  CODE(I)
             ELSE
                WRITE(LOGF,1001)  CODE(I)
             ENDIF
          ENDIF
          IF(MFLAG .AND. RFLAG)  THEN
             IF(LOGF .LT. 1)  THEN
                WRITE(*,1002)  CODE(I)
             ELSE
                WRITE(LOGF,1002)  CODE(I)
             ENDIF
          ENDIF
          RETURN
1000      FORMAT(' KERNLIB LIBRARY ERROR. ' /
     +           ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR',
     +           ' ERROR MONITOR. RUN ABORTED.')
1001      FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ',
     +           'CONDITION ',A6)
1002      FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6)
          END
C
      SUBROUTINE ABEND
C
C CERN PROGLIB# Z035    ABEND           .VERSION KERNVAX  1.10  811126

      STOP '*** ABEND ***'
      END
C====================================================================
C
      SUBROUTINE GET_CORE_STATE
C
      IMPLICIT REAL*8(A-H,O-Z)
C
c      INCLUDE 'mscalc.inc'
      include 'msxas3.inc'
c
c	############ I include the file msxasc3.inc
c
	  include 'msxasc3.inc'

cman
      integer rd_
      PARAMETER(RD_=440)
C





      COMMON/APARMS2/XV2(NAT_),YV2(NAT_),ZV2(NAT_),RS2(NAT_),
     U  ALPHA2(NAT_),REDF2(NAT_),Z2(NAT_),Q2(NAT_),QSPNT2(2),
     U  QINT2(2),
     U  WATFAC(NAT_),ALPHA02,VOLINT2,OVOUT2,RMXOUT2,NSYMBL2(NAT_),
     U  NZ2(NAT_)

	  CHARACTER*8 NSYMBL2

C

c     #############common/pot_type modified to include the core states
c     #############to the two hole in the final state of Auger decay i_
c	##############common /pdqi modified to consider also the two auger wav
C
C	common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
C     *	i_absorber_hole2,i_norman,i_alpha,
C     1    i_outer_sphere,i_exc_pot,i_mode
C

      COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1,
     * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA,
     1 I_OUTER_SPHERE,I_EXC_POT,I_MODE




C

      COMMON/PDQI/RPI(RD_),RPI1(RD_),RPI2(RD_)
      REAL*4 RPI,RPI1,RPI2
	  INTEGER I_HOLE
c	  INTEGER HOLE
C
      DIMENSION R(440),P_NK(440),P_NK1(440),P_NK2(440),ICHG(12)
C
      DATA THIRD,XINCR,CTFD
     &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/
C
      DATA KMX,MESH/RD_,440/
C
      IZ=NZ2(I_ABSORBER+I_OUTER_SPHERE)
c	open(unit=697,file='get1.dat',status='unknown')
      if(iz.eq.0) then 
         iz=1  ! in case an empty sphere is the first atom
         write(6,*) ' warning check! empty sphere is the first atom '
      endif

      I_RADIAL=I_ABSORBER_HOLE
C
C	 ######### Modified to consider also the Auger calculation
C
      I_RADIAL1=I_ABSORBER_HOLE1
	  I_RADIAL2=I_ABSORBER_HOLE2
      I_HOLE=0
      NCUT=1
C
C     SET-UP HERMAN-SKILLMAN MESH FOR Z OF ABSORBING ATOM
C
      MESH=MESH/NCUT
      H=XINCR*CTFD/(DFLOAT(IZ)**THIRD)*NCUT
      R(1)=H
      DO 10 N=1,12
10    ICHG(N)=(40/NCUT)*N
      N=1
      DO 20 K=2,MESH
	  R(K)=R(K-1)+H
	  IF (K.LT.ICHG(N)) GO TO 20
	  H=H+H
	  N=N+1
20    CONTINUE
C
C***  COMPUTE FUNCTION P_NK ON RADIAL MESH R
C
      CALL ATOM_SUB(IZ,I_HOLE,R,P_NK,1,I_RADIAL,0.d0)
C


C
C***  PASS VIA COMMON BLOCK THE FIRST KMX POINTS. NOTE THAT
C     P_NK IS NOT NORMALIZED SINCE Q_NK MUST ALSO BE CONSIDERED.
C     ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION
C     R*R_L = P_NK.  THIS RELATION HOLDS IN THE LIMIT C --> INFINITY.
C
      DO 30 I=1,KMX
	  RPI(I)=SNGL(P_NK(I))


30    CONTINUE


c
c     ############# modified to make the calculations also for the two
c     ############# wave functions necessary for the auger decay calcula
c     ############# these two wavefunction are calculated with Z+1 appro
c     ############# with one hole=to the deeper first core hole (hole)
c
	  IF (calctype.EQ.'aed') THEN


	  I_HOLE=HOLE2


          CALL ATOM_SUB(IZ,I_HOLE,R,P_NK1,1,I_RADIAL1,0.d0)
	  CALL ATOM_SUB(IZ,I_HOLE,R,P_NK2,1,I_RADIAL2,0.d0)
	  DO 3011 I=1,KMX
	  RPI1(I)=SNGL(P_NK1(I))
	  RPI2(I)=SNGL(P_NK2(I))




3011    CONTINUE





	   END IF
C

      RETURN
      END
c
C      
      SUBROUTINE COREWF(NAS,IZC,HOLE)
C
      INCLUDE 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
C
C
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
      COMMON /LLM/ ALPHA, BETA
C
      COMMON/PDQIX/RPIX(RDX_), FNISX
      COMPLEX RPIX
C
      DOUBLE PRECISION CWFX(RDX_),RXD(RDX_),XION
      COMPLEX RIDX(RDX_),DX
C
      INTEGER HOLE
C
      DATA THIRD,XINCR,CTFD
     &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/
C
C
      IZ=IZC
      ITYRADIAL=HOLE
C
      XION=0
      ITYHOLE=0
C
      KMXN = KMX(NAS)
      DO I = 1, KMXN
         RXD(I) = DBLE(RX(I,NAS))
      ENDDO
c      write(6,*) ' corewf: kmx = ', kmxn
C
C***  COMPUTE FUNCTION P_NK ON RADIAL MESH RD AND LL MESH RX
C
      XION = 0.D0
      CALL GET_INTRP_CORE(IZ,ITYHOLE,ITYRADIAL,XION,CWFX,RXD,KMXN)
C
C***  NOTE THAT CWFX=P_NK (UPPER COMPONENT OF DIRAC EQU.) IS NOT NORMALIZED 
C     SINCE ALSO Q_NK (LOWER COMPONENT) MUST ALSO BE CONSIDERED.
C     ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION R*R_L = P_NK.  
C     THIS RELATION HOLDS IN THE LIMIT C --> INFINITY.
c
c.....Find normalization constant in ll-mesh. 
c
      do i = 1, kmxn
         xi = sngl(cwfx(i))
	   rpix(i)=cmplx(xi)
c         write(6,*) rx(i,nas), xi
      enddo

c      dh = x(2,n) - x(1,n)
c      write(6,*) ' dh ', dh, hx(n), alpha, beta
      n = nas
      id = 1
      do k = 1,kmxn
        ridx(k)=rpix(k)**2*rx(k,n)/(alpha*rx(k,n) + beta)
      enddo
      call defint0(ridx,hx(n),kmxn,dx,id)
      fnisx=sqrt(real(dx))
c
c      write(6,*) 'corewf: fnisx = ', fnisx
c
      do k=1,kmxn
         rpix(k)=rx(k,n)**2*rpix(k)/fnisx
      enddo
c
      RETURN
      END
C
C
C***********************************************************************
C     
      subroutine get_intrp_core(iz,ihole,i_radial,xion,cwfx,rx,kmxn)
c
c
      implicit real*8(a-h,o-z)
c
c
      parameter ( mp = 251, ms = 30 )
c
      character*40  title
c
      common/mesh_param/jlo
      common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy
c
c     For interpolation on rx mesh
c
      dimension rx(kmxn), cwfx(kmxn)
      dimension p(0:mp), rat(0:mp), r(mp)
c
c
      dimension dum1(mp), dum2(mp)
      dimension vcoul(mp), rho0(mp), enp(ms)
c
      title = ' '
c
      ifr=1
      iprint=0
C
      amass=0.0d0
      beta=0.0d0
c
c There are no nodes in relativistic radial charge density
c
      small=1.0d-11
c                    !Hence a lower limit on rho(r) can be used.
      dpas=0.05d0
      dr1=dexp(-8.8d0)
      dex=exp(dpas)
      r_max=44.447d0
c
      radius=10.0d0
c
      xion=0.d0
c
c     compute relativistic Hartrer-Fock-Slater charge density (on log mesh)
c     
      call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint,
     1                   vcoul, rho0, dum1, dum2, enp, eatom)
c
c     compute radial log mesh (see subroutine phase in J.J. Rehr's program
c     FEFF.FOR)
c
      ddex=dr1
      do 10 i=1,251
	  r(i)=ddex
	  ddex=ddex*dex
10    continue
c
c     write(6,*) ' interpolating on rx mesh '
c     Dump upper componen of Dirac wf into p
c
      p(0) = 0.d-8
      rat(0) = 0.d-8
      do i = 1, 251
         p(i) = dgc(i,i_radial)
         rat(i) = r(i)
c         write(6,*) rat(i), p(i)
      enddo
c
      do  i=1,kmxn
	   if(rx(i).gt.r_max) goto 60
c          find nearest points
c        initialize hunting parameter (subroututine nearest)
c
	   jlo=1
	   call nearest(rat,252,rx(i),
     1     i_point_1,i_point_2,i_point_3)
c
           i_point_1 = i_point_1 -1
           i_point_2 = i_point_2 -1
           i_point_3 = i_point_3 -1
c
c          interpolate wavefunction
c
	   call interp_quad( rat(i_point_1),p(i_point_1),
     1                     rat(i_point_2),p(i_point_2),
     1                     rat(i_point_3),p(i_point_3),
     1                     rx(i),cwfx(i) )
      enddo
c
60    continue
c
      return
      end
C
C
C***********************************************************************
c
      subroutine input_cont(id,potype,potgen,lmax_mode,lmaxt)
c
      include 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
c  modified input subroutine for (optionally) complex potentials
c
      common /dens/ irho,rhotot(rd_,sd_),rhoconi(2),
     $ vcoul(rd_,sd_),vcoulint(2)

	common/auger/calctype,expmode,edge1,edge2
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex vcons
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      character*8 name0 ,nsymbl
	  character*3 calctype, expmode
          character*5 potype
          character*2 potgen
	  character*2 edge1,edge2
c
ctn   common block from msxas3.inc
c    .... redundant variables with param....
c
      common/continuum/xemin,xemax,xdelta,xcip,xgamma,xeftri,iexcpot
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
       complex vcon,xe,ev
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1 i_outer_sphere,i_exc_pot,i_mode
c                                    !pass pots and rhos to this sub
      common/out_ascii/iout_ascii
c
      common/lparam/lmax2(nat_),l0i
c
      logical check
c
      character*65 exc_pot_label(5)
      character*65 exc_pot_label_extnl(6)
      data exc_pot_label/
     &'generating final potential (x_alpha exchange)',
     &'generating final potential (real dirac-hara exchange)',
     &'generating final potential (real hedin-lundqvist exchange)',
     &'generating final potential (complex dirac-hara exchange)',
     &'generating final potential (complex hedin-lundqvist exchange)'
     &/
      data exc_pot_label_extnl/
     &'potential from extnl file (x_alpha exchange)',
     &'potential from extnl file (real dirac-hara exchange)',
     &'potential from extnl file (real hedin-lundqvist exchange)',
     &'potential form extnl file (complex dirac-hara exchange)',
     &'potential form extnl file (complex hedin-lundqvist exchange)',
     &'potential form extnl file (potential from lmto calculation)'
     &/
c
      data lunout/7/, ot/.333333/, pi/3.1415926/
c
c**** definitions for this version of continuum
c
      iout=2
      nspins=1
      iout_ascii=2
c                   !output check files
      iovrho=13
      iosym=14
c
c***  define state dependent parameters
c     read cip (core ionization potential),emin,emax and deltae
c     in order to check array sizes.
ctn          read(5,*) cip,emin_exc,emax_exc,de_exc
ctn          read(5,*) i_exc_pot,gamma,eftri
ctn initializes from common continuum
c
      emin_exc=xemin
      emax_exc=xemax
      de_exc=xdelta
      cip=xcip
      gamma=xgamma
      eftri=xeftri
      i_exc_pot=iexcpot
ctn          write(*,*)'dans inpot_cont:'
ctn          write(*,*) cip,emin_exc,emax_exc,de_exc
ctn          write(*,*) i_exc_pot,gamma,eftri
c
c      de_exc = 0.05
c      con = 27.2116/7.62
c      wvb = sqrt(con*emin_exc)
c      wve = sqrt(con*emax_exc)
c      kxe = nint((wve-wvb)/0.05 + 1.)
c          kxe = nint(alog(emax_exc - emin_exc + 1.)/de_exc + 1.)
       kxe = nint((xemax-xemin)/xdelta + 1.)
          if(kxe.gt.nep_)then
c              write(lunout,730) kxe
              write(6,730) kxe 
730           format(//,
     &        ' increase the dummy dimensioning variable, nep_. ',
     &        /,'it should be at least equal to: ', i5,/)
              write(6,'(3f10.5)') xemax, xemin, xdelta
              call exit
          end if
c                         !define absorbing atom
	  nas=i_absorber
c
          emin=emin_exc
          emax=emax_exc
          de=de_exc
	  if(i_exc_pot.eq.1)then
c                                      !define exchange potential types
              nedhlp=0
              irho=0
              imvhl=0
              if(i_mode.eq.1)then

                  print 745,exc_pot_label_extnl(1)
              else
                  print 745,exc_pot_label(1)
              end if
745           format(2x,a65)
          else if(i_exc_pot.eq.2)then
              nedhlp=1
              irho=2
              imvhl=0
              if(i_mode.eq.1)then
                  print 745,exc_pot_label_extnl(2)
              else
                  print 745,exc_pot_label(2)
              end if
          else if(i_exc_pot.eq.3)then
c
c	      nedhlp=2   !use rehr's approximation to re(vxc)
c
              nedhlp=0   !use exact integral expression for re(vxc)
              irho=2
              imvhl=0
              if(i_mode.eq.1)then
                  print 745,exc_pot_label_extnl(3)
              else
                  print 745,exc_pot_label(3)
              end if
          else if(i_exc_pot.eq.4)then
              nedhlp=1
              irho=2
              imvhl=1
              if(i_mode.eq.1)then
                  print 745,exc_pot_label_extnl(4)
              else
                  print 745,exc_pot_label(4)
              end if
          else if(i_exc_pot.eq.5) then
c
c	      nedhlp=2  !use rehr's approximation to re(vxc) and im(vxc)
c
              nedhlp=0  !use exact integral expression for vxc
c
	      irho=2
              imvhl=1
              if(i_mode.eq.1)then
                  print 745,exc_pot_label_extnl(5)
              else
                  print 745,exc_pot_label(5)
              end if
          else if(i_exc_pot.eq.6) then
              irho = 0
              print 745, exc_pot_label_extnl(6)
c
          end if
c

          if(irho.ne.0)then
              i_alpha=0
          else
              i_alpha=1
          end if
          if (i_mode.eq.1)then
c             call get_external_pot
             if(potype.eq.' lmto') print 745, exc_pot_label_extnl(6)
             call get_ext_pot_lmto(potype)
          else
              call vgen
          end if
c
c...  calculate fermi level eftr = vcint + kf**2 - .72*3./2.*kf/pi*2.
c
      if (irho.eq.0) then
          eftr = real(vcons(1))/2.
      else
          fmkf = (3.*pi**2*rhoconi(1))**ot
          eftr = real(vcons(1)) + fmkf*(fmkf - 2.16/pi)
      endif
c
      if (eftri.ne.0.0)  eftr = eftri
c
      if (lmax_mode.eq.0) then
c          write(lunout,741)
          write(6,741) lmaxt
741       format(/,1x,' lmax constant on each atom equal to: ', i5)
c
      else if (lmax_mode.eq.1) then
c          write(lunout,741)
          write(6,742) emax
742       format(/,1x,' lmax assignment based on',
     &    ' lmax = r_mt * k_max + 2',/, 
     &    '   at energy emax =',f12.6)
c
      else
c          write(lunout,741)
          write(6,743) 
743       format(/,1x,' lmax assignment based on',
     &    ' l_max = r_mt * k_e + 2',/, 
     &    '  where e is the running energy')
c
      endif

c     ###### problem: for low energy continuum auger electron it can happen
c            that lmax2 is less than the higher value of the orbital mom
c            allowed for the continuum auger electron; thus I set the lm
c            value equal to the lmax_ value given in the include file
c            msxas3.inc
c
      l_max = 0
c
     	if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or.
     &  (calctype.eq.'rex').or.(calctype.eq.'led')) then
c
c                               !assign lmax values and check max(lm)
c
        if (lmax_mode.eq.0) then
	    do i=1,ndat
              lmax2(i) = lmaxt
c              write(lunout,842) lmax2(i),i
              write(6,842) lmax2(i),i
842           format(10x,' lmax =', i3, ' on center =', i3)
          enddo
c
        else if (lmax_mode.eq.1) then
	    do i=1,ndat
              lmax2(i) = nint(rs(i)*sqrt(emax)) + 2
              if(l_max.lt.lmax2(i)) l_max=lmax2(i)
c              write(lunout,843) lmax2(i),i
              write(6,843) lmax2(i),i
843           format(10x,' optimal lmax =', i3, ' on center =', i3)
          enddo
c
        else
	    do i=1,ndat
              lmax2(i) = nint(rs(i)*sqrt(emax)) + 2
              if(l_max.lt.lmax2(i)) l_max=lmax2(i)
              if(i.eq.ndat) then
c                 write(lunout,844) 
                 write(6,844)
              endif   
844       format(1x,' optimal lmax chosen according to the running',
     &           ' energy e for each atom')
          enddo
c
        endif
c
c...give warning for insufficient lmax dimensions
c
        check = .false.
        if(lmax_mode.ne.0) then
          if(l_max.gt.lmax_) then
c manolo
              check=.true.
c              write(lunout,746)l_max
              write(6,746)l_max
746           format(///,
     &        '  increase the dummy dimensioning variable, lmax_. ',
     &        /,' it should be at least equal to: ', i5)
              call exit
          endif
        else
          if(lmaxt.gt.lmax_) then
c manolo
              check=.true.
c              write(lunout,746)lmaxt
              write(6,746)lmaxt
              call exit
          endif
        endif
c
c
	else
c
c     ##### auger part:
c
	  do  i=1,ndat
	    lmax2(i)=lmax_
          l_max=lmax_
        enddo

	end if
c
c...set lmax equal on any atom if check='true'
c
     	if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or.
     &  (calctype.eq.'rex').or.(calctype.eq.'led')) then
        if(check) then
	    do i=1,ndat
	      lmax2(i) = l_max
	      write(6,7422)lmax2(i),i
7422           format(10x,'   lmax =', i3, ' on center =', i3)
          enddo
c
          write(6,*) '  '
          write(6,*)' ** input_cont warning **'
          write(6,*)'      -> estimated l_max is greater than lmax_'
          write(6,*)'         computation proceeds with l_max=lmax_'
          write(6,*)'         but convergence is not guaranteed'
c
        endif
c
      else
c	    do i=1,ndat
c	      lmax2(i) = l_max
c	      write(6,7422)lmax2(i),i
c          enddo
      endif
c
      write(6,*)

c
c
      write (iovrho,408) nedhlp,irho,imvhl,eftr,gamma
  408 format(' nedhlp=',i5,' irho=',i5,' imvhl=',i5,
     x /,'  eftr = ',f10.6,' gamma =',f10.6)
      write (iovrho,409) nat,ndat,nspins,
     1 inmsh,inv,inrho,insym,iovrho,iosym
  409 format(9i5)
c
      write(iovrho,110) nat
      if (iovrho .ne. 6 ) write(6,110) nat
  110 format(/,2x,18hnumber of centers=,i5,/)
c
c     store coulomb potential if energy dependent exchange is to be used
c
      if(irho.ne.0)then
      do 4304 isp=1,nspins
          do 4303 nb=1,ndat
              ns=nb+(isp-1)*ndat
              do 4302 k=1,kmax(nb)
                  vcoul(k,ns)=v(1,k,ns)
4302          continue
4303      continue
          vcoulint(isp)=real(vcons(isp))
4304  continue
      end if
c
c check for consistency of input data:
c
      write(iovrho,111)
  111 format(30x,10hatom   no.,12x,8hposition,14x,13hradius     eq  )
      write(iovrho,112) (i,nsymbl(i),nz(i),xv(i),yv(i),zv(i),rs(i),
     1 neq(i),i=1,nat)
      write (iovrho,112)
  112 format(26x,i3,2x,a4,i6,4f10.4,i6)
      do 211 i=1,nat
      if(rs(i).lt.0.0) then
        write(iovrho,201) i, rs(i)
        write(6,201) i, rs(i)
	call exit
      endif
      if(neq(i).eq.0)go to 210
      if(neq(i).ge.i) go to 213
  210 i1=i+1
      if(i1.gt.nat) go to 5000
      go to 2135
  213 write(iovrho,202) neq(i), i
      write(6,202) neq(i), i
      call exit
 2135 do 211 j=i1,nat
      rij = sqrt((xv(j)-xv(i))**2+(yv(j)-yv(i))**2+(zv(j)-zv(i))**2)
      rsum = rs(i)+rs(j)
      rdif = rsum-rij
      if (rsum.gt.rij) go to 215
      go to 211
  215 write (iovrho,200) i,j,rsum,rij,rdif
  200 format(' spheres',2i5,'  overlap  ',3f12.6)
  201 format(' sphere',i5,' has negative rs', f12.6)
  202 format(' neq(i)',i5,' for atom i=', i5,' is inconsistent' )
  211 continue
c
 5000 return
      end
c
C
      SUBROUTINE GET_EXTERNAL_POT
C
c      INCLUDE 'mscalc.inc'
      include 'msxas3.inc'
      INTEGER   AT_,D_,RD_,SD_
      PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1)

      COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2),
     $ VCOUL(RD_,SD_),VCOULINT(2)
C
      COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_),
     $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_)
      COMPLEX VCONS
C
      COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM,
     1 IMVHL,NEDHLP
C
      CHARACTER*8 NAME0 ,NSYMBL
C
      COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS,
     1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_),
     3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_),
     4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE
       COMPLEX VCON,XE,EV
C
      COMMON/DIMENS2/NAT2,NDAT2
C
cman      DATA INV,INRHO/2,3/
      inv=2
      inrho=3
C
      NAT = NAT2 - 1
      NDAT = NDAT2 - 1
C
      OPEN(INV, status='unknown')
      DO 4444 N=1,NAT
      READ (INV,311)  NSYMBL(N),NEQ(N), NZ(N),IDUMMY,KMAX(N),
     1  KPLACE(N),XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC
311   FORMAT (1X,A4,3I2,2I4,5F11.6,T76,I5)
      Z(N)=NZ(N)
      IF(NEQ(N).NE.0) GO TO 4444
C
C RECONSTRUCT RADIAL MESH
C
      READ (INV,308)   (ICHG(I,N),I=1,10),NC
  308 FORMAT(10I5,T76,I5)
      KX=KMAX(N)
      READ (INV,319)  NC,(R(I,N),I=1,5)
      H(N)=R(2,N)-R(1,N)
      HH=H(N)
      ICH=1
      KICH=ICHG(ICH,N)
      DO  133  K=3,KX
      R(K,N)=R(K-1,N)+HH
      IF (K.LT.KICH) GO TO 133
      ICH=ICH+1
      KICH=ICHG(ICH,N)
      HH=HH+HH
133   CONTINUE
  319 FORMAT(T76,I5,T2,1P5E14.7)
      H(N)=R(2,N)-R(1,N)
      NS=N
C
      DO 142 ISPIN=1,NSPINS
      DO 141 K=1,KX,5
      KCARD=MIN0(KX,K+4)
      READ (INV,319) NC,(V(1,I,NS),I=K,KCARD)
      DO 7474 KKK=K,KCARD
 7474 V(2,KKK,NS) = 0.000
  141 CONTINUE
  142 NS=NS+NDAT
C
      IF(IRHO.EQ.0) GOTO  4444
      OPEN(INRHO, status='unknown')
      DO 423 ISPIN=1,NSPINS
      NS=N+(ISPIN-1)*NDAT
      DO 424 K=1,KX,5
      KCARD=MIN0(KX,K+4)
      READ(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD)
  424 CONTINUE
  423 CONTINUE
 4444 CONTINUE
C
C READ INTERSTITIAL V AND RHO
C
      READ (INV,319) NC,(VCONS(ISPIN),ISPIN=1,NSPINS)
      IF(IRHO.NE.0)READ (INRHO,319) NC,(RHOCONI(ISPIN),ISPIN=1,NSPINS)
C
	  WRITE(6,120) INV
  120 FORMAT ('  STARTING   POTENTIAL   READ IN FROM FILE',I4)
      IF( IRHO .NE. 0) WRITE(6,121) INRHO
  121 FORMAT ('  STARTING CHARGE DENSITY READ IN FROM FILE',I4)
C
      REWIND(INV)
      REWIND(INRHO)
C
      RETURN
      END
C
      SUBROUTINE GET_EXT_POT_LMTO(potype)
C
      include 'msxas3.inc'
C
      INTEGER   AT_,D_,RD_,SD_
      PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1)
C
      PARAMETER (MRP = 500)
C
      COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2),
     $ VCOUL(RD_,SD_),VCOULINT(2)
C
      COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_),
     $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_)
      COMPLEX VCONS
C
      COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM,
     1 IMVHL,NEDHLP
C
      CHARACTER*8 NAME0 ,NSYMBL
C
      COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS,
     1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_),
     3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_),
     4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE
       COMPLEX VCON,XE,EV
C
      COMMON/DIMENS2/NAT2,NDAT2
C
      common/aparms/xa(natoms),ya(natoms),za(natoms),zat(natoms),
     &  nsymbla(natoms),nzeq(natoms),neqa(natoms),ncores(natoms),
     &  lmaxat(natoms)
C
      REAL*8 xa,ya,za,zat
      CHARACTER*8 nsymbla
C
      DIMENSION RL(MRP,D_), VCL(MRP,SD_), RHOL(MRP,SD_), HL(D_),
     &          VLMTO(MRP,SD_), KMXP(SD_), KPLP(SD_), RSL(SD_),
     &          NPAC(-10:100), NZL(D_), KMX(SD_), ICHGL(SD_,D_)
C
      DIMENSION RHS(MRP,D_), VHS(MRP,SD_), RHOHS(MRP,SD_)
C
      REAL*8 RL, VCL, RHOL, HL, VLMTO, RSL, RHS, VHS, RHOHS,
     &       HR, VINT, RHOINT, DVT, DVTRHOINT
C
      EXTERNAL NEAREST
C
      CHARACTER*5 POTYPE
      CHARACTER*5 CHECK
C
      DATA THIRD,XINCR,CTFD
     &/0.33333333,0.0025E0,0.88534137E0/
C
      INP=2
C
      NDUMMY = 0
      NSPINS = 1
      NAT = NAT2 - 1
      NDAT = NDAT2 - 1
C
      OPEN(INP, file='data/inpot.ext',status='unknown')
C
C  Initialize to zero the vector indicating for which atomic species
C  the lmto data have been already interpolated. Positions from 1 to
C  100 indicates physical atoms, from 0 to -1010 empty inequivalent
C  spheres
C
      DO N = -10, 100
	NPAC(N) = 0
      ENDDO
C
C   VCOULINT : interstitial Coulomb potential in Ry
C   RHOCONI  : interstitial charge density in Ry
C   VCLMTO   : intsrstitial LMTO potential in Ry
C
      READ(INP,*) VCOULINT(1), RHOCONI(1), VCLMTO
C
      NES=1
C
      DO N=1,NDAT
C
       READ(INP,*,END=50) NZL(N), KMX(N), RSL(N)
       WRITE(6,*) 'N=',N,'ZATL(N)=', NZL(N),'KMX(N)=',KMX(N),
     &             'RS(N)=',RSL(N)
       IF (KMX(N).GT.MRP) THEN
          WRITE(6,*) '   '
          WRITE(6,*) '   '
          WRITE(6,*)' MRP =', MRP,' TOO SMALL, INCREASE UP TO ', KMX(N)
          WRITE(6,*) '   '
          WRITE(6,*) '   '
          CALL EXIT
       ENDIF
C
       IF(NZL(N).NE.0) THEN
         NPAC(NZL(N)) = N
C         WRITE(6,*) 'N, NZL(N), NPAC(NZL(N))', N, NZL(N) , NPAC(NZL(N))
       ELSE
	 NES=NES-1
	 NPAC(NES)=N
C       WRITE(6,*) 'N, NZL(N), NES, NPAC(NES)', N,NZL(N),NES,NPAC(NES)
       ENDIF
C
C      NOTE: COULOMB AND LMTO POTENTIALS ARE MULTIPLIED BY RL
C
       DO K = 1, KMX(N)
         READ(INP,*) RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N)
C         WRITE(6,*) K, RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N)
       ENDDO

C
C      SET-UP HERMAN-SKILLMAN MESH FOR ATOM OF ATOMIC NUMBER Z
C
       MESH=400
       NCUT=1
       MESH=MESH/NCUT
       IF(NZL(N).EQ.0) THEN
          HL(N)=DBLE(XINCR*CTFD*NCUT)
       ELSE
          HL(N)=DBLE(XINCR*CTFD/(FLOAT(NZL(N))**THIRD)*NCUT)
       ENDIF
       HR = HL(N)
       RHS(1,N)=HR
       DO 10 K=1,12
10      ICHGL(K,N)=(40/NCUT)*K
       I=1
       DO 20 K=2,MESH
	  RHS(K,N)=RHS(K-1,N)+HR
	  IF (K.LT.ICHGL(I,N)) GO TO 20
	  HR=HR+HR
	  I=I+1
20     CONTINUE
C
C      FIND KMAX(N) IN THE H-S MESH ACCORDING TO RS(N)
C
       KMXP(N) = 0
       KPLP(N) = 0
       DO K = 1, MESH
        IF (RHS(K,N).GT.RSL(N)) GO TO 40
       ENDDO
 40    KPLP(N) = K - 1
       KMXP(N) = K + 2
C
       WRITE(6,*) 'ATOMIC SPECIES, HS KPLACE AND KMAX'
       WRITE(6,*) 'N=',N, 'KPLP(N)= ',KPLP(N), ' KMXP(N)= ', KMXP(N)
C       WRITE(6,*) 'RHSMAX=', RHS(400,N), 'RSL(N) =', RSL(N)
C
        DO I=1,KMXP(N)
C        FIND NEAREST POINTS
C        INITIALIZE HUNTING PARAMETER (SUBROUTUTINE NEAREST)
C
         CALL NEAREST(RL(1,N), KMX(N), RHS(I,N), IP1, IP2, IP3)
C
         IF(IRHO.NE.0) THEN
C
C        INTERPOLATE COULOMB POTENTIAL
C
         CALL INTERP_QUAD( RL(IP1,N),VCL(IP1,N),RL(IP2,N),VCL(IP2,N),
     &                     RL(IP3,N),VCL(IP3,N),RHS(I,N),VHS(I,N))
C
C        INTERPOLATE CHARGE DENSITY
C
         CALL INTERP_QUAD( RL(IP1,N),RHOL(IP1,N),RL(IP2,N),
     &                      RHOL(IP2,N),RL(IP3,N),RHOL(IP3,N),
     &                      RHS(I,N),RHOHS(I,N))
         ELSE
C
C        INTERPOLATE LMTO POTENTIAL
C
         CALL INTERP_QUAD( RL(IP1,N),VLMTO(IP1,N),
     &                      RL(IP2,N),VLMTO(IP2,N),
     &                      RL(IP3,N),VLMTO(IP3,N),RHS(I,N),VHS(I,N))
         ENDIF
        ENDDO
C
       WRITE(6,*) 'INTERPOLATED VALUES ON HS MESH'
C
       DO I = 1, KMXP(N)
C          WRITE(6,*) I, RHS(I,N), VHS(I,N), RHOHS(I,N)
          IF(RHOHS(I,N).LT.0.D0) THEN
             WRITE(6,*) ' WARNING: DENSITY INTERPOLATED TO NEGATIVE',
     &                  ' VALUES AT RHS =', RHS(I,N),' FOR ATOM',
     &                  ' NUMBER N =', N
             CALL EXIT
          ENDIF
       ENDDO
C
C......TEST LAST THREE INTERPOLATED VALUES
C
        SMALL=0.005
C
        DO I = KPLP(N) + 1, KMXP(N)
         KP = KMX(N)
C
         IF(IRHO.NE.0) THEN
           CALL DINTERP(RL(KP-5,N),VCL(KP-5,N),5,RHS(I,N),VINT,DVT,
     &                .TRUE.)
           CALL DINTERP(RL(KP-5,N),RHOL(KP-5,N),5,RHS(I,N),RHOINT,
     &                DVTRHOINT,.TRUE.)
           IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN
             CHECK='OK'
             WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I,
     &                  'FOR  VC ', CHECK
           ELSE
             CHECK='NOTOK'
             WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I,
     &                  'FOR  VC ', CHECK
             WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N)
           ENDIF
C
           IF(DABS(RHOHS(I,N)-RHOINT).LT.DBLE(SMALL)) THEN
             CHECK='OK'
             WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I,
     &                  'FOR  RHO ', CHECK
           ELSE
            CHECK='NOTOK'
            WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I,
     &                  'FOR  DENSITY RHO ', CHECK
            WRITE(6,*) I, RHS(I,N), RHOINT, RHOHS(I,N)
           ENDIF
C
         ELSE
C
         CALL DINTERP(RL(KP-5,N),VLMTO(KP-5,N),5,RHS(I,N),VINT,DVT,
     &                .TRUE.)
           IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN
             CHECK='OK'
             WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I,
     &                  'FOR  VLMTO ', CHECK
           ELSE
             CHECK='NOTOK'
             WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I,
     &                  'FOR  VLMTO ', CHECK
             WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N)
           ENDIF
C
         ENDIF
C
        ENDDO
C
C
      ENDDO
C
 50   CONTINUE
C
      CLOSE(2)
C
C       write(6,*) npac(22), npac(8), npac(0), npac(-1)
      DO 60 I=1,NAT
       XV(I) = SNGL(XA(I+1)) - SNGL(XA(2))
       YV(I) = SNGL(YA(I+1)) - SNGL(YA(2))
       ZV(I) = SNGL(ZA(I+1)) - SNGL(ZA(2))
       NSYMBL(I) = NSYMBLA(I+1)
       NEQ(I) = NEQA(I+1)
c       write(6,*) NEQ(I), NSYMBL(I)
       IF(NEQ(I).NE.0) NEQ(I) = NEQ(I) - 1
       NZ(I) = NZEQ(I+1)
C      N = NPAC(NZ(I))
       IF(NZ(I).NE.0) THEN
C
         N = NPAC(NZ(I))
C        WRITE(6,*) 'N, NZ(I), NPAC(NZ(I))', N, NZ(I), NPAC(NZ(I))
C
       ELSE
C
         IF(NSYMBL(I).EQ.'ES') THEN
           N=NPAC(0)
         ELSE
	   NES=ICHAR('0')-ICHAR(NSYMBL(I)(2:2))
	   N=NPAC(NES)
C          WRITE(6,*) ICHAR('0'),ICHAR(NSYMBL(I)(2:2))
C	   WRITE(6,*) ' NES = ',NES, ' N = ', N
         ENDIF
C
       ENDIF
       KPLACE(I) = KPLP(N)
       KMAX(I) = KMXP(N)
       RS(I) = REAL(RSL(N))
       EXFACT(I) = 0.0
C
       IF(NEQ(I).NE.0) GO TO 60
C
       H(I) = REAL(HL(N))
       DO K = 1,10
          ICHG(K,I) = ICHGL(K,N)
       ENDDO
       DO K = 1, KMAX(I)
          R(K,I) = SNGL(RHS(K,N))
          V(2,K,I) = 0.0
          IF(IRHO.NE.0) THEN
             V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N))
             RHOTOT(K,I) = SNGL(RHOHS(K,N))
          ELSE
             V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N))
          ENDIF
       ENDDO
       IF(IRHO.NE.0) THEN
          VCONS(1) = CMPLX(VCOULINT(1))
       ELSE
          VCONS(1) = CMPLX(VCLMTO)
       ENDIF
 60   CONTINUE
C
C.....WRITE OUT POTENTIAL AND DENSITY FILES
C
      IF (potype.EQ.' lmto') THEN
	      OPEN (19, FILE = 'div/LMTO.POT', STATUS = 'unknown')
      ELSE
	      OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown')
	      OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown')
      ENDIF
C
      INV = 20
      IF (potype.EQ.' lmto') INV = 19
      INRHO= 9
      NST=1
      NC=2
      DO 4401 N=NST,NAT
      WRITE(INV,311) NSYMBL(N),NEQ(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N),
     1               XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC
  311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5)
      NC=NC+1
      IF(NEQ(N).NE.0) GO TO 4401
      WRITE(INV,308) (ICHG(I,N),I= 1,10),NC
  308 FORMAT(10I5,T76,I5)
      NC=NC+1
      WRITE(INV,319) NC,(R(I,N),I=1,5)
  319 FORMAT(T76,I5,T2,1P5E14.7)
      NS=N
      NC=NC+1
      KX=KMAX(N)
      NS = N
      DO 142 ISPIN=1,NSPINS
      DO 141 K=1,KX,5
      KCARD=MIN0(KX,K+4)
      WRITE(INV,319) NC,(V(1,I,NS),I=K,KCARD)
  141 NC=NC+1
  142 NS=NS+NDAT
      NS=N
      IF (potype.NE.' lmto') THEN
         DO 555 ISPIN=1,NSPINS
	 DO 551 K=1,KX,5
	 KCARD=MIN0(KX,K+4)
	 WRITE(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD)
  551    NC=NC+1
  555    NS=NS+NDAT
      ENDIF
 4401 CONTINUE
C
      IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS)
C
      IF (INV.EQ.20) THEN
         WRITE(INV,319) NC, REAL(VCONS(1))

         WRITE( INRHO,319) NC,(RHOCONI(IS),IS=1,NSPINS)
      ENDIF
C
      IF(potype.EQ.' lmto') THEN
	      CLOSE (UNIT=19)
      ELSE
	      CLOSE (UNIT=20)
	      CLOSE (UNIT=9)
      ENDIF
C
C      STOP
      RETURN
      END
C
C
C--------------------------------------------------------------

	   subroutine writewf(lxp)
      include 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS,
     1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_),
     3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_),
     4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE
       COMPLEX VCON,XE,EV
       CHARACTER*8 NSYMBL,NAME0
c
      common /pdq/ p(rd_,f_),ps(n_),dps(n_),
     *	     ramf(n_),pss(6),dpss(6)
      complex p,ps,dps,ramf,pss,dpss
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex vcons,v
c
      common/funit/idat,iwr,iphas,iedl0,iwf
      common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3),
     $               dxdir,dxexc,nfis,nfis1,nfis2
      real nfis,nfis2,nfis1
      complex dmx,dmx1,qmx,qmx1,dxdir,dxexc
c
      nlastl = nstart + lxp
c
c      write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf
      write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)'
        write(iwf,*) e, xe, real(vcon)
c
c	write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10)
c
      write(iwf,*)
      write(iwf,*) ' -- absorber excited regular wf for all l -- '
      write(iwf,*)
c
      do 1 i=nstart,nlastl
         write(iwf,*) ' l= ', i-1
      do 2 j=1,kmax(nas)
         write(iwf,*) r(j,1),p(j,i)/ramf(i)
2     continue
1     continue
c
      write(iwf,*)
      write(iwf,*) ' -- absorber irregular wf for l less than 6 -- '
      write(iwf,*) ' radial coor --- wf '
      write(iwf,*)
c
      do 3 i= 1, 6
         write(iwf,*) ' l= ', i-1
         do 4 j=1,kmax(nas)
            write(iwf,*) r(j,1),p(j,i+npss)
 4       continue
 3    continue
c
	  return
	  end
c
c
C--------------------------------------------------------------

	subroutine writeelswf
      include 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS,
     1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_),
     3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_),
     4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE
       COMPLEX VCON,XE,EV
       CHARACTER*8 NSYMBL,NAME0
C
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
c
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg
      real*4 einc,esct,scangl,qt,lambda
c
c
      common/funit/idat,iwr,iphas,iedl0,iwf
c
c      write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf
      write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)'
        write(iwf,*) e, xe, real(vcon)
c
c	write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10)
c
      write(iwf,*)
      write(iwf,*) ' -- absorber excited regular wf for all l -- '
      write(iwf,*)
c
      do  i=1,lmxels(1,nas)
         write(iwf,*) ' inc l= ', i-1
      do  j=1,kmx(nas)
         write(iwf,10) rx(j,1),p1(j,i,nas)/ramfsr1(i,nas)
      enddo
      enddo
c
c
      do  i=1,lmxels(2,nas)
         write(iwf,*) ' sct l= ', i-1
      do  j=1,kmx(nas)
         write(iwf,10) rx(j,1),p2(j,i,nas)/ramfsr2(i,nas)
      enddo
      enddo
c
c
      do  i=1,lmxels(3,nas)
         write(iwf,*) ' exc l= ', i-1
      do  j=1,kmx(nas)
         write(iwf,10) rx(j,1),p3(j,i,nas)/ramfsr3(i,nas)
      enddo
      enddo
c
c
  10  format(7e15.7)
c
      write(iwf,*)
      write(iwf,*) ' -- absorber irregular wf for l less than 6 -- '
      write(iwf,*) ' radial coor --- wf '
      write(iwf,*)
c
      do 3 i= 1, 6
         write(iwf,*) ' l= ', i-1
         do 4 j=1,kmx(nas)
            write(iwf,10) rx(j,1),p3irreg(j,i)
 4       continue
 3    continue
c
	  return
	  end
c
c
c**********************************************************************
c
      subroutine scfdat (title, ifr, iz, ihole, xion,amass, beta,iprint,
     1                   vcoul, srho, dgc0, dpc0, enp, eatom)
c
c   single configuration dirac-fock atom code
c
c   input:
c   title  - any name that will be written into output files.
c   ifr    - specify aadditional output file atom(ifr).dat
c   iz     - atomic number
c   ihole  - remove one electron from orbital #ihole.
c            complete list is in subroutine getorb.
c   xion   - ionicity (iz-number of electrons)
c   amass  - mass of nucleus; 0. - for point nucleus.
c   beta  - thickness parameter for nuclear charge distribution
c            beta=0. for uniform distribution
c   iprint - if iprint>0 additional output is written into atom(ifr).dat
c   output:
c   vcoul  - total coulomb potential (hartrees)
c   srho   - total charge density (bohr**-3)
c   dgc0   -  upper components of dirac spinors
c   dpc0   - lower  components of dirac spinors
c   enp    - energy eigenvalues (hartrees)
c   eatom  - total atomic energy (hartrees)

c          written by a. ankudinov, univ. of washington
c
c          programming language fortran 77
c
c          based on modifications of the code ACRV of J.P. Desclaux
c          [Comp Phys Comm. 9, 31 (1975)] and some subroutines from
c          the FEFF code, J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky
c          and R.C. Albers, [J. Am. Chem. Soc 113,5135(1991)
c
c          version 1 (5-22-96)
c
c**********************************************************************

      implicit double precision (a-h,o-z)
      parameter ( mp = 251, ms = 30 )
c
c     save central atom dirac components, see comments below.
c
      dimension dgc0(mp), dpc0(mp)
      dimension vcoul(mp), srho(mp), enp(ms)

      character*(*)  title
	  character*40 ttl
      character*512 slog
      common /charact/ ttl

      character*30 fname
c
c   this programm uses cofcon cofdat dsordf ictime iowrdf
c   lagdat messer nucdev ortdat potrdf soldir
      common cg(mp,ms),cp(mp,ms),bg(10,ms),bp(10,ms),fl(ms),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
c
c   gg,gp are the output from soldir
c
      common/comdir/cl,dz,gg(mp),ag(10),gp(mp),ap(10),bid(3*mp+30)
      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,idim
      data dprlab/'  scfdat'/


c
c *** copy input parameters to common blocks
c
      ttl = title
      lttl = istrln(title)
	  if (lttl.le.0) ttl='atomic data'
	  nz=iz
      dz=nz
c
c *** desclaux standard opinion. be careful when changing.
c
      nuc=11
c
c     nuc -  number of points inside nucleus (suggested value 11)
c
      nes=50
c
c     nes number of attempts in program soldir
c     differ from desclaux nes=40
c
      niter=30
c
c     equivalent to desclaux niter=1130
c     niter =1000*n1+100*n2+n3
c     n3 is the number of iterations per orbital
c
      testy=1.d-5
c
c     testy precision for the wave functions
c
      hx=5.d-2
      dr(1)=exp(-8.8D0)*iz
c
c     dr(1)=exp(-8.8)
c     hx exponential step
c     dr1 first tabulation point multiplied by nz
c     desclaux dr1=0.01 correspond to iz=66
c
      teste=5.d-6
      rap(1)=1.d2
      rap(2)=1.d1
c
c     teste precision for the one-electron energies
c     rap tests of precision for soldir
c
      ido=1
c
c     equivalent to ido=ndep=1
c     calculate initial orbitals using thomas-fermi model ido=1
c     option to read from cards(ido=2) destroyed
c     nmax=251 - set in subroutine inmuat
c     scc=0.3  - set in subroutine inmuat
c *** end of desclaux standard opinion on parameters
c
      if (iprint .ge. 1)  then
c
c        prepare file for atom output
c
         write(fname,14)  ifr
   14    format('atom', i2.2, '.dat')
         open (unit=16, file=fname, status='unknown')
c        call chopen (ios, fname, 'atom')
c        call head (16)
         write(16,*)  ' free atom ', ifr
         lttl = istrln(ttl)
         if (iprint .ge. 1)  write(16,40) ttl(1:lttl)
 40      format (1h1,40x,a)
      endif
c
c     initialize the rest of the data and calculate initial w.f.
c
      jfail = 0
      ibgp = 10
      numerr = 0
      nz = iz
      call inmuat (ihole, xion)
c
c     iholep is the index for core hole orbital in all arrays
c     for 90% of atoms iholep=ihole
c
      a = - xion - 1
      call wfirdf ( en, a, nq, kap, nmax, ido, amass, beta)

      j = 1
      ind = 1
      nter = 0
      do 41 i=1, norb
 41   scw(i) = 0.D0
      test1 = testy / rap(1)
      test2 = testy / rap(2)
      netir = abs(niter) * norb
      if (iprint .ge. 1)  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
c     muatco - programm to calculate angular coefficients
c
      call muatco
      if (numerr .ne. 0) go to 711
c
c     iteration over the number of cycles
c
 101  iort = 0
         nter = nter + 1
         if (niter .ge. 0) go to 105
c
c        orthogonalization by schmidt procedure
c
 104     call ortdat (j)
 105     method = 1
c
c        calculate lagrange parameters
c
         if (nre(j).gt.0 .and. ipl.ne.0) call lagdat (j,1)
c
c        calculate electron potential
c
         call potrdf (j)
         e = en(j)
         np = idim
c
c        resolution of the dirac equation
c
         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
c        variation of the wave function using two iterations
c
         k = nmax(j)
         pr = 0.D0
         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
         write(slog,'(i4,i3,2(1pe11.2),2(1pd16.6),4x,a,i2)')
     1   nter, j, sce(j), pr, a, b, 'method', method
         call wlog(slog,0)
c
c        acceleration of the convergence
c
         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
c        normalization of the wave function
c
         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
c        determination of the next orbital to calculate
c
         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.D0
         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.D0
         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
c **** number of iterations exceeded the limit
c
      dlabpr = dprlab
 711  call messer
      stop
 999  if (numerr .eq. 0) then
         if (jfail.ne.0) then
           call wlog(
     1     'failed to match lower component, results are meaningless',1)
            stop
         endif
c
c        tabulation of the results
c
         if (iprint .ge. 1)  call tabrat
         call etotal( kap, xnel, en, iprint, eatom)
c
c        return coulomb potential
c
         do 800 i=1, idim
  800    srho(i) = 0.0D0
         do 830 j=1, norb
         do 830 i=1, nmax(j)
  830       srho(i) = srho(i) + xnel(j) * (cg(i,j)**2 + cp(i,j)**2)
         call potslw( vcoul, srho, dr, hx, idim)
         do 810 i=1, 251
  810      vcoul(i) = vcoul(i) - nz/dr(i)
c
c        return srho as density instead of 4*pi*density*r**2
c        do 860  i = 1, 251
c           srho(i) = srho(i) / (dr(i)**2) / 4. / pi
c           srho(i) = srho(i) / 4. / pi
c 860    continue
c
         do 870 ispinr = 1, 30
            do 852  i = 1, 251
               dgc0(i) = cg( i, ispinr)
               dpc0(i) = cp( i, ispinr)
  852       continue
            enp(ispinr) = en(ispinr)
  870    continue
      endif
      if (iprint .ge. 1)  close(unit=16)

      return
      end
      double precision function akeato (i,j,k)
c     angular coefficient by the direct coulomb integral fk
c     for orbitals i and j

      implicit double precision (a-h,o-z)
      common/mulabk/afgk
      dimension afgk(30,30,0:3)
c
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)
c
      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
c angular coefficient at the exchange coulomb integral gk
c
      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 aprdev (a,b,l)
c
c     the result of this function is the coefficient of the term of
c     power for the product of two polynomes, whose coefficients are
c     in rows a and b
c
      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
      subroutine bkmrdf (i,j,k)
c
c     angular coefficients for the breit term
c i and j are the numbers of orbitals
c 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
c
      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabre/cmag(3),cret(3)

      do 12 l=1,3
        cmag(l)=0.0d 00
 12     cret(l)=0.0d 00
      ji=2* abs(kap(i))-1
      jj=2* abs(kap(j))-1
      kam=kap(j)-kap(i)
      l=k-1
      do 51 m=1,3
         if (l.lt.0) go to 51
         a=cwig3j(ji,jj,l+l,-1,1,2)**2
         if (a.eq.0.0d 00) go to 51
         c=l+l+1
         if (m-2) 14,16,17
 14      cm=(kam+k)**2
         cz=kam*kam-k*k
         cp=(k-kam)**2
         n=k
 15      l1=l+1
         am=(kam-l)*(kam+l1)/c
         az=(kam*kam+l*l1)/c
         ap=(l+kam)*(kam-l1)/c
         d=n*(k+k+1)
         go to 31

 16      d=k*(k+1)
         cm=(kap(i)+kap(j))**2
         cz=cm
         cp=cm
         go to 41

 17      cm=(kam-l)**2
         cz=kam*kam-l*l
         cp=(kam+l)**2
         n=l
         c=-c
         go to 15

 31      c= abs(c)*d
         if (c.ne.0.0d 00) c=n/c
         cret(1)=cret(1)+a*(am-c*cm)
         cret(2)=cret(2)+(a+a)*(az-c*cz)
         cret(3)=cret(3)+a*(ap-c*cp)
 41      if (d.eq.0.0d 00) go to 51
         a=a/d
         cmag(1)=cmag(1)+cm*a
         cmag(2)=cmag(2)+cz*(a+a)
         cmag(3)=cmag(3)+cp*a
 51      l=l+1
      return
      end
      subroutine cofcon (a,b,p,q)
c
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.2D0) b = b - 0.1D0
      go to 31

 21   if (b .le. 0.8D0) b = b + 0.1D0

 31   a = 1.0D0 - b
      q=p
      return
      end
      double precision function cwig3j (j1,j2,j3,m1,m2,ient)
c
c        wigner 3j coefficient for integers  (ient=1)
c                            or semiintegers (ient=2)
c        other arguments should be multiplied by ient
c
      implicit double precision (a-h,o-z)
      save
      character*512 slog
      dimension al(32),m(12)
      data ini/1/,idim/31/
c
c     idim-1 is the largest argument of factorial in calculations
c
      m3=-m1-m2
      if (ini) 1,21,1
c
c        initialisation of the log's of the factorials
c
 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
c        test triangular inequalities, parity and maximum values of m
c
      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
c      calculate 3j coefficient
c
      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,1)
      stop
      end
      double precision function dentfa (dr,dz,ch)
c
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
c
      implicit double precision (a-h,o-z)

      dentfa=0.0d 00
      if ((dz+ch).lt.1.0d-04) return
      w=dr*(dz+ch)**(1.D0/3.D0)
      w=sqrt(w/0.8853D0)
      t=w*(0.60112D0*w+1.81061D0)+1.D0
      w=w*(w*(w*(w*(0.04793D0*w+0.21465D0)+0.77112D0)+1.39515D0)+
     1     1.81061D0)+1D0
      dentfa=(dz+ch)*(1.0d 00-(t/w)**2)/dr
      return
      end
      double precision function dsordf (i,j,n,jnd,a)
c
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 utilises   aprdev
c
      implicit double precision (a-h,o-z)
      common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(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
c        construction of the array hg
c
      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
c        integration of the hg
c
 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
c        integral from 0 to dr(1)
c
      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 etotal (kap,xnel,en,iprint,eatom)
c
c combined from original subroutines tabfgk,tabbre,tabrat.
c kap quantique  number "kappa"
c xnel occupation of  orbitales (can be fractional)
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        sous programmes utilises akeato,bkeato
c        fdrocc fdrirk bkmrdf
c
      implicit double precision (a-h,o-z)
      dimension kap(30),xnel(30),en(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      dimension ener(4)
      dimension cer(17)
      common/tabre/cmag(3),cret(3)
      common/inelma/nem
      character*4 iner(4)
      character*512 slog
      data iner/'coul','ech.','mag.','ret.'/

      do 10 i = 1,4
 10   ener(i)=0.0d 00
      iv=0
c
c       fk  integrales
c
      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
            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
c       gk  integrales
c
      do 70 i=2,norb
         i1=i-1
         do 70 j=1,i1
            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)
            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
c       direct  integrales
c
      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
            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))*cer(ik)*
     1              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
c       exchange  integrales
c
      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
 185           ener(4) =ener(4) +cret(i)*cer(i)*b
            k=k+2
            if (k.le.kma) go to 141
 201  continue
      endif
c
c       total   energy
c
      eatom = -(ener(1)+ener(2))+ener(3)+ener(4)
      do 212 j=1,norb
 212     eatom = eatom + en(j)*xnel(j)
      if (iprint .ge. 1)  write(16,'(a,1pd18.7)') 'etot',eatom
      write(slog,'(a,1pd18.7)') 'etot',eatom
      call wlog(slog,0)
      do 215 i=1,4
         if (iprint .ge. 1) write(16,'(a4,1pd18.7)') iner(i),ener(i)
         write(slog,'(a4,1pd18.7)') iner(i),ener(i)
 215     call wlog(slog,0)
      return
      end
c
      double precision function fdmocc (i,j)
c
c     product of the occupation numbers of the orbitals i and j
c
      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.0D0)
      else
         fdmocc=xnel(i)*xnel(j)
      endif
      return
      end
c
      double precision function fdrirk (i,j,l,m,k)
c
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
c
      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
c comdir is used just to exchange variables between dsordf,yzkrdf,fdrirk
c
      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
c
      subroutine getorb (iz, ihole, xion, norb, norbco,
     1                  iholep, den, nqn, nk, xnel, xnval)
c
c     Gets orbital data for chosen element.  Input is iz, atomic number
c     of desired element, other arguments are output.
c     Feel free to change occupation numbers for element of interest.
c     ival(i) is necessary only for partly nonlocal exchange model.
c     iocc(i) and ival(i) can be fractional
c     But you have to keep the sum of iocc(i) equal to nuclear charge.
c     Also ival(i) should be equal to iocc(i) or zero.
c     Otherwise you have to change this subroutine or contact authors
c     for help.
c
      implicit double precision (a-h, o-z)
c
c     Written by Steven Zabinsky, July 1989
c     modified (20 aug 1989)  table increased to at no 97
c     Recipe for final state configuration is changed. Valence
c     electron occupations are added. ala 17.1.1996

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

c     element  level     principal qn (nqn), kappa qn (nk)
c           1  1s        1  -1
c           2  2s        2  -1
c           3  2p1/2     2   1
c           4  2p3/2     2  -2
c           5  3s        3  -1
c           6  3p1/2     3   1
c           7  3p3/2     3  -2
c           8  3d3/2     3   2
c           9  3d5/2     3  -3
c          10  4s        4  -1
c          11  4p1/2     4   1
c          12  4p3/2     4  -2
c          13  4d3/2     4   2
c          14  4d5/2     4  -3
c          15  4f5/2     4   3
c          16  4f7/2     4  -4
c          17  5s        5  -1
c          18  5p1/2     5   1
c          19  5p3/2     5  -2
c          20  5d3/2     5   2
c          21  5d5/2     5  -3
c          22  5f5/2     5   3
c          23  5f7/2     5  -4
c          24  6s        6  -1
c          25  6p1/2     6   1
c          26  6p3/2     6  -2
c          27  6d3/2     6   2
c          28  6d5/2     6  -3
c          29  7s        7  -1
c
      dimension den(30), nqn(30), nk(30), xnel(30), xnval(30)
      dimension kappa (29)
      real iocc, ival
      dimension iocc (97, 29), ival (97, 29)
      dimension nnum (29)
      character*512 slog
c
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
c
      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
c     principal quantum number (energy eigenvalue)
c
      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
c     occupation of each level for z = 1, 97
c
      data (iocc( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 3,i),i=1,29)  /2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 4,i),i=1,29)  /2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 4,i),i=1,29)  /0,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 5,i),i=1,29)  /2,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 5,i),i=1,29)  /0,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 6,i),i=1,29)  /2,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 6,i),i=1,29)  /0,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 7,i),i=1,29)  /2,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 7,i),i=1,29)  /0,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 8,i),i=1,29)  /2,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 8,i),i=1,29)  /0,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc( 9,i),i=1,29)  /2,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival( 9,i),i=1,29)  /0,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(10,i),i=1,29)  /2,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(10,i),i=1,29)  /0,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(11,i),i=1,29)  /2,2,2,4,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(11,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(12,i),i=1,29)  /2,2,2,4,2,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(12,i),i=1,29)  /0,0,0,0,2,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(13,i),i=1,29)  /2,2,2,4,2,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(13,i),i=1,29)  /0,0,0,0,2,  1,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(14,i),i=1,29)  /2,2,2,4,2,  2,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(14,i),i=1,29)  /0,0,0,0,2,  2,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(15,i),i=1,29)  /2,2,2,4,2,  2,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(15,i),i=1,29)  /0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(16,i),i=1,29)  /2,2,2,4,2,  2,2,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(16,i),i=1,29)  /0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(17,i),i=1,29)  /2,2,2,4,2,  2,3,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(17,i),i=1,29)  /0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(18,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(18,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(19,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(19,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(20,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(20,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(21,i),i=1,29)  /2,2,2,4,2,  2,4,1,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(21,i),i=1,29)  /0,0,0,0,0,  0,0,1,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(22,i),i=1,29)  /2,2,2,4,2,  2,4,2,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(22,i),i=1,29)  /0,0,0,0,0,  0,0,2,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(23,i),i=1,29)  /2,2,2,4,2,  2,4,3,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(23,i),i=1,29)  /0,0,0,0,0,  0,0,3,0,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(24,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(24,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(25,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(26,i),i=1,29)  /2,2,2,4,2,  2,4,4,2,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(26,i),i=1,29)  /0,0,0,0,0,  0,0,4,2,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(27,i),i=1,29)  /2,2,2,4,2,  2,4,4,3,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(27,i),i=1,29)  /0,0,0,0,0,  0,0,4,3,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(28,i),i=1,29)  /2,2,2,4,2,  2,4,4,4,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(28,i),i=1,29)  /0,0,0,0,0,  0,0,4,4,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(29,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(29,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(30,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(30,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(31,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(31,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  1,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(32,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(32,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(33,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,1,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(34,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,2,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,2,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(35,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,3,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,3,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(36,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(37,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(38,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(39,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(40,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,0,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(41,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(42,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(43,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(44,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,3,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,3,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(45,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,4,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,4,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(46,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(47,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(48,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,
     1                           0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(49,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(50,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(51,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(52,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(53,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(54,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ival(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc(55,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ival(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/
      data (iocc(56,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(57,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,
     1                           0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc(58,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,2,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(59,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,3,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(60,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,4,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(61,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,5,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(62,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(63,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           1,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           1,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(64,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           1,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           1,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc(65,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           3,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           3,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(66,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           4,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           4,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(67,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           5,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           5,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(68,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           6,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           6,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(69,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           7,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           7,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(70,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,
     1                           8,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc(71,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc(72,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ival(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,2,  0,0,0,2,0,  0,0,0,0/
      data (iocc(73,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,3,  0,0,0,2,0,  0,0,0,0/
      data (ival(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,3,  0,0,0,2,0,  0,0,0,0/
      data (iocc(74,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  0,0,0,2,0,  0,0,0,0/
      data (ival(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  0,0,0,2,0,  0,0,0,0/
      data (iocc(75,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  1,0,0,2,0,  0,0,0,0/
      data (ival(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  1,0,0,2,0,  0,0,0,0/
      data (iocc(76,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  2,0,0,2,0,  0,0,0,0/
      data (ival(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  2,0,0,2,0,  0,0,0,0/
      data (iocc(77,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  3,0,0,2,0,  0,0,0,0/
      data (ival(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  3,0,0,2,0,  0,0,0,0/
      data (iocc(78,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  5,0,0,1,0,  0,0,0,0/
      data (ival(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  5,0,0,1,0,  0,0,0,0/
      data (iocc(79,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,1,0,  0,0,0,0/
      data (ival(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,1,0,  0,0,0,0/
      data (iocc(80,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,0,  0,0,0,0/
      data (ival(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,4,  6,0,0,2,0,  0,0,0,0/
      data (iocc(81,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,1,  0,0,0,0/
      data (ival(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,1,  0,0,0,0/
      data (iocc(82,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  0,0,0,0/
      data (ival(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  0,0,0,0/
      data (iocc(83,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  1,0,0,0/
      data (ival(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  1,0,0,0/
      data (iocc(84,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  2,0,0,0/
      data (ival(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  2,0,0,0/
      data (iocc(85,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  3,0,0,0/
      data (ival(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  3,0,0,0/
      data (iocc(86,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,0/
      data (ival(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,2,2,  4,0,0,0/
      data (iocc(87,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,1/
      data (ival(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/
      data (iocc(88,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,0,0,2/
      data (ival(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,0,0,2/
      data (iocc(89,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,1,0,2/
      data (ival(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,1,0,2/
      data (iocc(90,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,0,0,2,2,  4,2,0,2/
      data (ival(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,0,0,0,0,  0,2,0,2/
      data (iocc(91,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,2,0,2,2,  4,1,0,2/
      data (ival(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,2,0,0,0,  0,1,0,2/
      data (iocc(92,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,3,0,2,2,  4,1,0,2/
      data (ival(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,3,0,0,0,  0,1,0,2/
      data (iocc(93,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,4,0,2,2,  4,1,0,2/
      data (ival(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,4,0,0,0,  0,1,0,2/
      data (iocc(94,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,0,2,2,  4,0,0,2/
      data (ival(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,0,0,0,  0,0,0,2/
      data (iocc(95,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,1,2,2,  4,0,0,2/
      data (ival(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,1,0,0,  0,0,0,2/
      data (iocc(96,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,2,2,2,  4,0,0,2/
      data (ival(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,2,0,0,  0,0,0,2/
      data (iocc(97,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,
     1                           8,2,2,4,4,  6,6,3,2,2,  4,0,0,2/
      data (ival(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,
     1                           0,0,0,0,0,  0,6,3,0,0,  0,0,0,2/

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

      ion = nint(xion)
      delion=xion-ion


      index = iz - ion
      ilast = 0
      iscr = 0
      iion = 0
      iholep = ihole
c
c     find last occupied orbital (ilast) and iion for delion.ge.0
c
      do 30 i=29,1,-1
         if (iion.eq.0 .and. dble(iocc(index,i)).gt.delion) iion=i
         if (ilast.eq.0 .and. iocc(index,i).gt.0) ilast=i
 30   continue
c      open(unit=91,file='getorbtuo.dat',status='unknown')
c        iz=29
      if (ihole.eq.0) go to 11
      if (ihole.gt.0 .and. iocc(index,ihole) .lt. 1 .or.
     1 (ihole.eq.ilast .and. iocc(index,ihole)-real(delion).lt.1) ) then
c         call wlog(' Cannot remove an electron from this level',1)
         write(6,*)' Cannot remove an electron from level =', ihole
         write(6,*) ' stop in getorb ' 
         stop 'GETORB-1'
      endif
 11   continue
c
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
c     find where to put screening electron
c
      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
c     special case of hydrogen like ion
c     if (index.eq.1) iscr=2
c
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
c
      if (delion .lt. 0) then
c
c        addition of electron charge
c
         iion = iscr
c
c        except special cases
c
         if (ihole.ne.0 .and.
     1       iocc(index,iscr)+1-real(delion).gt.2*abs(kappa(iscr))) then
             iion = ilast
             if (ilast.eq.iscr .or. iocc(index,ilast)-real(delion).gt.
     1                          2*abs(kappa(ilast)) ) iion = ilast + 1
         endif
      endif

      norb = 0
      do 20  i = 1, 29
         if (iocc(index,i).gt.0 .or. (i.eq.iscr .and. ihole.gt.0)
     1     .or. (i.eq.iion .and. iocc(index,i)-real(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) = dble(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)= dble(ival(index,i))
               if (i.eq.ihole .and. xnval(norb).ge.1)
     1                         xnval(norb) = xnval(norb) - 1
               if (i.eq.iscr .and. ihole.gt.0)
     1                         xnval(norb) = xnval(norb) + 1
               if (i.eq.iion)  xnel(norb) = xnel(norb) - delion
               if (i.eq.iion)  xnval(norb) = xnval(norb) - delion
               den(norb) = 0.0D0
            endif
         endif
   20 continue
      norbco = norb
c
c     check that all occupation numbers are within limits
c
      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,1)
            stop
         endif
  50  continue
c      do 60 i=1,norb
c60    xnval(i) = 0.0d0
c60    xnval(i) = xnel(i)

      return
      end

      subroutine inmuat (ihole, xionin)
      implicit double precision (a-h,o-z)
      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
      dimension xnval(30)
c
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
c
      common/scrhf1/eps(435),nre(30),ipl
c
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)
c
      common/snoyau/dvn(251),anoy(10),nuc
c
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)
c
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      data ideps/435/

      ndor=10



      call getorb( nz, ihole, xionin, norb, norbsc,
     1             iholep, en, nq, kap, xnel, xnval)
      xk=0
      do 411 i=1,norb
 411  xk=xk+xnel(i)
      if ( abs(nz-xionin-xk) .gt. 0.001D0) then
         call wlog('check number of electrons in getorb.f',1)
         stop
      endif
      norbsc=norb
c
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
c nes number of attempts in program soldir
c nuc number of points inside nucleus (11 by default)
c
      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
c     ipl=0 means no orbitals with the same kappa and no
c     orthogonalization needed. Thus it will remain zero only
c     for hydrogen atom.
c
      do 401 i=1,norb
         nre(i)=-1
         llq= abs(kap(i))
         l=llq+llq
         if (kap(i).lt.0) llq=llq-1
         if (llq.lt.0.or.llq.ge.nq(i).or.llq.gt.3) then
            call wlog('kappa out of range, check getorb.f',1)
            stop
         endif
         nmax(i)=idim
         scc(i)=0.3d0
         if (xnel(i) .lt. l)  nre(i)=1
         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
      return
      end
c
      subroutine intdir(gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0)
c
c            solution of the inhomogenios dirac equation
c gg gp initially exchage terms, at the time of return - 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
c
      implicit double precision (a-h,o-z)
      save
      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)
      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
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
c
      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
c      search for the second sign change point
c
 15   mat=npi
      j=1
 16   mat=mat+2
         if (mat.ge.np) then
c
c   i had trouble with screened k-hole for la, for f-electrons.
c   below i still define matching point if one electron energy is
c   not less than -1ev. ala, january 1995
c
            if (ec .gt. -0.0003D0) then
              mat = np - 12
              go to 25
            endif
            numerr=56011
c
c          * fail to find matching point
c          if you got this error with fractional ionicity, try
c          slightly different.(xion=xion+0.01)
c
            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
c     initial values for the outward integration
c
 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
c     integration of the inhomogenious system
c
 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
c     initial values for inward integration
c
      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
c          *the last tabulation point is too close to the matching point
c
            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
c
      subroutine lagdat (ia,iex)
c
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
c
      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),
     1              nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl

      i1= max(ia,1)
      idep=1
      if (ia.gt.0) go to 15
 11   idep=i1+1
 15   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
c     the following line was included to handle the case of single
c     electron in 2 s-shells
c     probably need to use schmidt orthogonalization in this case
c
         if (xnel(i1).eq.xnel(i2)) go to 201
         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
c
      subroutine messer
c
c  prints error message on the output device
c
      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,1)
      return
      end
c
      subroutine muatco
c
c               * angular coefficients *
c        sous programmes utilises  cwig3j
c
      implicit double precision (a-h,o-z)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/mulabk/afgk
      dimension afgk(30,30,0:3)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)

      do 511 i=1,30
      do 511 j=1,30
      do 511 k=0,3
 511  afgk(i,j,k)=0.0d 00
      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
c calculate a_k(i,j)
c
            m=0
            if (j.eq.i) m=1
            afgk(j,i,0)=afgk(j,i,0)+xnel(i)*(xnel(j)-m)
c
c calculate b_k(i,j)
c
            b=afgk(j,i,0)
            if (j.eq.i) 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
 701  continue
      return
      end
c
      subroutine nucdev (a,epai,av,dr,dv,dz,hx,nuc,np,ndor,dr1)
c
c        * construction of nuclear potential *
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 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
c
      implicit double precision (a-h,o-z)
      dimension av(10),dr(251),dv(251),at(251)
c
c     calculate radial mesh
c
      if (a.le.1.0d-01) then
         nuc=1
      else
c        dr(nuc)=nuclear radius
c
         a=dz*(a**(1.D0/3.D0))*2.2677d-05
         b=a/ exp(hx*(nuc-1))
         if (b.le.dr1) then
            dr1=b
         else
c
c           increase value of nuc
c
            b=log(a/dr1)/hx
            nuc=3+2*int(b/2.0D0)
            if (nuc.ge.np) stop 'dr1 too small'
c
c           index of atomic radius larger than dimension of dr
c
            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
c       * there should be at least 5 development coefficients
c
         call wlog('stopped in programm nucdev, ndor should be > 4.',1)
         stop
      endif
c
c     calculate nuclear potential on calculated radial mesh
c
      do 11 i=1,ndor
 11      av(i)=0.0d 00
      if (epai.le.0.0D0) 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
c
      subroutine ortdat (ia)
c
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
c
      implicit double precision (a-h,o-z)
      common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
c  dg,ag,dp,ap are used to exchange data only with dsordf
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim

      m=norb
      l= max(ia,1)
      if (ia.gt.0) go to 11
 5    m=l
      l=l+1
      if (l.gt.norb) go to 999
 11   do 15 i=1,idim
         dg(i)=0.0d 00
 15      dp(i)=0.0d 00
      maxl=nmax(l)
      do 21 i=1,maxl
         dg(i)=cg(i,l)
 21      dp(i)=cp(i,l)
      do 25 i=1,ndor
         ag(i)=bg(i,l)
 25      ap(i)=bp(i,l)
      do 51 j=1,m
         if (j.eq.l.or.kap(j).ne.kap(l)) go to 51
         max0=nmax(j)
         a=dsordf (j,j,0,3,fl(l))
         do 41 i=1,max0
            dg(i)=dg(i)-a*cg(i,j)
 41         dp(i)=dp(i)-a*cp(i,j)
         do 45 i=1,ndor
            ag(i)=ag(i)-a*bg(i,j)
 45         ap(i)=ap(i)-a*bp(i,j)
         maxl= max(maxl,max0)
 51   continue
      max0= maxl
      nmax(l)=max0
      a=dsordf (l,max0,0,4,fl(l))
      a= sqrt(a)
      do 71 i=1,max0
         cg(i,l)=dg(i)/a
 71      cp(i,l)=dp(i)/a
      do 75 i=1,ndor
         bg(i,l)=ag(i)/a
 75      bp(i,l)=ap(i)/a
      if (ia.le.0) go to 5
 999  return
      end
c
      subroutine potrdf (ia)
c
c        this programm uses akeato(bkeato),aprdev,multrk,yzkrdf
c
      implicit double precision (a-h,o-z)
      common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10),
     2              eg(251),ceg(10),ep(251),cep(10)
c     dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir
      dimension at(251),bt(251)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      common/snoyau/dvn(251),anoy(10),nuc
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)

      do 9 i=1,ndor
         cep(i)=0.0d 00
         ceg(i)=0.0d 00
 9       av(i)=anoy(i)
      do 11 i=1,idim
         at(i)=0.0d 00
         bt(i)=0.0d 00
         ep(i)=0.0d 00
         eg(i)=0.0d 00
 11      dv(i)=0.0d 00
c
c     coulomb terms
c
      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
         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
c     exchange terms
c
      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)
 135        cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1)
 141     i=2* abs(kap(j))+1
         if (i.gt.ndor) go to 151
         do 143 i = 1,10
            bgj(i) = bg(i,j)
 143        bpj(i) = bp(i,j)
         do 145 n=i,ndor
            ceg(n)=ceg(n)-a*aprdev(ag,bgj,n+1-i)
 145        cep(n)=cep(n)-a*aprdev(ag,bpj,n+1-i)
 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
c addition of nuclear potential and division of potentials and
c       their development limits by speed of light
c
 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
c
      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 **********************************************************************
c
      implicit double precision (a-h,o-z)
      save
      dimension dv(251), d(251), dp(251), dr(251)
      das=dpas/24.0D0
      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.0D0*(dlo-1.0D0))
      dp(1)=dv(1)/3.0D0-dp(2)/dlo2
      dp(2)=dv(2)/3.0D0-dp(2)*dlo2
      j=np-1
      do 20 i=3,j
   20 dp(i)=dp(i-1)+das*(13.0D0*(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.0D0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp
     1 (k-1)*dlo))
      dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0D0*dp(2)/dlo+dp(3)/dlo2)/3.0D0
      do 40 i=1,np
   40 dv(i)=dv(i)/dr(i)
      return
      end
c
	  subroutine soldir (en,fl,agi,api,ainf,nq,kap,max0,ifail)
c
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
c
      implicit double precision (a-h,o-z)
      save
      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
c gg,gp -output, dv,eg,ep - input
c
      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
c
      common/subdir/ell,fk,ccl,imm,nd,node,mat
c
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
c
      common/messag/dlabpr,numerr
      character*8 dprlab,dlabpr, drplab
c
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.
c
      character*512 slog
c
      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
c notice that below iex=0,1 and method=1,2 only.
c this was used to simplify block structure of program. ala 11/22/94
c
      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.0D0
      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.0D0) then
         numerr=75011
c
c       *potential is apparently positive
c
         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
c     integration of the inhomogenious system
c
 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
c     match large component for the homogenios system(method=0)
c
      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
c     integration of the homogenios system
c
 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
c     match the large component for inhomogenious system(method=1)
c
      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
c        integration of the system derived from disagreement in energy
c
         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
c        match both components for inhomogenious system (method=2)
c
         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
c        calculate the norm
c
         call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,
     1     gpmat,fl,max0,mat)
c
c        correction to the energy (method=2)
c
         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
c     search for the maximum of the modulus of large component
c
      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
         write(slog,'(a,i4,a,i4)') ' warning  mat=',mat,' max0=',max0
         call wlog(slog,1)
      endif
c
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 of
c soldir.  redirected by ala 11/21/94.
c     numerr=220021
c * impossible matching point
c     go to 899

c compute number of nodes
c
 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
c    *energy is lower than the minimum of apparent potential
c
      go to 899

 271  if ( abs(einf-esup).gt.test1) go to 281
      numerr=249051
c
c    *the upper and lower limits of energy are identical
c
      go to 899

 281  en=(einf+esup)/2.0d 00

 285  jes=jes+1
      if (jes.le.nes) go to 106
c
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 are getting it at final norb calls of
c soldir
c
      call wlog('warning jes>nes',1)
      ifail=1
c
c    *redirected by ala 11/21/94.
c     numerr=255061
c     go to 899
c
c     calculation of the norm
c
 305  call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,
     1     gpmat,fl,max0,mat)
      if (method.eq.1) then
c
c        correction to the energy (method=1)
c
         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
c        try smaller step in enrgy under above conditions
c
         f=f/2.0d 00
         g=g/2.0d 00
         en=en-f
         if (g.gt.test1) go to 371
         numerr=29071
c
c       *zero energy
c
         go to 899
      endif

      if ( abs(c).gt.test)  then
         ies=ies+1
         if (ies.le.nes) go to 105
         ifail=1
         call wlog('warning: iteration stopped because ies=nes',1)
c
c     everything is fine unless you are getting this message
c     on the latest stage selfconsistent process.
c     just stopped trying to match lower component
c     because number of trials exceeded limit.
c     lines below were commented out.  ala 11/18/94
c
      endif
c
c     numerr=298081
c    *number of attempts to match the lower component is over the limit
c     go to 899
c
c     divide by a square root of the norm, and test the sign of w.f.
c
      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
c     if everything o'k , exit is here.
c
      return
c
c     abnormal exit is here, if method.ne.1
c
 899  if (iex.eq.0 .or. method.eq.2) go to 999
      method=method+1
      go to 101

 999  return
      end
c
      subroutine norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,
     1 gpmat,fl,max0,mat)
c
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
c
      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

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

      subroutine tabrat
c
c      tabulation of the results
c do identifications of orbitals
c nmax number of tabulation points for wave function
c      this programm uses dsordf
c
      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 /charact/ ttl
      character*40  ttl
      character*2  titre(30)
      character*2  ttire(9)
      dimension at(8),mbi(8)
      parameter (zero=0)
      data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/
c
      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
c     tabulation of number of points and of average values of
c                   r**n (n=6,4,2,1,-1,-2,-3)
c
      do 201 i=2,8
 201     mbi(i)=8-i-i/3-i/4+i/8
      lttl = istrln(ttl)
      write(16,11) ttl(1:lttl)
  11  format (10x,a)
      write(16,*)
     1'number of electrons nel and average values of r**n in a.u.'
      write(16,2061) (mbi(k),k=2,8)
 2061 format (4x,'nel','  n=',7(i2,8x))
      do 251 i=1,norb
         llq= abs(kap(i))-1
         j=8
         if (llq.le.0) j=7
         do 241 k=2,j
 241        at(k)=dsordf(i,i,mbi(k),1, zero)
 251     write(16,2071) nq(i),titre(i),xnel(i),(at(k),k=2,j)
 2071 format(i2,a2,f7.3,7(1pe10.3))
c
c      overlap integrals
c
      if (norb.le.1) return
      write(16,11) ttl(1:lttl)
      write(16,321)
 321  format(10x,'overlap integrals')
      do 351 i=1,norb-1
         do 331 j=i+1,norb
            if (kap(j).ne.kap(i)) go to 331
            at(1)=dsordf(i,j,0,1, zero)
            write(16,2091)  nq(i),titre(i),nq(j),titre(j),at(1)
 331     continue
 351  continue
 2091 format (4x,i3,a2,i3,a2,f14.7)
      return
      end
c
      subroutine wfirdf (en,ch,nq,kap,nmax,ido,amass,beta)
c
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
c
      implicit double precision (a-h,o-z)
      common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(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
c     speed of light in atomic units
c
      cl=1.370373d+02
c
c     make r-mesh and calculate nuclear potential
c     hx exponential step
c     dr1 first tabulation point multiplied by nz
c
      dr1=dr(1)
      call nucdev (amass, beta,anoy,dr,dvn,dz,hx,nuc,idim,ndor,dr1)
c
c     notice that here nuc=1,
c     unless you specified nonzero nuclear mass in nucdev.f
c
      a=(dz/cl)**2
      if (nuc.gt.1) a=0.0d 00
      do 11 j=1,norb
         b=kap(j)*kap(j)-a
 11      fl(j)= sqrt(b)
c
c     calculate potential from thomas-fermi model
c
      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
c     resolution of the dirac equation to get initial orbitals
c
      if (ido.ne.1) then
         call wlog('only option ido=1 left',1)
         ido = 1
      endif
c
c     here was a piece to read orbitals from cards
c
      do 281 j=1,norb
         bg(1,j)=1.0d 00
         i=nq(j)- abs(kap(j))
         if (kap(j).lt.0) i=i-1
         if (mod(i,2).eq.0) bg(1,j)=-bg(1,j)
         if (kap(j).lt.0) go to 201
         bp(1,j)=bg(1,j)*cl*(kap(j)+fl(j))/dz
         if (nuc.gt.1) bg(1,j)=0.0d 00
         go to 211

 201     bp(1,j)=bg(1,j)*dz/(cl*(kap(j)-fl(j)))
         if (nuc.gt.1) bp(1,j)=0.0d 00
 211     np=idim
         en(j)=-dz*dz/nq(j)*nq(j)
         method=0
         call soldir
     1     (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),0)

         if (numerr.eq.0) go to 251
         call messer
         write(slog,'(a,2i3)')
     1   'soldir failed in wfirdf for orbital nq,kappa ',nq(j),kap(j)
         call wlog(slog,1)
         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
      subroutine wlog (string,iprint)
      character*(*) string
c
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
c     The log file is unit 11.  The log file is opened in the
c     main program, program feff.
c
c     make sure not to write trailing blanks
c

   10 format (a)

      il = istrln (string)
      if (il .eq. 0)  then
         if(iprint.eq.1) print 10
         write(11,10) 
      else
         if(iprint.eq.1) print 10, string(1:il)
         write(11,10) string(1:il)
      endif
      return
      end
c
      subroutine yzkrdf (i,j,k)
c
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
c
      implicit double precision (a-h,o-z)
      common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(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
      if (i.le.0) go to 51
c
c     construction of the function f
c
      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
c
 51   ap(1)=k+2
      id=j
 55   call yzkteg (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim)
      return
      end
c
      subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim)
c
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
c
      implicit double precision (a-h,o-z)
      dimension f(251),af(10),g(251),ag(10),dr(251)
c
c    initialisation and development coefficients of yk
c
      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
c     calcualation of zk
c
      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
c     calcualation of yk
c
      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
c
      subroutine llmesh
c
      include 'msxas3.inc'
c      include 'msxasc3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $ n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_),
     $ ichg(10,d_),kplace(at_),kmax(at_)
      complex v,vcons
c
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
      COMMON /LLM/ ALPHA, BETA
c
      character*8 name0 ,nsymbl         !added 29/3/2013
c
      common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de

      complex vcon,xe,ev
c
      logical do_r_in
c
c--------------------------------------------------------
c
c      write(69,*) ' in sub cont_sub nat = ', nat
C
C CONSTRUCT LINEAR-LOG MESH
C
      DO_R_IN = .FALSE.
C
      DO N = 1, NDAT
C
         ZAT = FLOAT(NZ(N))
         IF(ZAT.EQ.0.0) THEN
            X0 = 9.0
C            X0 = 10.0
         ELSE
            X0 = 9.0 + LOG(ZAT)
C            X0 = 10.0 + LOG(ZAT)
         ENDIF
         RKMX = R(KMAX(N),N)
         DPAS = 0.1/RKMX
!         IF(DPAS.GT.0.03) DPAS = 0.03
         IF(DPAS.GT.0.02) DPAS = 0.02
         ALPHA = 0.5
         BETA = 1.0
         RHO_1 = -BETA*X0
         R_SUB = RS(N)
         XMAX = ALPHA*R_SUB + BETA*LOG(R_SUB)
         KMX(N) = NINT ( (XMAX + X0 + DPAS) / DPAS )
         IF(KMX(N).GT.RDX_) THEN
            WRITE(6,*) 
     &      'INCREASE PARAMETER RDX_. IT SHOULD BE AT LEAST ', KMX(N)
            CALL EXIT
         ENDIF
         NR = KMX(N)
         KPLX(N) = KMX(N)-3
C
C     CHECK IN LLMESH
c         write(6,'(2i5,4e15.6)') n,kmx(n),rkmx,r_sub,xmax,rho_1
c         flush(6)
C
         CALL LINLOGMESH ( I_END, HX(N), X(1,N), RX(1,N), DO_R_IN,  
     &                        KMX(N), KPLX(N), NR, RHO_1, R_SUB, R_IN, 
     &                        ALPHA, BETA )
c
c      if(n.eq.ndat) then

c         if(n.eq.ndat) write(6,*) (x(i,n), rx(i,n), i=1,kmx(n))
c      endif
C
c      print *, ' inside llmesh loop ', kmx(n)
c      do i = 1, kmx(n)
c         write(69,*) x(i,n), rx(i,n)
c          print *, x(i,n), rx(i,n)
c      enddo
c
      ENDDO
c
c----------------------------------------------------------
c
      return
      end
c
      subroutine linlogmesh ( i_end, drho, rho, r_real, do_r_in,  
     &                        kmax, kplace, nr, rho_1, r_sub, r_in, 
     &                        alpha, beta )
!
!   Set up log + linear radial mesh.
!
!          rho = alpha * r_real + beta * log ( r_real )
!   
!          rho_i = rho_{i-1} + drho
!
!
!   i_end   : point at inscribed sphere, for outersphere not used always 0.
!   drho    : constant step in loglinear space
!   rho     : log + linear mesh with constant step.
!   r_real  : real radial mesh correponding to the step of loglinear mesh
!   do_r_in : option for outer sphere
!   kmax    : three points after kplace
!   kplace  : point on the bounding sphere where the Wronskian is estimated.
!   nr      : number of radial mesh points
!   rho_1   : the first point in loglinear space
!   r_sub   : radius of bounding sphere in loglinear space, r_sub => rho(kplace)
!   r_in    :
!   alpha   : parameter for linear part 
!   beta    : parameter for log part

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

!...input
!    logical,                intent ( in  ) :: do_r_in
!    integer,                intent ( in  ) :: nr, kmax, kplace
!    real ( kind = double ), intent ( in  ) :: rho_1, r_sub, r_in, alpha, beta

!...output
!    integer,                intent ( out )                  :: i_end
!    real ( kind = double ), intent ( out )                  :: drho
!    real ( kind = double ), intent ( out ), dimension ( : ) :: rho, r_real

!...local
!    logical                :: check
!    integer                :: i, k
!    real ( kind = double ) :: rn, rhon, epsilon
c
      dimension rho(kmax), r_real(kmax)
c
      logical do_r_in, check

      myrank = 0
      dzero = 0.0
      check = .false.
c      check = .true.

      rho ( kplace ) =  alpha * r_sub + beta * log ( r_sub )

      rho ( 1 ) = rho_1
      drho = ( rho ( kplace ) - rho ( 1 ) ) / real ( kmax - 4 )

      rho ( kmax ) = rho ( kplace ) + 3.00 * drho
!
!      write(6,*) rho(1), rho(kmax), drho
!      write(6,*) ' ** '

!    if ( myrank .eq. 0 ) then
!      write ( unit = 6, fmt = * ) " alpha =", alpha, " beta ", beta
!      write ( unit = 6, fmt = * ) "rho_1 =", rho ( 1 ), &
!        & " rho ( kplace ) =", rho ( kplace ), " rho ( kmax ) = ", rho ( kmax )
!      write ( unit = 6, fmt = * ) "drho =", drho, " nr =", nr
!    end if

!
      do i = 2, nr

        rho ( i ) = rho ( i - 1 ) + drho

      end do
!
!.....Solve non-linear equation by Newton method
!
      rhon = rho ( kplace )
      r_real ( kplace ) = r_sub
!      rn = ( rhon - beta * log ( rhon ) ) / alpha  ! correction 2nd April 2013
      rn = ( rhon - beta * log ( r_sub ) ) / alpha
!
      do i = kplace - 1, 1, - 1 

         k = 0
!
      do
!
!       MPI
!
        if ( check .and. myrank .eq. 0 ) then

          write ( unit = 98, fmt = * )  i, rn

        end if
!
!       MPI

!
        if ( rn .eq. dzero ) then
!
!         MPI
!
          if ( myrank .eq. 0 ) then

            write ( unit = 6, fmt = * ) "Error occurred at radialmesh!", 
     &                         "rn = 0"

          end if
!
!         MPI
!
          stop

        end if
!

        epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / 
     &       ( alpha * rn + beta )
!
!       MPI
!
        if ( check .and. myrank .eq. 0 ) then

          write ( unit = 98, fmt = * ) i, rn, epsilon

        end if
!
!       MPI
!

        rn = rn * ( 1.00 - epsilon )
!
        if ( rn .lt. 0.0 ) then

          rn = r_real ( i + 1 ) * 0.100 ** k
          k = k + 1

        end if
!
!
        if ( abs ( epsilon ) .le. 1.0e-6 ) then

          exit

        end if
!
      end do
!
      r_real ( i ) = rn

!      write(6,*) i, r_real ( i )

      end do
!

      rhon = rho ( kplace )
!      rn = ( rhon - beta * log ( rhon ) ) / alpha   ! correction 2nd April 2013
      rn = ( rhon - beta * log ( r_sub ) ) / alpha

!
      do i = kmax - 2, nr

         k = 0
!
        do
!
!       MPI
!
          if ( check .and. myrank .eq. 0 ) then

             write ( unit = 98, fmt = * )  i, rn

          end if
!
!       MPI
!

          epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / 
     &       ( alpha * rn + beta )
!
!       MPI
!
          if ( check .and. myrank .eq. 0 ) then

             write ( unit = 98, fmt = * ) i, rn, epsilon

          end if
!
!       MPI
!
          rn = rn * ( 1.00 - epsilon )
!
          if ( rn .lt. 0.0 ) then

             rn = r_real ( i - 1 ) * 10.00 ** k
             k = k + 1

          end if
!
          if ( abs ( epsilon ) .le. 1.0e-6 ) then

          exit

          end if
!
        end do
!
      r_real ( i ) = rn

      end do
!
!   MPI
!
      if ( check .and. myrank .eq. 0 ) then

      write ( unit = 99, fmt = * ) '#   i    rho    r    rho ( r )', 
     &                             ' dr'
      i = 1
      write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i, rho ( i ), 
     &        r_real ( i ), 
     &        alpha * r_real ( i ) + beta * log ( r_real ( i ) )
!
      do i = 2, nr

        write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i,rho ( i ),
     &          r_real ( i ), 
     &          alpha * r_real ( i ) + beta * log ( r_real ( i ) ), 
     &          r_real ( i ) - r_real ( i - 1 )

      end do
!
      end if
!
!   MPI
!
      if ( .not. do_r_in ) then
!      if ( do_r_in ) then

      i = 1
!
      do
!
        if ( r_real ( i ) > r_in ) then

          exit

        end if
!
        i = i + 1

      end do
!
      i_end = i

      else

      i_end = 0

      end if
!

!     if ( myrank .eq. 0 ) then

!      write ( unit = 6, fmt = * )
!      write ( unit = 6, fmt = "( a7, i5, a20, f12.7 )" ) &
!        & "kplace = ", kplace, ", r_real ( kplace ) = ", r_real ( kplace )
!      write ( unit = 6, fmt = "( a7, i5, a20, f12.7, a10, f12.7 )" ) &
!        & "kmax = ", kmax, ", r_real ( kmax ) = ", r_real ( kmax ), &
!        & ", r_sub = ", r_sub
!      write ( unit = 6, fmt = * )
!      write ( unit = 6, fmt = * ) "**** r_in = r_real (",i_end,")= ", &
!        & r_real ( i_end )

!     end if

      end subroutine linlogmesh
C
C
      SUBROUTINE VREL
C
      include 'msxas3.inc'

      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
C
      COMMON /FCNR/KXE,H(D_),VCONS(2),
     1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_)
      COMPLEX VCONS,V
C 
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,xe,ev
      character*8 nsymbl,name0
c

      COMPLEX ZTMP(0:RD_), ZX, DZX, D2ZX
      REAL*4 RTMP(0:RD_)
C
      DATA FSC,FSCS4 /7.29735E-3,1.331283E-5/ 
C
C INTERPOLATE POTENTIAL ON THE LOG-LINEAR MESH 
C AND ADD RELATIVISTIC CORRECTIONS, INCLUDING SPIN-ORBIT INTERACTION
C
C      WRITE(7,*) ' I RX(I), VX(I), VXSR(I), VXSO(I), BX(I) '
C
      RTMP(0) = 0.0
C
      DO N = 1, NDAT
C
         ZAT = FLOAT(NZ(N))
         ZTMP(0) = CMPLX(2.0*ZAT,0.0)
C
         DO I = 1, KMAX(N)
            RTMP(I) = R(I,N)
         ENDDO
C
         NS = N
         DO IS=1,NSPINS         
            DO I = 1, KMAX(N)
               ZTMP(I) = -V(I,NS) * RTMP(I)
C              WRITE(6,*) N, IS, I, RTMP(I), ZTMP(I)
            ENDDO

C
            DO I=1,KMX(N)
C
C        FIND NEAREST POINTS - INITIALIZE HUNTING PARAMETER (SUBROUTINE NEAREST)
C
            JLO=1
            CALL NEAREST1(RTMP(0), KMAX(N)+1, RX(I,N),
     &                            IP1, IP2, IP3, JLO)
            IP1 = IP1 - 1
            IP2 = IP2 - 1
            IP3 = IP3 - 1
C
C       INTERPOLATE ZR(I) AND RHOTOT(I)
C
               CALL CINTERP_QUAD( RTMP(IP1),ZTMP(IP1),
     &                          RTMP(IP2),ZTMP(IP2),
     &                          RTMP(IP3),ZTMP(IP3),
     &                          RX(I,N),ZX,DZX,D2ZX )
               VX(I,NS) = -ZX/RX(I,N)
               BX(I,NS) = FSCS4/(1.0 + FSCS4*(E - VX(I,NS)))
               DVX(I,NS) = -(DZX/RX(I,N) - ZX/RX(I,N)**2)
               VXR(I,NS) = VX(I,NS) - FSCS4*(E - VX(I,NS))**2 + 
     &                      0.5*BX(I,NS)*( -D2ZX/RX(I,N) + 
     &                      1.5*BX(I,NS)*(DVX(I,NS))**2 )
               VXSO(I,NS) = BX(I,NS)*DVX(I,NS)/RX(I,N)
C              WRITE(15,1) I, RX(I,N), VX(I,NS), VXR(I,NS), 
C     &                       VXSO(I,NS), BX(I,NS) 
1     FORMAT(I5,9E15.6)   
            ENDDO
         NS=NS+NDAT
         ENDDO
C
      ENDDO
C 
      RETURN
C
      END
C
C
      SUBROUTINE NEAREST1(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3,
     &                  JLO)
C
C     FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X
C     AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3
C     This subroutine was taken from Numerical Recipes,
C     W. H. Press, B. F. Flanney, S. A. Teukolsky and W.  T.
C     Vetterling, page 91. Originally called HUNT
C      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C      COMMON/MESH_PARAM/JLO
C
      DIMENSION XX(*)
      LOGICAL ASCND
      ASCND=XX(N).GT.XX(1)
C
C EXTRAPOLATE BELOW LOWEST POINT
C
      IF(X.LE.XX(1))THEN
          I_POINT_1=1
          I_POINT_2=2
          I_POINT_3=3
          RETURN
      END IF
C
C EXTRAPOLATE BEYOND HIGHEST POINT
C
      IF(X.GE.XX(N))THEN
          I_POINT_1=N-2
          I_POINT_2=N-1
          I_POINT_3=N
          RETURN
      END IF
      IF(JLO.LE.0.OR.JLO.GT.N)THEN
        JLO=0
        JHI=N+1
        GO TO 3
      ENDIF
      INC=1
      IF(X.GE.XX(JLO).EQV.ASCND)THEN
1       JHI=JLO+INC
        IF(JHI.GT.N)THEN
          JHI=N+1
        ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN
          JLO=JHI
          INC=INC+INC
          GO TO 1
        ENDIF
      ELSE
        JHI=JLO
2       JLO=JHI-INC
        IF(JLO.LT.1)THEN
          JLO=0
        ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN
          JHI=JLO
          INC=INC+INC
          GO TO 2
        ENDIF
      ENDIF
3     IF(JHI-JLO.EQ.1)THEN
          IF((JLO+1).EQ.N)THEN
              I_POINT_1=JLO-1
              I_POINT_2=JLO
              I_POINT_3=JLO+1
          ELSE
              I_POINT_1=JLO
              I_POINT_2=JLO+1
              I_POINT_3=JLO+2
          END IF
      RETURN
      END IF
      JM=(JHI+JLO)/2
      IF(X.GT.XX(JM).EQV.ASCND)THEN
        JLO=JM
      ELSE
        JHI=JM
      ENDIF
      GO TO 3
      END
C
C
        SUBROUTINE CINTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4,DY4,D2Y4)
C
C       INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2)
C       TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT
C       PARAMETERS.  THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C
C
        COMPLEX Y1, Y2, Y3, Y4, DY4, D2Y4
        COMPLEX TOP, A, B, C
C
        TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1)
        BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1)
        B = TOP/BOTTOM
        A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1)
        C = Y3 - A*X3*X3 - B*X3
        Y4 = A*X4*X4 + B*X4 + C
        DY4 = 2.0*A*X4 + B
        D2Y4 = 2.0*A
C
        RETURN
        END
C
C
      subroutine smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax,
     &                   ramfnr,ramfsr,ramfsop,ramfsoa)
c
      include 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
C
C
      COMMON/BESSEL/SBF(LTOT_),DSBF(LTOT_),SHF(LTOT_),DSHF(LTOT_)
      COMPLEX*16 SBF,DSBF,SHF,DSHF
      COMPLEX*16 SBFX(LTOT_),DSBFX(LTOT_),SHFX(LTOT_),DSHFX(LTOT_)
C
      COMPLEX*16 Y0(0:LMAX_), Y1(0:LMAX_)
      DOUBLE PRECISION RX1, RX2, EXPR
C
      COMMON /FCNR/KXE, H(D_),VCONS(2),
     1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_)
      COMPLEX VCONS,V 
C 
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
      COMPLEX VXP(RDX_), VXA(RDX_), BD(RDX_)
C       
      COMPLEX PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), PAX(RDX_,F_)
      COMPLEX PSX(N_), DPSX(N_), STMAT, RAMFX(N_)
      COMPLEX PS0(N_), DPS0(N_), STMAT0, RAMF0(N_)
      COMPLEX PS1(N_), DPS1(N_), STMAT1, RAMF1(N_)
      COMPLEX PS2(N_), DPS2(N_), STMAT2, RAMF2(N_)
      COMPLEX RAMF00, RAMF01, RAMF02
C
      COMPLEX PKMX, PKMX1
C
      COMMON /LLM/ ALPHA, BETA
c
      common /flag/ inmsh,inv,inrho,insym,iovrho,iosym,
     1 imvhl,nedhlp
c
      complex pss(6),dpss(6), 
     &        ramfnr(n_), ramfsr(n_), ramfsop(n_), ramfsoa(n_)
c
      character*8 name0 ,nsymbl         !added 29/3/2013
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,ev,xe
c
      common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_)
      complex atmnr, atmsr, atmsop, atmsoa
c
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
c
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg
      real*4 einc,esct,scangl,qt,lambda
c
	common/auger/calctype,expmode,edge1,edge2
  	character*3 calctype, expmode
	character*2 edge1,edge2
c
      complex csqrt,arg,arg1
      COMPLEX ONEC
c
      character*2 relc
c
      data zero,one,two/0.0,1.0,2.0/
      data pi/3.14159265358979/,srt2/1.414213562/
c
      data fsc,fscs4 /7.29735e-3,1.331283e-5/
c
c.....Define bd for non relativistic calculation
c
        do i = 1, rdx_
           bd(i) = cmplx(fscs4,0.0)
        enddo

C
      onec = (1.0,0.0)
      if(e.eq.0.0) e = 1.0e-8
      ns=(nns-1)*ndat
C
      do  5  j=1,ndim
      atmnr(j)=(0.00,0.00)
      atmsr(j)=(0.00,0.00)
      atmsop(j)=(0.00,0.00)
   5  atmsoa(j)=(0.00,0.00) 
c
c      write(70,*) ' non relativistic stmat and phase shifts '
c      write(80,*) ' scalar relativistic stmat and phase shifts '
c      write(90,*) ' spin-orbit stmat and phase shifts '
c
c calculate t-matrix elements:
c                    stmat: inverse t-m elements (atomic spheres)
c                    ramf:  for normalization of ps(k) functions
c           
c      write(19,18) e, xe
      write(81,*) ' e, vcon, xe, relc =', e, real(vcon), 
     &              real(xe), relc
c      write(84,*) ' e, vcon, xe =', e, vcon, xe
c  18  FORMAT(' E =', F10.5,5X,' XE =',2F10.5,' GAMMA =',F10.5)
c
      do 60 na=1,nuatom
      write(35,77) na
      write(70,77) na
      write(80,77) na
      write(90,77) na
      ns=ns+1
   25 nt0a=n0(na)            
      ntxa=nt0a+nterms(na)-1
	  if (na.eq.nas) then
	   nstart=nt0a
	   nlast=ntxa
	  endif
      l=-1
      nlat=-1
      arg=xe*rs(na)
      ml=lmaxn(na)+1
      if (ml.lt.3) ml = 3
      call csbf(arg,xe,ml,sbf,dsbf)
      call cshf2(arg,xe,ml,shf,dshf)
      npabs = 0
C
   43 do 45 nn=nt0a,ntxa

      l=ln(nn)
      nlat=nlat+1
      npabs=npabs+1
      if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss
      if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45
      np=npabs
C
c      if(relc.eq.'nr') then 
c
          rx1 = dble(rx(1,na))
          rx2 = dble(rx(2,na))          
          y0(l) = dcmplx(rx1**(l+1),0.d0)
          y1(l) = dcmplx(rx2**(l+1),0.d0)
c
          call pgenll1m(l, e, hx(na), rx(1,na), vx(1,ns), bd, 
     &                  kmx(na), kplx(na), rs(na), px(1,np), psx(nn),
     &                  dpsx(nn), ramf00, stmat, y0(l),y1(l))
c
      atmnr(nn)=stmat
      ramfx(nn)=ramf00
      ramfnr(nn) = ramf00

      write(70,1000) xe/0.52917715, stmat
      if(relc.eq.'nr') write(35,1000) xe/0.52917715, stmat
c     definition of stmat as exp(-i*delta)*sin(delta)
	phase=sign(-1.,real(stmat))*
     1         asin(sqrt(abs(aimag(stmat))))
	 if(phase.lt.0.0) phase=phase+3.1415926
       write(71,1001)e,xe,na,nlat,stmat,phase
 1001 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3,
     &       2x,2e12.6,f10.5,2x,2e12.6,f10.5)
 1000 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6,5x,e12.6,5x,e12.6)
c 1000 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9,5x,f12.9,5x,f12.9)

c
c      elseif(relc.eq.'sr') then
c          
          rx1 = dble(rx(1,na))
          rx2 = dble(rx(2,na))
          expr = 0.5d0 + sqrt( dfloat(l*(l+1)) +1 - dble(fsc*z(na))**2 )
          y0(l) = dcmplx(rx1**expr,0.d0)
          y1(l) = dcmplx(rx2**expr,0.d0)
          call pgenll1m(l, e, hx(na), rx(1,na), vxr(1,ns), bx(1,ns), 
     &                  kmx(na), kplx(na), rs(na), px0(1,np), ps0(nn),
     &                  dps0(nn), ramf00, stmat0, y0(l),y1(l))
c
      if(calctype.eq.'els'.or.calctype.eq.'e2e') then
         do k = 1, kmx(na)
            if(nks.eq.1) p1(k,l+1,na) = px0(k,np) !npabs = np
            if(nks.eq.2) p2(k,l+1,na) = px0(k,np)
            if(nks.eq.3) p3(k,l+1,na) = px0(k,np)
         enddo
            if(nks.eq.1) ramfsr1(l+1,na) = ramf00
            if(nks.eq.2) ramfsr2(l+1,na) = ramf00
            if(nks.eq.3) ramfsr3(l+1,na) = ramf00
      endif
c
      atmsr(nn)=stmat0
      ramfsr(nn)=ramf00

      write(80,1000) xe/0.52917715, stmat0
      if(relc.eq.'sr') write(35,1000) xe/0.52917715, stmat0
C
c     definition of stmat as exp(-i*delta)*sin(delta)
C
	phase=sign(-1.,real(stmat0))*
     1         asin(sqrt(abs(aimag(stmat0))))
	 if(phase.lt.0.0) phase=phase+3.1415926
       write(81,1001)e,xe,na,nlat,stmat,phase
c
c      elseif(relc.eq.'so') then
c
          ilm = 2
          if(l.eq.0) ilm = 1
          do il = 1, ilm
c
             if(il.eq.1) then 
               do i = 1, kmx(na)
                  vxp(i) = vxr(i,ns) + float(l)*vxso(i,ns)
               enddo
               rx1 = dble(rx(1,na))
               rx2 = dble(rx(2,na))
               expr = 0.5d0 + sqrt( dfloat(l+1)**2 -dble(fsc*z(na))**2 )
               y0(l) = dcmplx(rx1**expr,0.d0)
               y1(l) = dcmplx(rx2**expr,0.d0)
             call pgenll1m(l, e, hx(na), rx(1,na), vxp, bx(1,ns), 
     &                     kmx(na), kplx(na), rs(na), ppx(1,np),  
     &                     ps1(nn), dps1(nn), ramf01, stmat1, 
     &                     y0(l),y1(l))
               if(na.eq.nas)
     &         write(81,1) 'rp', na, l, real(stmat1), 1.0/stmat1, 
     &                     real(ramf01), e
             else
               do i = 1, kmx(na)
                 vxa(i) = vxr(i,ns) - float(l+1)*vxso(i,ns)
               enddo
               rx1 = dble(rx(1,na))
               rx2 = dble(rx(2,na))
               expr = 0.5d0 + sqrt( dfloat(l)**2 - dble(fsc*z(na))**2 )
               if(l.eq.0) expr = 0.5d0 +sqrt( 1.0d0 -dble(fsc*z(na))**2)
               y0(l) = dcmplx(rx1**expr,0.d0)
               y1(l) = dcmplx(rx2**expr,0.d0)
             call pgenll1m(l, e, hx(na), rx(1,na), vxa, bx(1,ns), 
     &                     kmx(na), kplx(na), rs(na), pax(1,np),  
     &                     ps2(nn), dps2(nn), ramf02, stmat2, 
     &                     y0(l),y1(l))
c
             endif
c
          enddo
c
c
      atmsop(nn)=stmat1
      ramfsop(nn)=ramf01
      atmsoa(nn)=stmat2
      ramfsoa(nn)=ramf02

      write(90,1000) xe/0.52917715, stmat1, stmat2
      if(relc.eq.'so') write(35,1000) xe/0.52917715, stmat1, stmat2
C
c     definition of stmat as exp(-i*delta)*sin(delta)
C
	phase1=sign(-1.,real(stmat1))*
     1         asin(sqrt(abs(aimag(stmat1))))
	phase2=sign(-1.,real(stmat2))*
     1         asin(sqrt(abs(aimag(stmat2))))
	 if(phase.lt.0.0) phase=phase+3.1415926
       write(91,1001)e,xe,na,nlat,stmat1,phase1,stmat2,phase2
c

c      endif
1     format(a3,2i5,10e13.5)
30    format(5i3,8e13.5)
c      
c
   45 continue
   60 continue
c
  77  FORMAT('--------------------------  ATOM ',I3,
     1       '  -----------------------')
c
c
c calculate singular solution inside muffin tin sphere for the absorbing
c atom, matching to shf in interstitial region
c 
      if(calctype.eq.'els'.and.nks.eq.3) 
     &   write(6,*)'   store irregular solution'
   90 nl=0
      lmsing=5
      mout=4
      nst=n0(nas)
      nlst=n0(nas)+nterms(nas)-1
c      if(nks.eq.3) write(6,*)' nst =',nst,' nlst =',nlst
      l=-1
      ml=lmaxn(nas)+1
      if (ml.lt.3) ml = 3   
      kpp = kmx(nas) -2
      arg=xe*rx(kpp,nas)
      call cshf2(arg,xe,ml,sbfx,dsbfx)
      arg1=xe*rx(kpp-1,nas)
      call cshf2(arg1,xe,ml,shfx,dshfx)
c
      do n=nst,nlst
         l=ln(n)
         if(l.gt.lmsing) cycle
         nl=nl+1
         np=npss+nl
         np1=nl
c
      pkmx = cmplx(sbfx(l+1))*arg/pi
      pkmx1 = cmplx(shfx(l+1))*arg1/pi
c
        call pgenll2( l, e, hx(nas), rx(1,nas), vx(1,nas), bd,
     &                kpp, px(1,np), pkmx, pkmx1 ) 

          call pgenll2( l, e, hx(nas), rx(1,nas), vxr(1,nas),  
     &                  bx(1,nas), kpp, px0(1,np), pkmx, pkmx1 ) 

          ilm = 2
          if(l.eq.0) ilm = 1
c
          do i = 1, kmx(nas)
             vxp(i) = vxr(i,nas) + float(l)*vxso(i,nas)
             vxa(i) = vxr(i,nas) - float(l+1)*vxso(i,nas)
          enddo
c
          do il = 1, ilm
             if(il.eq.1) 
     &       call pgenll2( l, e, hx(nas), rx(1,nas), vxp, 
     &                     bx(1,nas), kpp, ppx(1,np), pkmx, pkmx1 )
             if(il.eq.2) 
     &       call pgenll2( l, e, hx(nas), rx(1,nas), vxa,
     &                     bx(1,nas), kpp, pax(1,np), pkmx, pkmx1 )
          enddo
c
      if(calctype.eq.'els') then
         if(nks.eq.2) then
            do k = 1, kmx(nas)
               p2irreg(k,l+1) = px0(k,np)
c              write(6,*) l, rx(k,nas), px0(k,np)
            enddo
         elseif(nks.eq.3) then
            do k = 1, kmx(nas)
               p3irreg(k,l+1) = px0(k,np)
c            write(6,*) l, rx(k,nas), px0(k,np)
            enddo
         endif
      endif
c
      enddo
c
c
      return
c
      end
c
c

      subroutine pgenll1m(l, en, h, rx, v, b, kmax, kplx, rs,  
     &                     p, ps, dps, ramf, stmat, y0, y1 )
c
c
      include 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
c
      common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_)
      complex*16 sbf,dsbf,shf,dshf
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout
      complex vcon,xe,ev
c
      common /llm/ alpha, beta
c
      complex v(kmax), p(kmax), b(kmax), ps, dps, ramff, ramf, stmat, x
      complex*16 y0, y1, pd(kmax)
c
      dimension rx(kmax)
c
      double precision dfl, a, hd, hsq12, rxi, den, arb2, 
     &                 alphad, betad, rlv, amv
      complex*16 dvi
c
      complex*16 um(0:kmax), vm(0:kmax), 
     &           am(0:kmax), bm(0:kmax)
c
c
      data pi/3.141592653589793d0/, fsc/7.29735E-3/
c
c     calculate coefficients um(m) and vm(m).
c     inv = .true. : y0 first starting point; y1 last starting point
c     inv = .false. : y0, y1 first two starting points at rx(1) and rx(2)
c     In this particular case um=/0.
c

      vm(1) = (0.d0,0.d0)
      um(1) = (1.d0,0.d0)
      am(0) = (0.d0,0.d0)
      bm(0) = (0.d0,0.d0)
c
      alphad = dble(alpha)
      betad = dble(beta)
      den = dble(en)
      dfl = dble(float(l))
      a = (dfl + 1)*dfl 
      hd = dble(h)
      hsq12 = hd*hd/12.d0
c
      do i = 1, kmax
        rxi = dble(rx(i))
        arb2 = (alphad*rxi + betad)**2
        dvi = dcmplx(v(i))
        am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a  -
     &          betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 
        bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) 
      enddo

      do i = 2, kmax-1
        vm(i) = am(i+1) / ( bm(i) - am(i-1)*vm(i-1) )
      enddo

      do i = 2, kmax
         um(i) = um(i-1)*am(i-1) / ( bm(i) - am(i-1)*vm(i-1) )
      enddo
c
        pd(1) = y0 * sqrt( alphad + betad/dble(rx(1)) )
        pd(2) = y1 * sqrt( alphad + betad/dble(rx(2)) )
        do i = 2, kmax - 1
          pd(i+1) = (pd(i) - um(i)*pd(1))/vm(i)       
        enddo
c
        do i = 1, kmax
          pd(i) = pd(i)*sqrt(dble(rx(i))/(alphad*dble(rx(i))+betad) ) * 
     &           dble(fsc)/2.0D0 /sqrt(dcmplx(b(i)))/ dble(rx(i))
          p(i) = cmplx(pd(i))
        enddo
c
      kplx3 = kplx - 3
      call interp(rx(kplx3),p(kplx3),7,rs,ps,dps,.true.) 
c
      x=dps/ps
      ramff=cmplx(sbf(l+1))*x-cmplx(dsbf(l+1))
c      stmat=(shf(l+1)*x-dshf(l+1))/ramff
      stmat=ramff/(cmplx(shf(l+1))*x-cmplx(dshf(l+1)))
      ramf=ramff*ps*rs*rs*pi
      ramf=ramf*xe/pi
c
c
      return
      end
c
c
      subroutine pgenll2( l, en, h, rx, v, b, kmax, p, pkmx, pkmx1 )
c
c     This subroutine for inward integration toward the origin
c
      common /llm/ alpha, beta
c
      complex v(kmax), p(kmax), b(kmax), pkmx, pkmx1
      dimension rx(kmax)
c
      double precision dfl, a, hd, hsq12, rxi, den, arb2, 
     &                 alphad, betad
c
      complex*16 um(0:kmax), vm(0:kmax), am(0:kmax), bm(0:kmax)
      complex*16 dvi, dnm 
c
      data pi/3.14159265/, fsc/7.29735E-3/
c
c     calculate coefficients um(m) and vm(m). 
c

      vm(kmax) = (0.d0,0.d0)
      um(kmax) = dcmplx(pkmx*sqrt( alpha + beta/rx(kmax) ))

      alphad = dble(alpha)
      betad = dble(beta)
      den = dble(en)
      dfl = dble(float(l))
      a = (dfl + 1)*dfl 
      hd = dble(h)
      hsq12 = hd*hd/12.d0
c
      do i = 1, kmax
        rxi = dble(rx(i))
        arb2 = (alphad*rxi + betad)**2
        dvi = dcmplx(v(i))
        am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a  -
     &          betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 
        bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) 
      enddo

      do i = kmax-1, 2, -1
         dnm = ( bm(i) - am(i+1)*vm(i+1) )
         vm(i) = am(i-1) / dnm
         um(i) = am(i+1) * um(i+1) / dnm
c      write(6,*) vm(i), um(i) 
      enddo


      p(kmax) = pkmx * sqrt( alpha + beta/rx(kmax) )
      p(kmax-1) = pkmx1 * sqrt( alpha + beta/rx(kmax-1) )

      do i = kmax-1, 2, -1
        p(i-1) = ( p(i) - cmplx(um(i))) / cmplx(vm(i))
      enddo

      do i = 1, kmax
         p(i) = p(i) * sqrt( rx(i)/(alpha*rx(i) + beta) ) *
     &           fsc/2.0 /sqrt(b(i))/ rx(i)
      enddo

      return
      end
c
C
      subroutine get_edge_gap(iz,ihole,i_radial,xion,eatom)
c
c
      implicit real*8(a-h,o-z)
c
c
      parameter ( mp = 251, ms = 30 )
c
      character*40  title
c
      common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy
c
      dimension dum1(mp), dum2(mp)
      dimension vcoul(mp), rho0(mp), enp(ms)
c
      title = ' '
c
      ifr=1
      iprint=0
C
      amass=0.0d0
      beta=0.0d0
c     
      call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint,
     1                   vcoul, rho0, dum1, dum2, enp, eatom)
c
      return
      end
C
C
      subroutine calc_edge(cip)
      implicit real*8 (a-h,o-z)
      real*4 cip
c
      include 'msxas3.inc'
      include 'msxasc3.inc'
c
      dimension etot(2)
c
c.....Find out ionization potential for chosen edge
c
      xion=0.0d0 !corrected 23 June 2017
      iz = nz(1)
      ihole1 = 0
c
      if(edge.eq.'k ') ihole2 = 1
      if(edge.eq.'l1') ihole2 = 2
      if(edge.eq.'l2') ihole2 = 3
      if(edge.eq.'l3') ihole2 = 4
      if(edge.eq.'m1') ihole2 = 5
      if(edge.eq.'m2') ihole2 = 6
      if(edge.eq.'m3') ihole2 = 7
      if(edge.eq.'m4') ihole2 = 8
      if(edge.eq.'m5') ihole2 = 9
      if(edge.eq.'n2') ihole2 = 11
      if(edge.eq.'n3') ihole2 = 12
      if(edge.eq.'n4') ihole2 = 13
      if(edge.eq.'n5') ihole2 = 14
      if(edge.eq.'n6') ihole2 = 15
      if(edge.eq.'n7') ihole2 = 16
c
      write(6,*) '                       ---'
      do i = 1, 2
c      
      ityhole = ihole1
c      if(i.eq.2) ityhole = ihole2 ----- corrected 23th June 2017
      if(i.eq.2) then 
         ityhole = ihole2
         xion = 1.0d0
      endif
c
      if(i.eq.1) write(6,*) ' total energy for atom in ground state '
      if(i.eq.2) write(6,*) ' total energy for atom with a hole in ', 
     &                        edge, ' edge'
c

      call get_edge_gap(iz,ityhole,ityhole,xion,etot(i))
c
      enddo
c
      cip = real(etot(2) - etot(1))*2.0
      cip = sign(cip,1.0)
      write(6,*) ' calculated ionization energy for edge ', edge,
     &           ' = ', cip*13.6, ' eV'
c
c.....Find out energy distance between edges and construct two edge 
c     dipole cross section
c
      xion=1.0d0
c
      if(edge.eq.'k '.or.edge.eq.'l1'.or.edge.eq.'m1'.or.edge.eq.'n1') 
     &   go to 15
      if(edge.eq.'l2'.or.edge.eq.'l3') then
       ihole1 = 3
       ihole2 = 4
      else if(edge.eq.'m2'.or.edge.eq.'m3') then
       ihole1 = 6
       ihole2 = 7
      else if(edge.eq.'m4'.or.edge.eq.'m5') then
       ihole1 = 8
       ihole2 = 9
      else if(edge.eq.'n2'.or.edge.eq.'n3') then
       ihole1 = 11
       ihole2 = 12
      else if(edge.eq.'n4'.or.edge.eq.'n5') then
       ihole1 = 13
       ihole2 = 14
      else if(edge.eq.'n6'.or.edge.eq.'n7') then
       ihole1 = 15
       ihole2 = 16
      endif
c
      do i = 1, 2
      
      ityhole = ihole1
      if(i.eq.2) ityhole = ihole2
c
      call get_edge_gap(iz,ityhole,ityhole,xion,etot(i))
c
      enddo
c
      detot = (etot(1) - etot(2))*2.0d0
      detot = sign(detot,1.0d0)
      if(edge.eq.'l2'.or.edge.eq.'l3') then 
        write(6,*) ' energy distance between edges l2 and l3  =  ',
     &           real( etot(1) - etot(2) )* 27.2, 'eV'
      elseif(edge.eq.'m2'.or.edge.eq.'m3') then
        write(6,*) ' energy distance between edges m2 and m3  =  ',
     &           real( etot(1) - etot(2) )* 27.2, 'eV'
      elseif(edge.eq.'m4'.or.edge.eq.'m5') then
        write(6,*) ' energy distance between edges m4 and m5  =  ',
     &           real( etot(1) - etot(2) )* 27.2, 'eV'
      endif
c
15    continue
c
      write(6,*) '                       ---'
c
      end
C
C
      SUBROUTINE RADIALX(NE,RELC,EIKAPPR)
      INCLUDE 'msxas3.inc'
      integer   at_,d_,rd_,ltot_,sd_
      parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1,
     $n_=ltot_*ua_,rd_=440,sd_=ua_-1)
C
c.....this subroutine calculates the radial matrix elements d(i)
c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for
c.....the regular (dmxx) and irregular solution (dmxx1) using a 
c.....linear-log mesh
c
      common/mtxele/ nstart,nlast
c
      common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2),
     &                qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3),
     &                dxxdir,dxxexc
      complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1,
     &        dxxdir,dxxexc
c
      common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins,
     1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_),
     3 lmaxx(at_),nz(at_),nsymbl(at_),
     4 neq(at_),name0,cip,emax,emin,de
      complex vcon,ev,xe
      character*8 nsymbl,name0
c
      common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_)
      complex*16 sbf,dsbf,shf,dshf
C
      COMMON /LLM/ ALPHA, BETA
C
      COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_),
     &               VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_),
     &               VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_)
      COMPLEX VX, VXR, DVX, BX, VXSO
C
C      COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_)
C      COMPLEX PX,DPX,PSX,DPSX,RAMFX
c
      COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), 
     &             PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_),
     &             RAMFSOA(N_)
      COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA
c
C
      COMMON/PDQIX/RPIX(RDX_), FNISX
      COMPLEX RPIX
C
      common /state/ natom(n_),ln(n_),nleq(at_),
     1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_),
     2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_)
C
c     ######### common pottype modified to consider also the Auger calcu
c
      common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1,
     *	i_absorber_hole2,i_norman,i_alpha,
     1    i_outer_sphere,i_exc_pot,i_mode
c
	common/auger/calctype,expmode,edge1,edge2
c
      common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss),
     &            p1(rdx_,npss,nef_),p2(rdx_,npss,nef_),
     &            p3(rdx_,npss,nef_),ramfsr1(npss,nef_),
     &            ramfsr2(npss,nef_),ramfsr3(npss,nef_),
     &            lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7)
      complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg
      real*4 einc,esct,scangl,qt,lambda
      complex qtc, arg, ydf, scprod
c
    	character*3 calctype, expmode, eikappr
	character*2 edge1,edge2
C
      common /lparam/lmax2(nat_),l0i
c
      DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_)
      COMPLEX RID,CRI,CRI1,DX,DX1,SMX0,SMX1
C
      CHARACTER*2 RELC
C
C
c***************************************************************************
c     note that here rpix(k) = r**3*pi(k). 
c     wf rpix(k) is already normalized
c     (see subroutine corewf)
c***************************************************************************
c
      pi = 3.1415926
c
      id = 1
      nq = nas
      kx = kmx(nq) - 3
      dh = hx(nq)
c
         write(6,*)' check orthogonality between core and continuum',
     &             ' state'
         np = l0i + 1
         do k = 1, kx
            if(relc.eq.'nr')
     &      rid(k)=rpix(k)*px(k,np+1)/(alpha*rx(k,nq) + beta)
            if(relc.eq.'sr')
     &      rid(k)=rpix(k)*px0(k,np+1)/(alpha*rx(k,nq) + beta)
         enddo
            call defint1(rid,dh,kx,scprod,id)
         write(6,*)' scalar product between core and continuum',
     &             ' state =', scprod/ramfsr(nstart+np) !*sqrt(xe/pi)
         write(6,*) ' sqrt(xe/pi) =', sqrt(xe/pi)
c
      if((calctype.eq.'els'.or.calctype.eq.'e2e')
     &   .and.eikappr.eq.'yes') then
         ydf=(0.0,0.0)
         qtc = cmplx(qt,0.0)
         ml=lmxne(nq,ne)+1
         if (ml.lt.3) ml = 3
         do np = 0, ml-1
            do k = 1, kx
               arg=qtc*rx(k,nq)
               call csbf(arg,ydf,ml,sbf,dsbf)
            if(relc.eq.'nr')
     &      rid(k)=rpix(k)*px(k,np+1)*cmplx(sbf(np+1))/
     1                    (alpha*rx(k,nq) + beta)
            if(relc.eq.'sr')
     &      rid(k)=rpix(k)*px0(k,np+1)*cmplx(sbf(np+1))/
     1                    (alpha*rx(k,nq) + beta)
            enddo
c            call defint1(rid,dh,kx,eelsme(np+1),id)
c            eelsme(np+1) = (eelsme(np+1)/ramfsr(nstart+np))**2*xe/pi
c            write(6,*) 'l =',np,'eelsme =', eelsme(np+1)
c            write(6,*) 'l =',np,'sqrt(eelsme) =', sqrt(eelsme(np+1))
         enddo
c
      endif
c
c  21  if(calctype.eq.'xpd'.or.eikappr.eq.' no') then
  21  if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or.
     &    calctype.eq.'rex'.or.eikappr.eq.' no') then
c
      do 100 i=1,2
      dmxx(i)=(0.,0.)
      dmxx1(i)=(0.,0.)
      if((l0i.eq.0).and.(i.eq.1))goto 100
      np = l0i + (-1)**i
C
      if(relc.eq.'nr') then
c
      DO 116 K=1,KX
  116 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      DMXX(I) = (CRI(KX)/RAMFNR(NSTART+NP))**2*(L0I-1+I)
c      dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i)
      DO 117 K=1,KX
  117 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 118 K=1,KX
  118 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,SMX0,ID) 
      DO 119 K=1,KX
  119 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,SMX1,ID) 
      DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFNR(NSTART+NP)
c      dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np)
c
      else if(relc.eq.'sr') then
      DO K=1,KX
         RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      ENDDO
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      DMXX(I) = (CRI(KX)/RAMFSR(NSTART+NP))**2*(L0I-1+I)
      DO 120 K=1,KX
  120 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 121 K=1,KX
  121 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,SMX0,ID) 
      DO 122 K=1,KX
  122 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,SMX1,ID) 
      DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSR(NSTART+NP)
c
      else if(relc.eq.'so') then
      DO K=1,KX
         RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      ENDDO
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      DMXX(I) = (CRI(KX)/RAMFSOP(NSTART+NP))**2*(L0I-1+I)
      DO 123 K=1,KX
  123 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 124 K=1,KX
  124 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,SMX0,ID) 
      DO 125 K=1,KX
  125 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,SMX1,ID) 
      DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSOP(NSTART+NP)
C
      DO K=1,KX
         RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      ENDDO
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      DMXXA(I) = (CRI(KX)/RAMFSOA(NSTART+NP))**2*(L0I-1+I)
      DO 126 K=1,KX
  126 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 127 K=1,KX
  127 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,DX,ID) 
      DO 128 K=1,KX
  128 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,DX1,ID) 
      DMXXA1(I) = (DX + DX1)*(L0I-1+I)/RAMFSOA(NSTART+NP)
c
      endif
 
  100 continue
C
c      write(6,*) ' radialx matrix elements from shell li = ', l0i
c      write(6,*) (real(dmxx(l)),aimag(dmxx(l)),l=1,2)
c      write(6,*) (real(dmxx1(l)),aimag(dmxx1(l)),l=1,2)
C
C.....CALCULATE RADIAL QUADRUPOLAR TRANSITION MATRIX ELEMENT 
C
      DO K = 1, KX
         RPIX(K) = RPIX(K) * RX(K,NQ)
      ENDDO
C
      M = 0
      DO 200 I=-2,2,2
      M = M + 1
      QMXX(M)=(0.,0.)
      QMXX1(M)=(0.,0.)
      LF = L0I + I
      IF(LF.LE.0) GO TO 200
      NP = L0I + I
C
      if(relc.eq.'nr') then
c
      DO 216 K=1,KX
  216 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      QMXX(M) = (CRI(KX)/RAMFNR(NSTART+NP))**2   
c      dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i)
      DO 217 K=1,KX
  217 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 218 K=1,KX
  218 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,SMX0,ID) 
      DO 219 K=1,KX
  219 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,SMX1,ID) 
      QMXX1(M) = (SMX0 + SMX1)/RAMFNR(NSTART+NP)   
c      dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np)
c
      else if(relc.eq.'sr') then
      DO K=1,KX
         RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      ENDDO
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      QMXX(M) = (CRI(KX)/RAMFSR(NSTART+NP))**2 
      DO 220 K=1,KX
  220 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 221 K=1,KX
  221 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,SMX0,ID) 
      DO 222 K=1,KX
  222 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,SMX1,ID) 
      QMXX1(M) = (SMX0 + SMX1)/RAMFSR(NSTART+NP) 
c
      else if(relc.eq.'so') then
      DO K=1,KX
         RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      ENDDO
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      QMXX(M) = (CRI(KX)/RAMFSOP(NSTART+NP))**2 
      DO 223 K=1,KX
  223 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 224 K=1,KX
  224 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,SMX0,ID) 
      DO 225 K=1,KX
  225 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,SMX1,ID) 
      QMXX1(M) = (SMX0 + SMX1)/RAMFSOP(NSTART+NP) 
C
      DO K=1,KX
         RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      ENDDO
      CALL INTEGRCM(RID,DH,KX,CRI,ID)
      QMXXA(M) = (CRI(KX)/RAMFSOA(NSTART+NP))**2  
      DO 226 K=1,KX
  226 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL INTEGRCM(RID,DH,KX,CRI1,ID) 
      DO 227 K=1,KX
  227 RID(K)=RID(K)*CRI(K)
      CALL DEFINT1(RID,DH,KX,DX,ID) 
      DO 228 K=1,KX
  228 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))*
     &       RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA)
      CALL DEFINT1(RID,DH,KX,DX1,ID) 
      QMXXA1(M) = (DX + DX1)/RAMFSOA(NSTART+NP) 
c
      endif
C
  200 CONTINUE
C
C.....RESET RPI(K) TO INITIAL VALUE
C
      DO K = 1, KX
         RPIX(K) = RPIX(K) / RX(K,NQ)
      ENDDO
C
      else   !PUT AUGER PART HERE
C
      endif
C
      RETURN
      END
C
C
      SUBROUTINE OSBF(X,Y,MAX,SBF,DSBF)
C      REAL*8 SBFK,SBF1,SBF2,XF1,PSUM
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C     GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR
C     FIRST DERIVATIVES WITH RESPECT TO R.  X=ARGUMENT= Y*R.
C     IF Y=0, NO DERIVATIVES ARE CALCULATED.  MAX MUST BE AT LEAST 3.
C     OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS.  MSBF - MODI-
C     FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS;
C     MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS
C
      DIMENSION SBF(MAX), DSBF(MAX)
      LOGICAL ORD
      ORD=.TRUE.
      GO TO 1
      ENTRY MSBF(X,Y,MAX,SBF,DSBF)
      ORD=.FALSE.
1     IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99
      IF( ABS(X).LT.0.50D0 ) GO TO 18
C
C     BESSEL FUNCTIONS BY DOWNWARD RECURSION
C
      SBF2=0.0D0
      SBF1=1.0D-25
      IF( ABS(X).LT.2.0D0) SBF1=1.0D-38
      JMIN=10+X
      KMAX=MAX+JMIN-1
      K=MAX
      XF1=2*KMAX+1
      IF (ORD) GO TO 11
      DO  10  J=1,KMAX
      SBFK=XF1*SBF1/X+SBF2
      SBF2=SBF1
      SBF1=SBFK
      IF (J.LT.JMIN) GO TO 10
      SBF(K)=SBFK
      K=K-1
10    XF1=XF1-2.0D0
      RAT=SINH(X)/(X*SBF(1))
      DSBF1=SBF2*RAT
      GO TO 16
11    CONTINUE  
      DO  12  J=1,KMAX
      SBFK=XF1*SBF1/X-SBF2
      SBF2=SBF1
      SBF1=SBFK
      XF1=XF1-2.0D0
      IF (J.LT.JMIN) GO TO 12
      SBF(K)=SBFK
      K=K-1
12    CONTINUE                 
   15 RAT=SIN(X)/(X*SBF(1))   
      DSBF1=-SBF2*RAT
   16 DO 17 K=1,MAX
   17 SBF(K)=RAT*SBF(K)
      GO TO 26
C
C     SMALL ARGUMENTS
C
   18 Z=X*X*0.50D0
      IF(ORD) Z=-Z
      A=1.0D0
      MMX=MAX
      IF (MAX.EQ.1.AND.Y.NE.0.0D0) MMX=2
      DO  30  J=1,MMX
      SBFJ=A
      B=A
      DO 31 I=1,20
      B=B*Z/(I*(2*(J+1)-1))
      SBFJ=SBFJ+B
      IF ( ABS(B).LE.1.0D-07* ABS(SBFJ  )) GO TO 29
   31 CONTINUE
29    IF (J.EQ.2) DSBF1=SBFJ
      IF (J.LE.MAX) SBF(J)=SBFJ
   30 A=A*X/ DFLOAT(2*J+1)
      IF (ORD) DSBF1=-DSBF1
      GO TO 26
      ENTRY OSNF(X,Y,MAX,SBF,DSBF)
      ORD=.TRUE.
      SBF2=-COS(X)/X
      IF (MAX.EQ.1 .AND. Y.EQ.0.0D0)  GO TO 2
      SBF1=(SBF2-SIN(X))/X
      DSBF1=-SBF1
      GO TO 2
      ENTRY MSNF(X,Y,MAX,SBF,DSBF)
      ORD=.FALSE.
      SBF2=COSH(X)/X
      IF (MAX.EQ.1 .AND. Y.EQ.0.0D0)  GO TO 2
      SBF1=(SINH(X)-SBF2)/X
      DSBF1= SBF1
      GO TO 2
      ENTRY MSHF(X,Y,MAX,SBF,DSBF)
      ORD=.FALSE.
      SBF2=EXP(-X)/X
      SBF1=-SBF2/X-SBF2
      DSBF1= SBF1
2     SBF(1)=SBF2
      IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99
      IF (MAX.EQ.1) GO TO 26
      SBF(2)=SBF1
      IF (MAX.EQ.2) GO TO 26
      XF1=3.0D0
      IF (ORD) GO TO 21
      DO 8  I=3,MAX
      SBFK=SBF2-XF1*SBF1/X
      SBF(I)=SBFK
      SBF2=SBF1
      SBF1=SBFK
8     XF1=XF1+2.0D0
      GO TO 26
21    DO  22  I=3,MAX
      SBFK=XF1*SBF1/X-SBF2
      SBF(I)=SBFK
      SBF2=SBF1
      SBF1=SBFK
22    XF1=XF1+2.0D0
26    IF (Y.EQ.0.0D0)  RETURN
      DSBF(1)=Y*DSBF1
      IF (MAX.EQ.1)  RETURN
      DO 9 I=2,MAX
    9 DSBF(I)=Y*(SBF(I-1)- DFLOAT(I)*SBF(I)/X)
      RETURN
99    WRITE(6,100) MAX
100   FORMAT ('       SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8)

      STOP                             2013
C
      END
C 

