epsi
/
msspec_python3
3
0
Fork 0
Code Issues 6 Pull Requests Releases Wiki Activity
msspec_python3/msspec/phagen/fortran/phagen_scf.f

14918 lines
434 KiB
Fortran
Raw Blame History

subroutine phagen()
c 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')
C!!!! INPUT FILE TO LOAD
open (idat,file='../input/input.ms',status='old')
C!!!!
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)
close(55)
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(441),rho0_hs(441)
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
!
C! 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
Reference in New Issue View Git Blame Copy Permalink