program phagen c .................................... C .. .. c .. Generates atomic phase shifts .. c .. for inequivalent atoms in a .. c .. given cluster. Prototypical .. c .. atoms selected automatically. .. c .. Muffin-tin radii and type of .. c .. final state potential selected .. c .. via input option .. C .. .. c .. By C.R. Natoli 15/10/93 .. C .. .. c .. This version can handle ES .. c .. ES = Empty Spheres 28/09/2007 .. C .. .. C .. Scalar-relativistic version .. C .. with spin-orbit selection .. C .. by C.R. Natoli 9 june 2011 .. C .. .. C .................................... c .................................... C c .. INCOMING WAVE BOUNDARY CONDITIONS c C .................................... C C bug corrected in subroutine C GET_CORE_STATE C (FDP 18th May 2006) C C bug corrected in subroutine C ALPHA0 (DS : 7th May 2007) C 2nd dimension r: 150 ---> UA_ C C LEED case (calctype = 'led') C added (DS : 30th May 2007). C C bug corrected in subroutine C SETEQS (DS+CRN 30th May 2007) : C z_shift=5.0 and i_z_shift=5 C instead of 0.0 and 0. C C bug corrected in subroutines C MOLDAT,GRPNEI,WRIDAT : C NEIMAX set to nat_ instead C of 350 in PARAMETER statement C (FDP+DS 4th June 2007) C C all error output redirected to C unit 6 (DS 4th March 2008). C C modified to handle high Z elements C (CRN : september 2008) C C cleaned : DS 17th November 2008 C C modified to impose lmaxt externally C (CRN : july 2009) C C modified to include quadrupole C radial matrix elements C (CRN : june 2012) C C File formats for radial integrals C modified (DS 8th january 2013) C C modified to introduce t-matrix C calculation in the eikonal approximation C (CRN : march 2013) C C bug corrected in routine linlogmesh: rhon ---> r_sub C (CRN : april 2013) C C modified to calculate tmatrix, radial integrals C and atomic cross sections on linearlog mesh C (CRN: september 2012 and april 2013) C C bug corrected in routine pgenll2: complex*16 dnm. C v potential converted to complex*16 in routines C pgenll1m and pgenll2 C (CRN: april 2013) C C bug corrected in the calculation of the total mfp = amfpt C (CRN: april 2014) C C modified to calculate eels regular radial matrix elements C (CRN: november 2014) C C modified to convert energy input data in data3.ms to Ryd C (CRN: november 2014) C C modified to calculate eels and xas/rexs irregular radial matrix elements C (CRN: juin 2015) C C modified to calculate e2e regular radial matrix elements C (CRN: december 2015) modification in subroutine smtxllm C statement 13824 C C bug corrected in subroutine calc_edge (xion = 0 for ground state) C (CNR: June 2017) implicit real*8 (a-h,o-z) c include 'msxas3.inc' include 'msxasc3.inc' c c.. constants c antoau = 0.52917715d0 pi = 3.141592653589793d0 ev = 13.6058d0 zero = 0.d0 c c.. threshold for linearity c thresh = 1.d-4 c c.. fortran io units c idat = 5 iwr = 6 c iwr = 16 iwf=32 iphas = 30 iedl0 = 31 iof = 17 c....................................................... c open (iwr,file='results.dat',form='formatted',status='unknown') write(iwr,1000) c... c open (idat,file='data/auger.ms',status='old') c open (iphas,file='phases.dat',status='unknown') c if (calctype.eq.'xpd') then call system('mkdir -p div/wf') call system('mkdir -p plot') call system('mkdir -p tl') open (iphas,file='div/phases.dat',form='formatted', 1 status='unknown') open (iedl0,file='div/exdl0.dat',form='unformatted', 1 status='unknown') open (iof,file='div/inf.xas',form='unformatted',status='unknown') c open (iwr,file='phagen_3.lis',status='unknown') open (unit=21,form='unformatted',status='scratch') open (60,file='div/file060.dat',form='formatted',status='unknown') open (50,file='div/filerme.dat',form='formatted', 1 status='unknown') c open (56,file='div/eelsrme.dat',form='formatted', c 1 status='unknown') open (unit=13,file='div/filepot.dat',form='formatted', 1 status='unknown') open (unit=14,file='div/filesym.dat',form='formatted', 1 status='unknown') open(unit=11,file='div/fort.11',status='unknown') c open(unit=56,file='div/nchannels.dat',status='unknown') open(unit=32,file='div/wf/wf1.dat',status='unknown') open(unit=33,file='div/wf/wf2.dat',status='unknown') open(unit=66,file='div/file066',status='unknown') c open(unit=15,file='div/vrel.dat',status='unknown') !in sub vrel c open(unit=34,file='wf3.dat',status='unknown') open(unit=70,file='div/tl-nr.dat',status='unknown') open(unit=71,file='div/phases-nr.dat',status='unknown') c open(unit=80,file='div/tl-sr.dat',status='unknown') open(unit=81,file='div/phases-sr.dat',status='unknown') c open(unit=90,file='div/tl-so.dat',status='unknown') open(unit=91,file='div/phases-so.dat',status='unknown') C C Storage of old t_l calculation (subroutine smtx) for reference C open(unit=95,file='div/tl_ref.dat',status='unknown') c open(unit=98,file='div/cshsm.dat',status='unknown') c open(unit=99,file='div/csllm.dat',status='unknown') c open(unit=69,file='check.log',status='unknown') c else c open(iphas,file='phasesaed.dat',form='formatted',status='unknown' c open (iwf,file='wfaed.dat',form='formatted',status='unknown') c open(iedl0,file='exdl0aed.dat',form='unformatted', c * status='unknown') c open (iof,file='infaed.xas',form='unformatted',status='unknown') c open (iwr,file='phagen_12aed.lis',status='unknown') c write(iwr,*)'ciao' c open (unit=21,form='unformatted',status='scratch') c open (60,file='file060aed.dat',form='formatted',status='unknown') c open (50,file='fileatcsaed.dat',form='formatted',status='unknown' c open (unit=13,file='filepotaed.dat',form='formatted', c 1 status='unknown') c open (unit=14,file='filesymaed.dat',form='formatted', c 1 status='unknown') c open(unit=11,file='fortaed.11',status='unknown') c open(unit=32,file='wf1aed.dat',status='unknown') c open(unit=33,file='wf2aed.dat',status='unknown') c open(unit=66,file='fortaed.66',status='unknown') c open(unit=34,file='wf3aed.dat',status='unknown') c open(unit=35,file='tlaedmio3.dat',status='unknown') c open(unit=55,file='radaedmio3.dat',status='unknown') c endif c rewind idat rewind iwf rewind iphas rewind iedl0 rewind iof c c read control cards c call inctrl c c read title cards c call intit(iof) c c read atomic coordinates cards (internal or cartesian) c call incoor c c compute atomic phase shifts if required c call calphas c c normal end c write(iwr,1100) c c.. c close(69) close(70) close(71) close(80) close(81) close(90) close(91) close(21) close(60) close(13) close(14) close(15) close(7) close(50) close(56) close(35) close(iwf) close(iphas) c 1000 format(1x,65('_'),//,31x,'PHAGEN',/,1x,65('_'),/) 1100 format(//,15x,' ** phagen terminated normally ** ',//) c end c subroutine inctrl implicit real*8 (a-h,o-z) include 'msxas3.inc' c include 'msxasc3.inc' c real*4 emin,emax,delta,cip,gamma,eftri,db common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), & ramfsr2(npss,nef_),ramfsr3(npss,nef_), & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg real*4 einc,esct,scangl,qt,lambda c common/typot/ ipot c c I define the shells and orbitals of the primary core hole, and the c two holes in the final state: c character shell,shell1,shell2,orbital1,orbital,orbital2 c................................................................ namelist/job/edge,edge1,edge2,l2h,potype,norman,absorber,coor, $ emin,emax,delta,gamma,eftri,cip,vc0,rs0,vinput,eikappr,rsh,db, $ lmaxt,ovlpfac,ionzst,charelx,calctype,potgen,lmax_mode,relc, $ einc,esct,scangl,optrsh,enunit,lambda,expmode c c initialize namelist c vinput = .false. potype='hedin' potgen='in' cip=0.0 relc='nr' eikappr=' no' coor='angs' edge='k' edge1='k' edge2='k' lmaxt=60 lmax_mode=2 l2h=0 absorber = 1 charelx = 'ex' norman = 'stdcrm' ovlpfac=0.d0 ionzst='neutral' c mode = 0 calctype='xpd' expmode='cis' optrsh='n' enunit='Ryd' c vc0 = -0.7d0 rs0 = 3.d0 c emin = 0.5 emax = 40.0 delta= 0.05 gamma= 0.0 eftri= 0.0 rsh = 0.0d0 !used as a flag; set below to default in au db = 0.01 c c data initialization for calctype='els' or 'e2e' c if(calctype.eq.'els'.or.calctype.eq.'e2e') then c einc= 1200.0 esct= 1000.0 scangl= 7.0/180.0*3.1415926 lambda = 0.0 !used as a flag; set below to default in au c endif c c.....definition of lmax_mode: c..... lmax_mode = 0: lmaxn(na)=lmax_, independent of energy and atom number c..... lmax_mode = 1: lmaxn(na)= km*rs(na)+1, where km=(emax)^{1/2} c..... lmax_mode = 2: lmaxn(na)= ke*rs(na)+1, where ke=(e)^{1/2}, where c..... e is the running energy c c.. read control cards in namelist &job c read(idat,job) read(idat,*) c c.....convert lengths in au if coor='angs'. Coordinates will be converted c in subroutine inoor if(coor.eq.'angs'.and.lambda.ne.0) then lambda = lambda/real(antoau) else lambda = 20.0 ! in au corresponding to kappa = 0.05 (see subroutine cont) endif c if(coor.eq.'angs'.and.rsh.ne.0) then rsh = rsh/antoau else rsh = 1.0d0 ! in au endif c.....convert all energies to Ryd (when they are inputed in eV) c if(enunit.eq.' ev') then c vc0 = vc0/ev c cip = cip/real(ev) emin = emin/real(ev) emax = emax/real(ev) delta= delta/real(ev) gamma= gamma/real(ev) eftri= eftri/real(ev) einc= einc/real(ev) esct= esct/real(ev) endif c if(lmax_mode.gt.2) then write(iwr,*) 'lmax_mode should be less than 3' call exit endif c if(calctype.eq.'els') then lmax_mode = 2 einl = dble(einc - esct - cip) if(cip.ne.0.0.and.einl.lt.0.0d0) then write(6,*)' unable to excite chosen edge:', & ' einc - esct - cip less than zero =', einl call exit endif endif c if(calctype.eq.'led') charelx = 'gs' if ((calctype.eq.'xpd').or.(calctype.eq.'led').or. & (calctype.eq.'els')) then c write(iwr,1000) calctype write(iwr,1001) if(calctype.eq.'xpd'.or.calctype.eq.'xas'.or. & calctype.eq.'rex'.or.calctype.eq.'els') write(iwr,1005)edge write(iwr,1010)potype,norman,absorber write(iwr,1015)coor,emin,emax write(iwr,1020)delta,gamma,eftri c write(iwr,1025)cip,lmax write(iwr,1038) ionzst c if (mode.eq.0) write(iwr,1036) if (potgen.eq.'in') write(iwr,1036) c if (mode.eq.1) write(iwr,1037) if (potgen.eq.'ex') write(iwr,1037) 1000 format(' parameters for this ',a3,' calculation:') 1001 format(1x,65('-')) 1005 format(2x,'edge= ',a2) 1010 format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2) 1015 format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ', $ f7.2,' Ry') 1020 format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2, $ 2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry') 1025 format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2) 1036 format(2x,'final state potential generated internally') 1037 format(2x,'final state potential read in from extnl file') 1038 format(2x,'ionization state : ',a7) c else c write(iwr,10001) calctype write(iwr,10011) write(iwr,10051)edge,edge1,edge2 write(iwr,10101)potype,norman,absorber write(iwr,10151)coor,emin,emax write(iwr,10201)delta,gamma,eftri c write(iwr,10251)cip,lmax write(iwr,10381) ionzst c if (mode.eq.0) write(iwa,10361) c if (mode.eq.1) write(iwa,10371) 10001 format(' parameters for this 'a3,' calculation:') 10011 format(52('-')) 10051 format(2x,'edge= ',a2,2x,'edge1= ',a2,2x,'edge2= ',a2) 10101 format(2x,'potype= ',a5,5x,'norman= ',a6,4x,'absorber= ',i2) 10151 format(2x,'coor= ',a4,8x,'emin= ',f7.2,' Ry',2x,'emax= ', $ f7.2,' Ry') 10201 format(2x,'delta= ',f6.3,' Ry',2x,'gamma= ',f5.2, $ 2x,'Ry',2x,'eftri= ',f6.3,2x,'Ry') 10251 format(2x,'cip= ',f7.2,2x,'Ry',2x,'lmax= ',i2) 10381 format(2x,'ionization state :',a7) c end if c c......check number of energy points c kxe = nint((emax-emin)/delta + 1.) if(kxe.gt.nep_)then write(6,731) kxe 731 format(//, & ' increase the dummy dimensioning variable, nep_. ', & /,' it should be at least equal to: ', i5,/) call exit end if c c.. set other options and seek for errors c ierror=0 c c potgen determines whether the potential is generated internally c by the present program or read in externally c potype determines which which kind of exchange-correlation potential c is used c mode is 0 if the potential is to be computed and 1 if the c potential is to be read c iexcpot is defined after the potential type according to c the values found below c mode = 0 if (potgen.eq.'ex') mode=1 c iexcpot = 0 ipot = 0 c if(potype.eq.'xalph')then iexcpot=1 else if(potype.eq.'hedin')then ipot = 1 iexcpot=5 else if(potype.eq.'dhrel')then iexcpot=2 else if(potype.eq.'dhcmp')then ipot = 1 iexcpot=4 else if(potype.eq.'hdrel')then iexcpot=3 else if(potype.eq.' lmto') then iexcpot=6 else ierror=1 endif endif endif endif endif endif c shell=edge(1:1) orbital=edge(2:2) c if(shell.eq.'k')then lin=0 hole=1 else if(shell.eq.'l')then if(orbital.eq.'1') then lin=0 hole=2 else if(orbital.eq.'2')then lin=1 hole=3 else if(orbital.eq.'3')then lin=1 hole=4 else ierror=1 endif endif endif c else if(shell.eq.'m')then if(orbital.eq.'1')then lin=0 hole=5 else if(orbital.eq.'2')then lin=1 hole=6 else if(orbital.eq.'3')then lin=1 hole=7 else if(orbital.eq.'4')then lin= 2 hole=8 else if(orbital.eq.'5')then lin=2 hole=9 else ierror=1 endif endif endif endif endif c else c if(shell.eq.'n')then if(orbital.eq.'1')then lin=0 hole=10 else if(orbital.eq.'2')then lin=1 hole=11 else if(orbital.eq.'3')then lin=1 hole=12 else if(orbital.eq.'4')then lin= 2 hole=13 else if(orbital.eq.'5')then lin=2 hole=14 else if(orbital.eq.'6')then lin=3 hole=15 else if(orbital.eq.'7')then lin=3 hole=16 else ierror=1 endif endif endif endif endif endif endif c else c if(shell.eq.'o')then if(orbital.eq.'1')then lin=0 hole=17 else if(orbital.eq.'2')then lin=1 hole=18 else if(orbital.eq.'3')then lin=1 hole=19 else if(orbital.eq.'4')then lin= 2 hole=20 else if(orbital.eq.'5')then lin=2 hole=21 else if(orbital.eq.'6')then lin=3 hole=22 else if(orbital.eq.'7')then lin=3 hole=23 else ierror=1 endif endif endif endif endif endif endif c endif endif endif endif endif c if (calctype.eq.'aed') then c c We take the substrings of the final holes in the Auger decay c shell1=edge1(1:1) orbital1=edge1(2:2) shell2=edge2(1:1) orbital2=edge2(2:2) c if(shell1.eq.'k')then lin1=0 hole1=1 else if(shell1.eq.'l')then if(orbital1.eq.'1') then lin1=0 hole1=2 else if(orbital1.eq.'2')then lin1=1 hole1=3 else if(orbital1.eq.'3')then lin1=1 hole1=4 else ierror=1 endif endif endif c else c if(shell1.eq.'m')then if(orbital1.eq.'1')then lin1=0 hole1=5 else if(orbital1.eq.'2')then lin1=1 hole1=6 else if(orbital1.eq.'3')then lin1=1 hole1=7 else if(orbital1.eq.'4')then lin1= 2 hole1=8 else if(orbital1.eq.'5')then lin1=2 hole1=9 else ierror=1 endif endif endif endif endif c else c if(shell1.eq.'n')then if(orbital1.eq.'1')then lin1=0 hole1=10 else if(orbital1.eq.'2')then lin1=1 hole1=11 else if(orbital1.eq.'3')then lin1=1 hole1=12 else if(orbital1.eq.'4')then lin1= 2 hole1=13 else if(orbital1.eq.'5')then lin1=2 hole1=14 else if(orbital1.eq.'6')then lin1=3 hole1=15 else if(orbital1.eq.'7')then lin1=3 hole1=16 else ierror=1 endif endif endif endif endif endif endif c else c if(shell1.eq.'o')then if(orbital1.eq.'1')then lin1=0 hole1=17 else if(orbital1.eq.'2')then lin1=1 hole1=18 else if(orbital1.eq.'3')then lin1=1 hole1=19 else if(orbital1.eq.'4')then lin1= 2 hole1=20 else if(orbital1.eq.'5')then lin1=2 hole1=21 else if(orbital1.eq.'6')then lin1=3 hole1=22 else if(orbital1.eq.'7')then lin1=3 hole1=23 else ierror=1 endif endif endif endif endif endif endif c endif endif endif endif endif c if(shell2.eq.'k')then c lin2=0 hole2=1 c else c if(shell2.eq.'l')then if(orbital2.eq.'1') then lin2=0 hole2=2 else if(orbital2.eq.'2')then lin2=1 hole2=3 else if(orbital2.eq.'3')then lin2=1 hole2=4 else ierror=1 endif endif endif c else c if(shell2.eq.'m')then if(orbital2.eq.'1')then lin2=0 hole2=5 else if(orbital2.eq.'2')then lin2=1 hole2=6 else if(orbital2.eq.'3')then lin2=1 hole2=7 else if(orbital2.eq.'4')then lin2= 2 hole2=8 else if(orbital2.eq.'5')then lin2=2 hole2=9 else ierror=1 endif endif endif endif endif c else c if(shell2.eq.'n')then if(orbital2.eq.'1')then lin2=0 hole2=10 else if(orbital2.eq.'2')then lin2=1 hole2=11 else if(orbital2.eq.'3')then lin2=1 hole2=12 else if(orbital2.eq.'4')then lin2= 2 hole2=13 else if(orbital2.eq.'5')then lin2=2 hole2=14 else if(orbital2.eq.'6')then lin2=3 hole2=15 else if(orbital2.eq.'7')then lin2=3 hole2=16 else ierror=1 endif endif endif endif endif endif endif c else c if(shell2.eq.'o')then if(orbital2.eq.'1')then lin2=0 hole2=17 else if(orbital2.eq.'2')then lin2=1 hole2=18 else if(orbital2.eq.'3')then lin2=1 hole2=19 else if(orbital2.eq.'4')then lin2= 2 hole2=20 else if(orbital2.eq.'5')then lin2=2 hole2=21 else if(orbital2.eq.'6')then lin2=3 hole2=22 else if(orbital2.eq.'7')then lin2=3 hole2=23 else ierror=1 endif endif endif endif endif endif endif c endif endif endif endif endif c endif c c.. stop if errors occurred c if(ierror.eq.0)goto 10 c write(iwr,*) ' ' write(iwr,*) ' ' write(iwr,*)' ** error in inctrl **' write(iwr,*)' -> check namelist values' write(iwr,*) ' ' write(iwr,*) ' ' c stop 10 continue c c.. check dimensions for lmax c if(lmaxt.gt.lmax_) then write(iwr,*) ' ' write(iwr,*) ' ' write(iwr,*)' ** error in inctrl **' write(iwr,*)' -> check dimensions for lmax_' write(iwr,*) ' ' write(iwr,*) ' ' stop endif c end c subroutine intit(iof) C c... read title cards until a blank card is encountered C implicit real*8 (a-h,o-z) include 'msxas3.inc' c include 'msxasc3.inc' c logical blank logical line1 character*1 card(80) c write(iwr,1001) line1=.true. c 1 call incard (idat,card,ierr) if(ierr.eq.0) goto 3 if(ierr.eq.1) then write(iwr,2000) if(ierr.eq.2) then write(iwr,2001) endif endif 2000 format(//,' ** intit : end input -> stop **',//) 2001 format(//,' ** intit : input error -> stop **',//) stop 3 continue c c.. write the 1st line of title into iof c if (line1) write(iof) (card(j),j=1,79) line1=.false. if ( blank(card) ) goto 2 write(iwr,1000) (card(j),j=1,79) goto 1 2 continue write(iwr,1001) 1000 format(1x,80a1) 1001 format(/) end c subroutine incard (idat,card,ierr) c character*1 card(80) ierr=0 do 2 i=1,80 2 card(i)=' ' read(idat,1000,end=9,err=10) (card(i),i=1,80) return 9 ierr=1 return 10 ierr=2 return 1000 format(80a1) end c logical function blank(card) character*1 card(80) data iasc/32/ c c iasc is the ascii code for ' ' (32) c here a blank card is a card with ascii codes < 32 c i.e., control characters are ignored c blank=.true. do 1 i=1,80 if (ichar(card(i)).gt.iasc) then blank=.false. return endif 1 continue end c subroutine incoor c implicit real*8 (a-h,o-z) include 'msxas3.inc' c include 'msxasc3.inc' c common/lmto/ rdsymbl,tag(nat_) character*2 tag,tagi logical rdsymbl c if( coor.eq.'au ') write(iwr,2000) if( coor.eq.'angs') write(iwr,2001) write(iwr,2002) i=1 1 continue c rdsymbl=.false. read (idat,*,iostat=ios) tagi,nzi backspace(idat) if (ios.eq.0) rdsymbl=.true. c if (rdsymbl) then c if (norman.eq.'stdcrm') then radi = 0.0d0 redfi = 0.0d0 read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3 endif c if (norman.eq.'stdfac') then radi = 0.d0 redfi = 0.8d0 read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3 endif c if (norman.eq.'scaled') then radi = 0.0d0 read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,redfi endif c if (norman.eq.'extrad') then redfi = 0.0d0 read (idat,*,err=2) tagi,nzi,ci1,ci2,ci3,radi endif c else c if (norman.eq.'stdcrm') then radi = 0.0d0 redfi = 0.0d0 read (idat,*,err=2) nzi,ci1,ci2,ci3 endif c if (norman.eq.'stdfac') then radi = 0.d0 redfi = 0.8d0 read (idat,*,err=2) nzi,ci1,ci2,ci3 endif c if (norman.eq.'scaled') then radi = 0.0d0 read (idat,*,err=2) nzi,ci1,ci2,ci3,redfi endif c if (norman.eq.'extrad') then redfi = 0.0d0 read (idat,*,err=2) nzi,ci1,ci2,ci3,radi endif c endif c if (nzi.lt.0) goto 2 c if (i.gt.natoms) then write(iwr,*) ' ' write(iwr,*) ' ' write(iwr,*)' ** error in incoor **' write(iwr,*)' -> too many atoms, ', 1 'check dimensions' write(iwr,*) ' ' write(iwr,*) ' ' stop endif c nz(i) = nzi c(i,1) = ci1 c(i,2) = ci2 c(i,3) = ci3 rad(i) = radi redf(i) = redfi tag(i) = tagi if(rdsymbl) then write (iwr,101) tag(i),nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i) else write (iwr,100) nz(i),c(i,1),c(i,2),c(i,3),rad(i),redf(i) endif 100 format(2x,i3,3f10.4,3x,2f7.4) 101 format(2x,a2,3x,i3,3f10.4,3x,2f7.4) i=i+1 goto 1 2 nat = i-1 C print *, 'nat =', nat write(iwr,2002) write(iwr,2003) if(ionzst.eq.' ionic') then 10 read(idat,*) nzat if(nzat.lt.0) goto 20 backspace(idat) read(idat,*) ndummy,charge_ion(nzat) goto 10 endif 20 continue c c.. default units are angtroms, convert to a.u. if necessary c if (coor.eq.'au ') return if (coor.eq.'angs') then do 3 i=1,nat if (norman.eq.'extrad') & rad(i) = rad(i)/antoau do 3 iz=1,3 c(i,iz)= c(i,iz) / antoau 3 continue return endif c write(iwr,*) ' ' write(iwr,*) ' ' write(iwr,*)' ** incoor: unit type unknown -> ', 1 'stop ** ' write(iwr,*) ' ' write(iwr,*) ' ' c 2000 format(' coordinates in a.u. ',25x,'Radii') 2001 format(' coordinates in angstroms',25x,'Radii') 2002 format(1x,65('-')) 2003 format(/) stop end c subroutine calphas c implicit real*8 (a-h,o-z) include 'msxas3.inc' c include 'msxasc3.inc' c c real*4 emin,emax,delta,cip,gamma,eftri,db common/continuum/emin,emax,delta,cip,gamma,eftri,iexcpot,db common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), & ramfsr2(npss,nef_),ramfsr3(npss,nef_), & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg real*4 einc,esct,scangl,qt,lambda c character*8 nsymbl c c ######## Modified to introduce the two state wave functions for the c Auger decay c ######## let's introduce i_absorber_hole1 and i_absorber_hole2 c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode common/dimens/nats,ndat,nout,lmaxx,irreps c common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), u lmaxat(natoms), ktau(ua_),natau(neq_,ua_) c common/aparms_extra/rs_(natoms),redf_(natoms),ovlf c c real*4 emin,emax,delta,cip,gamma,eftri c write(iwr,*) ' ** enter calphas **' c if(cip.eq.0.0) then c c calculate edge ionization potential c call calc_edge(cip) write(6,*) ' calculated ionization potential (ryd) =',cip else write(6,*) ' given ionization potential (ryd) =',cip endif write(6,*) ' ---' c c check consistency of input data in case of calctype = 'els' c if(calctype.eq.'els') then einl = dble(einc - esct - cip) if(einl.lt.0.0d0) then write(6,*)' unable to excite chosen edge:', & ' einc - esct - cip less than zero =', einl call exit endif endif c c phase shifts computation c initializes some variables for symmetry+potential programs c nat is the total number of physical atoms as read in in c subroutine incoor and is listed in common/atoms/ c nats=nat i_absorber = absorber i_absorber_hole = hole c c ################## Modified to introduce the two state wave functions c for the Auger decay c ################## hole1 is the electron that will go down to fill c the primary core hole c i_absorber_hole1 = hole1 i_absorber_hole2 = hole2 i_norman = 1 c if (norman.eq.'extrad') i_norman = 0 i_mode = mode do 100 i=2,nat+1 nzeq(i) = nz(i-1) xv(i) = c(i-1,1) yv(i) = c(i-1,2) zv(i) = c(i-1,3) rs_(i)=rad(i-1) redf_(i)=redf(i-1) 100 continue ovlf = ovlpfac c write(iwr,*) ' ' write(iwr,*) ' ' write(iwr,*) ' symmetrizing coordinates... ' open (7,file='div/sym.out',status='unknown') call xasymfn_sub c c.....Warning: in subroutine xasymfn_sub nats has been assigned c.....the value (nat+1) to take into account the outer sphere. c c create equivalence table neqat c i=1 is the outer sphere in xasym programs c do 200 i=1,nat if (neq(i+1).eq.0) then neqat(i)=i else neqat(i)=neq(i+1)-1 endif 200 continue c c.....Write out atomic coordinates in symmetry-program order: c each prototypical atom is followed by its sym-equivalent atoms c c open (10,file='clus/clus.out',status='unknown') if( coor.eq.'au ') then ipha=1 coef=1.d0 endif if( coor.eq.'angs') then ipha=2 coef=0.529177d0 endif write(10,888) ipha 888 format(30x,i1) write(7,10) (neqat(i),i=1,nat) 10 format (/,16i5,//) c c write(7,10) nat, ndat-1 c x0 = xv(2) y0 = yv(2) z0 = zv(2) c no = 0 do na = 1, ndat-1 do k = 2, nat+1 if (neqat(k-1).eq.na) then no = no + 1 write(7,20) no,nsymbl(k),nzeq(k),xv(k)-x0, & yv(k)-y0,zv(k)-z0,neqat(k-1) write(10,20) no,nsymbl(k),nzeq(k),(xv(k)-x0)*coef, & (yv(k)-y0)*coef,(zv(k)-z0)*coef,neqat(k-1) endif continue enddo enddo c close(10) c 20 format (i5,6x,a4,i5,3f10.4,i5) c write(iwr,*) write(iwr,*)' computing muffin tin potential and phase shifts' call cont_sub(potype,potgen,lmax_mode,lmaxt,relc,eikappr,db) c ctn write(iwr,*)'calphas: neq', (neq(i),i=1,nat+1) ctn write(iwr,*)'calphas: neqat', (neqat(i),i=1,nat) c tstop=cputim() c elapsed=tstop-tstart c write(iwr,2000)elapsed c 2000 format(' ** end calphas ** elapsed time ',f10.3,' seconds') return end c c subroutine exit c write(6,*) ' ' write(6,*) ' ' write(6,*)' ** stop via call exit **' write(6,*) ' ' write(6,*) ' ' stop end c subroutine xasymfn_sub c c*********************************************************************** c c xasymfn: xalpha symmetry function program (version 3, 11 feb 1981) c c written by m. cook, 1981. c c calls: input(at input,outpot),seteqs,symops,closur,ctable,basfns c c*********************************************************************** c implicit real*8 (a-h,o-z) c include 'mscalc.inc' include 'msxas3.inc' integer op_,ord_,two_npr_ parameter (natm2_=nat_-2,npr_=24,op_=48,ntax_=250, 1 ir_=14,ib_=28,ord_=8,l_=3,lp1_=4, 2 nms_=7,nfac_=9,nbf_=nat_*4,ncs_=24) parameter(two_npr_=2*npr_,npr_p1_=npr_+1) c common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx c c !flag for reformatted output common/sym_out/isym_format c c----- define maximum array dimensions --------------------------------- c warning : natmx est dans le common cman data natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, cman u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx cman u /nat_,ua_,neq_,npr_,two_npr_,npr_p1_, cman u ord_,ir_,ib_,l_,nbf_,ncs_,ntax_/ c data natm2m,nopmax,lp1mx,nmsmx,mxfct u /natm2_,op_,lp1_,nms_,nfac_/ cman natmx = nat_ ndatmx = ua_ neqsmx = neq_ nprmx = npr_ nopmx = two_npr_ nimp1 = npr_p1_ nordmx = ord_ nirpmx = ir_ nibmx = ib_ lbasmx = l_ nbfmx = nbf_ ncsmx = ncs_ ntaxmx = ntax_ c c if (natm2m.lt.natmx-2) go to 10 if (nopmax.ne.2*nprmx) go to 20 if (lp1mx.ne.lbasmx+1) go to 30 if (nmsmx.ne.2*lbasmx+1) go to 40 if (mxfct.lt.2*lbasmx+1) go to 50 if (nordmx.lt.3) go to 60 c c----- call major calculational subroutines ---------------------------- c call input_xasymfn call seteqs call outpot_xasymfn c return c c----- error prints and stops ------------------------------------------ c 10 write (6,500) natm2m stop 20 write (6,510) nopmax stop 30 write (6,520) lp1mx stop 40 write (6,530) nmsmx stop 50 write (6,540) mxfct stop 60 write (6,550) nordmx stop c 500 format (//,' error stop: natm2m =',i6,' is less than', u ' natmx-2 : redimension',//) 510 format (//,' error stop: nopmax =',i6,' is not equal to', u ' 2*nprmx : redimension',//) 520 format (//,' error stop: lp1mx =',i6,' is not equal to', u ' lbasmx+1 : redimension',//) 530 format (//,' error stop: nmsmx =',i6,' is not equal to', u ' 2*lbasmx+1 : redimension',//) 540 format (//,' error stop: mxfct =',i6,' is less than', u ' 2*lbasmx+1 : redimension',//) 550 format (//,' error stop: nordmx =',i6,' : must be', u ' redimensioned to 3 or greater',//) end c c subroutine input_xasymfn c c*********************************************************************** c c reads in the molecular geometry information, desired c l-values, and mode control variables. modes of operation: c c iprt=0, rot'n matrices not printed c iprt=1, rot'n matrices will be printed out from ctable c c mdin=0, geometry, nz, neq data all read from card input c mdin=1, non-sym data read from a molec stpot; sym data from cards c c mdou=0, only 1st col of degenerate irreps output to ktape c mdou=1, all columns of degenerate irreps will be written c c mdco=0, single-atom core functions will be generated c mdco=1, symmetry-adapted core functions will be generated c c mdeq=0, calc'd symmetry-eq list (neq) overrides any input neq c mdeq=1, input list of symmetry-equivalences will be used c c if mdin=1, mdeq=1 is automatically enforced by this program c because the form of the stpot depends on the list of sym-eq ats. c c called by: main (at input,outpot) c c*********************************************************************** c implicit real*8(a-h,o-z) c include 'mscalc.inc' include 'msxas3.inc' c logical cmplxc,frezeq,inpot,nonint,onecol,symcor character*8 nsymbl,nsymbl2 common/aparms_extra/rs(nat_),redf(nat_) common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_), u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_), u ktau(ua_),natau(neq_,ua_) common/aparms2/xv2(nat_),yv2(nat_),zv2(nat_),rs2(nat_), u alpha2(nat_),redf2(nat_),z2(nat_),q2(nat_),qspnt2(2), u qint2(2), u watfac(nat_),alpha02,volint2,ovout2,rmxout2,nsymbl2(nat_), u nz2(nat_),neq2(nat_),kmax2(nat_),kplace2(nat_),ktau2(ua_) common/lparam/lmax2(nat_),l0i common/coords/s(3,nat_) dimension s2(3,nat_) common/dimens/nat,ndat,nout,lmaxx,irreps common/dimens2/nat2,ndat2 common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx c !flag for reformatted output common/sym_out/isym_format c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode c !generate potential file common/out_ascii/iout_ascii c common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc logical shift_cc c common/lmto/ rdsymbl,tag(nat_) character*2 tag logical rdsymbl character*2 nameat dimension nameat(100) c DATA NAMEAT/' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', 1 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca', 1 'Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn', 1 'Ga','Ge','As','Se','Br','Kr','Rb','Sr',' Y','Zr', 1 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', 1 'Sb','Te',' I','Xe','Cs','Ba','La','Ce','Pr','Nd', 1 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', 1 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', 1 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', 1 'Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm'/ c data thr/0.001d0/ data zero/0.d0/ data lunout,lunout2/7,60/ c iprt=0 mdou=0 mdco=0 mdeq=0 isym_format=0 c !nout defined nout=1 c !same as nout but global i_outer_sphere=1 c frezeq=.false. symcor=.false. onecol=.true. if (mdeq.eq.1) frezeq=.true. if (mdco.eq.1) symcor=.true. if (mdou.eq.1) onecol=.false. c c----------------------------------------------------------------------- c mdin = 0 : only geometry & atomic # data, from card input c----------------------------------------------------------------------- c inpot=.false. c !nout defined nout=1 ctn ctn Values passed through the subroutines parameters ctn read (lunin,*) nat,i_absorber,i_absorber_hole,i_norman, ctn &i_mode c nat=nat+i_outer_sphere if (nout.eq.0) write (lunout,570) nat if (nout.ne.0) write (lunout,580) nat if (nat.gt.natmx) go to 140 write (lunout,530) c r_sphere=0.0d0 do 10 na=2,nat ctn read (lunin,*) nsymbl(na),nz(na),xv(na),yv(na),zv(na), ctn u rs(na),redf(na) ctn modifs : c nsymbl(na)=nameat(nz(na)) c......modification for Empty Spheres c if(rdsymbl) then nsymbl(na)=tag(na-1) else if(nz(na).eq.0) then nsymbl(na)='ES' else nsymbl(na)=nameat(nz(na)) endif endif z(na)=dfloat(nz(na)) neq(na)=0 c !needed to determine point group lmax(na)=3 ncores(na)=0 write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na), u neq(na),lmax(na),ncores(na) 10 continue c c define outer sphere parameters (i. e. atomic center) c na=1 nsymbl(na)='osph' nz(na)=0 z(na)=0.0d0 neq(na)=0 rs(na)=0.0d0 redf(na)=0.0d0 c !needed to determine point group lmax(na)=3 ncores(na)=0 c c define outer sphere coordinates at center of charge c xo=zero yo=zero zo=zero wt=zero do 910 na1=2,nat xo=xo+z(na1)*xv(na1) yo=yo+z(na1)*yv(na1) zo=zo+z(na1)*zv(na1) wt=wt+z(na1) 910 continue xo=xo/wt yo=yo/wt zo=zo/wt if (dabs(xo).lt.thr) xo=zero if (dabs(yo).lt.thr) yo=zero if (dabs(zo).lt.thr) zo=zero xv(na)=xo yv(na)=yo zv(na)=zo c if(i_norman.ne.1)then do 15 na1=2,nat r_sphere_temp=sqrt((xv(na1)-xv(1))**2+ u (yv(na1)-yv(1))**2+ u (zv(na1)-zv(1))**2)+rs(na1) if(r_sphere.lt.r_sphere_temp)then r_sphere=r_sphere_temp end if 15 continue rs(1)=r_sphere end if write (lunout,550) na,nsymbl(na),nz(na),xv(na),yv(na),zv(na), u neq(na),lmax(na),ncores(na) write (lunout,560) c c*** check coordinates of atoms c do 1150 na1=1,nat do 1140 na2=1,na1 dist =dsqrt((xv(na1)-xv(na2))**2 u +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 ) if((na2.gt.1).and.(na1.ne.na2)) then if(dist.lt.thr)then write(6,562)na1,na2 call exit end if end if 1140 continue 1150 continue c return c c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c entry outpot_xasymfn c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ c c----- molecule will usually have been rotated: c print the new atomic coordinates in standard orientation ------ c entry outpot_xasymfn write (lunout,590) print 595 write (lunout,530) print 535 nashf=1 c nat2=nat ndat2=ndat i_absorber_real=i_absorber+i_outer_sphere c c set z on absorbing atom back to original value c z(i_absorber_real)=z(i_absorber_real)-z_shift nz(i_absorber_real)=nz(i_absorber_real)-i_z_shift c !symmetry distinct atoms do 70 nda=1,ndat if(shift_cc)then c !go back to real cente s2(1,nashf)=s(1,nashf)-cc_dif(1,1) c !of charge s2(2,nashf)=s(2,nashf)-cc_dif(2,1) s2(3,nashf)=s(3,nashf)-cc_dif(3,1) if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero else s2(1,nashf)=s(1,nashf) s2(2,nashf)=s(2,nashf) s2(3,nashf)=s(3,nashf) endif write (lunout,550) nda,nsymbl(nda),nz(nda), u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda), u lmax(nda),ncores(nda) print 555, nda,nsymbl(nda),nz(nda), u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(nda) if(nda.ne.1)write (lunout2,552) s2(1,nashf),s2(2,nashf), u s2(3,nashf),nsymbl(nda) c rs2(nda)=rs(nda) redf2(nda)=redf(nda) nsymbl2(nda)=nsymbl(nda) xv2(nda)=s2(1,nashf) yv2(nda)=s2(2,nashf) zv2(nda)=s2(3,nashf) nz2(nda)=nz(nda) z2(nda)=z(nda) neq2(nda)=neq(nda) ktau2(nda)=ktau(nda) nashf=nashf+ktau(nda) 70 continue nashf=0 do 90 nda=1,ndat nashf=nashf+1 neqs=ktau(nda) if (neqs.eq.1) go to 90 do 80 ne=2,neqs c !equivalent sets nashf=nashf+1 na=natau(ne,nda) if(shift_cc)then c !go back to real cente s2(1,nashf)=s(1,nashf)-cc_dif(1,1) c !of charge s2(2,nashf)=s(2,nashf)-cc_dif(2,1) s2(3,nashf)=s(3,nashf)-cc_dif(3,1) if (dabs(s2(1,nashf)).lt.thr) s2(1,nashf)=zero if (dabs(s2(2,nashf)).lt.thr) s2(2,nashf)=zero if (dabs(s2(3,nashf)).lt.thr) s2(3,nashf)=zero else s2(1,nashf)=s(1,nashf) s2(2,nashf)=s(2,nashf) s2(3,nashf)=s(3,nashf) endif write (lunout,550) na,nsymbl(na),nz(na), u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na),lmax(na),ncores(na) print 555, na,nsymbl(na),nz(na), u s2(1,nashf),s2(2,nashf),s2(3,nashf),neq(na) write (lunout2,552) s2(1,nashf),s2(2,nashf),s2(3,nashf), u nsymbl(na) rs2(na)=rs(na) redf2(na)=redf(na) nsymbl2(na)=nsymbl(na) xv2(na)=s2(1,nashf) yv2(na)=s2(2,nashf) zv2(na)=s2(3,nashf) nz2(na)=nz(na) z2(na)=z(na) neq2(na)=neq(na) 80 continue 90 continue if(nout.eq.1) then z2(1)=1.0d0 nz2(1)=1 end if write (lunout,560) return c c----- error prints and stops ------------------------------------------ c 140 write (6,600) natmx,nat stop c 530 format (t53,'position'/30x,'atom no.',4x,'x',9x,'y',9x,'z',8x, u 'eq',5x,'lmax',5x,'#cores'/) 535 format (t35,'position'/12x,'atom no.',4x,'x',9x,'y',9x,'z',8x, u 'eq'/) 550 format (26x,i4,2x,a4,i6,3f10.4,i6,i8,i9) 552 format (3(2x,f10.3),2x,a4) 555 format (8x,i4,2x,a4,i6,3f10.4,i6) 560 format (/46x,6('*****')/) 562 format (//,'error: check coordinates of atoms # ',i4, & ' and # ',i4,//) 570 format (//38x,'number of centers=',i5,' no outer sphere'/) 580 format (//38x,'number of centers=',i5,' outer sphere at ' u ,'center 1'/) 590 format (///38x,'molecular orientation for basis fn projection:'/) 595 format (//14x,' symmetrized atomic coordinates of cluster '/) 600 format (//' error stop: variable nat is .gt.',i6, u ' : redimension natmx to',i6,//) end c subroutine seteqs c c*********************************************************************** c c translates the molecule to the center of nuclear charge c and tentatively identifies symmetry-equivalent sets of atoms c on the basis of interatomic distances. c checks that the atoms are arranged in correct order for c xascf: nda's first and eq atoms following. if input is from c a molec starting pot, error stop if order is not correct. if c input is not from a pot, the atoms will be shuffled into c the appropriate xascf order at output time. c note that during the execution of the symmetry program, the c atoms are not kept in the scf order: they are in sym-program c order, each nda followed immediately by its sym-eq partners. c c called by: main c c*********************************************************************** c implicit real*8 (a-h,o-z) c include 'mscalc.inc' include 'msxas3.inc' parameter (natm2_=nat_-2) c character*8 nsymbl logical doshuf,equiv,found,match,frezeq logical cmplxc,inpot,nonint,onecol,symcor dimension neqt(nat_) dimension found(natm2_),nbrz(natm2_,nat_),dnbr(natm2_,nat_) integer trans(nat_) common/aparms_extra/rs(nat_),redf(nat_) common/aparms/xv(nat_),yv(nat_),zv(nat_),z(nat_), u nsymbl(nat_),nz(nat_),neq(nat_),ncores(nat_),lmax(nat_), u ktau(ua_),natau(neq_,ua_) common/coords/s(3,nat_) common/dimens/nat,ndat,nout,lmaxx,irreps common/logicl/cmplxc,iprt,frezeq,inpot,nonint,onecol,symcor common/maxdim/natmx,ndatmx,neqsmx,nprmx,nopmx,nimp1, u nordmx,nirpmx,nibmx,lbasmx,nbfmx,ncsmx,ntaxmx c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode c common/charge_center/cc_dif(3,1),z_shift,i_z_shift,shift_cc common/transform/trans logical shift_cc c data zero,thr/0.0d0,0.001d0/ c data jtape/21/ data lunout/7/ c c----------------------------------------------------------------------- c find the center of charge of the nuclear framework and c translate the molecule to that origin c----------------------------------------------------------------------- c !define nuclear charge shift z_shift=5.0d0 i_z_shift=5 shift_cc=.true. c xo=zero yo=zero zo=zero wt=zero nastrt=nout+1 c !set up to make absorbing atom unique by addin cc_dif(1,1)=zero c !z_shift units of charge to its nucleus cc_dif(2,1)=zero cc_dif(3,1)=zero wt_real=zero do 5 na=nastrt,nat cc_dif(1,1)=cc_dif(1,1)+z(na)*xv(na) cc_dif(2,1)=cc_dif(2,1)+z(na)*yv(na) cc_dif(3,1)=cc_dif(3,1)+z(na)*zv(na) wt_real=wt_real+z(na) 5 continue cc_dif(1,1)=cc_dif(1,1)/wt_real cc_dif(2,1)=cc_dif(2,1)/wt_real cc_dif(3,1)=cc_dif(3,1)/wt_real c i_absorber_real=i_absorber+i_outer_sphere c increase z value of absorbing atom z(i_absorber_real)=z(i_absorber_real)+z_shift nz(i_absorber_real)=nz(i_absorber_real)+i_z_shift c do 10 na=nastrt,nat xo=xo+z(na)*xv(na) yo=yo+z(na)*yv(na) zo=zo+z(na)*zv(na) wt=wt+z(na) 10 continue xo=xo/wt yo=yo/wt zo=zo/wt if (dabs(xo).lt.thr) xo=zero if (dabs(yo).lt.thr) yo=zero if (dabs(zo).lt.thr) zo=zero c !cc_dif is difference between cc_dif(1,1)=cc_dif(1,1)-xo c !real and shifted centers of cc_dif(2,1)=cc_dif(2,1)-yo c !charge cc_dif(3,1)=cc_dif(3,1)-zo if (dabs(cc_dif(1,1)).lt.thr) cc_dif(1,1)=zero if (dabs(cc_dif(2,1)).lt.thr) cc_dif(2,1)=zero if (dabs(cc_dif(3,1)).lt.thr) cc_dif(3,1)=zero r_dif_cc=sqrt( cc_dif(1,1)*cc_dif(1,1)+cc_dif(2,1)* u cc_dif(2,1)+cc_dif(3,1)*cc_dif(3,1) )/dsqrt(3.0d0) if(r_dif_cc.lt.thr)shift_cc=.false. do 20 na=1,nat xv(na)=xv(na)-xo yv(na)=yv(na)-yo zv(na)=zv(na)-zo if (dabs(xv(na)).lt.thr) xv(na)=zero if (dabs(yv(na)).lt.thr) yv(na)=zero if (dabs(zv(na)).lt.thr) zv(na)=zero 20 continue c c----------------------------------------------------------------------- c classify sym-eq sets of atoms: two atoms are eqiv c if they have same number of neighbors of same nz at same distances c----------------------------------------------------------------------- c c----- calculate the distances of each atom from the others ------------ c neqt(1)=0 do 40 na1=nastrt,nat nabor=0 neqt(na1)=0 do 30 na2=nastrt,nat if (na1.eq.na2) go to 30 nabor=nabor+1 nbrz(nabor,na1)=nz(na2) rab=dsqrt((xv(na1)-xv(na2))**2 u +(yv(na1)-yv(na2))**2 + (zv(na1)-zv(na2))**2 ) dnbr(nabor,na1)=rab 30 continue 40 continue c c----- compare the neighbor charges and distances ---------------------- c nabors=nat-(nout+1) do 90 na1=nastrt,nat na1p1=na1+1 if (na1p1.gt.nat) go to 90 do 80 na2=na1p1,nat if (nz(na1).ne.nz(na2)) go to 80 if (neqt(na2).ne.0) go to 80 do 50 nabor=1,nabors 50 found(nabor)=.false. equiv=.true. c c----- try to match the neighbors of na1 & na2 one-to-one -------------- c do 70 nabor1=1,nabors nzt= nbrz(nabor1,na1) rabt=dnbr(nabor1,na1) match=.false. do 60 nabor2=1,nabors if (found(nabor2)) go to 60 if (nbrz(nabor2,na2).ne.nzt) go to 60 if (dabs(dnbr(nabor2,na2)-rabt).gt.thr) go to 60 found(nabor2)=.true. match=.true. go to 65 60 continue 65 if (match) go to 70 equiv=.false. go to 75 70 continue c c----- if all nabor2 found and each nabor1 had match=.true., c na1 and na2 have equivalent sets of neighbors ----------------- c 75 if (equiv) neqt(na2)=na1 80 continue 90 continue c c----------------------------------------------------------------------- c compare the calculated and input neq arrays c----------------------------------------------------------------------- c write (lunout,500) write (lunout,510) (na,neqt(na),na=1,nat) equiv=.true. do 100 na=1,nat if (neqt(na).ne.neq(na)) equiv=.false. if (.not.frezeq) neq(na)=neqt(na) 100 continue if (equiv) write (lunout,520) if (.not.equiv.and.frezeq) write (lunout,530) if (.not.equiv.and..not.frezeq) write (lunout,540) c c----------------------------------------------------------------------- c check that the atoms are arranged in the correct scf order: c all nda's first, then the sym-eq atoms for each nda in same order c----------------------------------------------------------------------- c doshuf=.false. do 110 na=nastrt,nat if (neq(na).eq.0.and.neq(na-1).ne.0) doshuf=.true. if (neq(na).lt.neq(na-1)) doshuf=.true. 110 continue if (inpot.and.doshuf) go to 230 c c----- if not running from a molecular starting pot, c shuffle the atoms into xascf order ---------------------------- c rewind jtape nda=0 do 130 na=1,nat if (neq(na).gt.0) go to 130 nda=nda+1 write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) do 120 na2=1,nat if (neq(na2).eq.na) neq(na2)=nda 120 continue 130 continue ndat=nda if (ndat.gt.ndatmx) go to 240 do 150 nda=1,ndat do 140 na=1,nat if (neq(na).ne.nda) go to 140 write (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) write (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) 140 continue 150 continue nda=0 do 310 i=2,nat if (neq(i).eq.0) then nda=nda+1 trans(i-1)=nda endif 310 continue do 320 na=2,ndat do 325 i=2,nat if (neq(i).eq.na) then nda=nda+1 trans(i-1)=nda endif 325 continue 320 continue c c----- read the shuffled atomic parameters back in --------------------- c rewind jtape do 160 na=1,nat read (jtape) nsymbl(na),neq(na),nz(na),xv(na),yv(na),zv(na) read (jtape) lmax(na),ncores(na),rs(na),redf(na),z(na) 160 continue rewind jtape c c----------------------------------------------------------------------- c calculate the final symmetry-equivalence list ( natau ) c----------------------------------------------------------------------- c do 200 nda=1,ndat neqs=1 natau(1,nda)=nda do 190 na=1,nat if (neq(na).ne.nda) go to 190 neqs=neqs+1 if (neqs.gt.neqsmx) go to 250 natau(neqs,nda)=na 190 continue ktau(nda)=neqs 200 continue c c----------------------------------------------------------------------- c arrange the atomic x,y,z coords in symmetry-program order: c each nda is followed immediately by its sym-equivalent atoms c----------------------------------------------------------------------- c nashuf=0 do 220 nda=1,ndat neqs=ktau(nda) do 210 ne=1,neqs na=natau(ne,nda) nashuf=nashuf+1 s(1,nashuf)=xv(na) s(2,nashuf)=yv(na) s(3,nashuf)=zv(na) 210 continue 220 continue return c c----- error prints and stops ------------------------------------------ c 230 write (6,550) stop 240 write (6,560) ndatmx,ndat stop 250 write (6,570) neqsmx stop c 500 format (//25x,'calculated atomic symmetry equivalences,'/ u 30x,'based on interatomic distance matrix:',7x,'na', u 4x,'neq(na)'/) 510 format (69x,i7,i8) 520 format (/t35,'the calculated symmetry-eq sets agree with', u ' the input'/) 530 format (/t25,'calculated & input symmetry-eq sets do not', u ' agree: input sets will be used'/) 540 format (/t22,'calculated & input symmetry-eq sets do not', u ' agree: calculated sets will be used'/) 550 format (//t25,'input molecular pot does not have distinct', u ' & sym-eq atoms in correct order for input to xascf',//) 560 format (//' error stop: variable ndat is .gt.',i6, u ' : redimension ndatmx to',i6,//) 570 format (//' error stop: variable neqs is .gt.',i6, u ' : redimension neqsmx',//) end c c subroutine vgen c write(6,*) 'check1' call rhoat c write(6,*) 'check2' call molpot c write(6,*) 'check3' call inpot c write(6,*) 'check4' return end c C*********************************************************************** SUBROUTINE RHOAT C*********************************************************************** C C MAY-92 C C GENERATES ATOMIC CHARGE DENSITY FOR PROTOTYPICAL ATOMS C C DICTIONARY : C NDAT Number of prototypical atoms C INV Logical unit on which to write the output [8] C ZAT Atomic number C MESH Number of radial mesh points [441] C C************************************************ implicit real*8 (a-h,o-z) c include 'msxas3.inc' include 'msxasc3.inc' c common/dimens/nats,ndat c character*8 nsymbl c.. c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1 c *i_absorber_hole2,i_norman,i_alpha, c 1i_outer_sphere,i_exc_pot,i_mode COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1, * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA, 1 I_OUTERSPHERE,I_EXC_POT,I_MODE C COMMON/APARMS/XV(NATOMS),YV(NATOMS),ZV(NATOMS),Z(NATOMS), C u NSYMBOL(NATOMS),NZEQ(NATOMS),NEQ(NATOMS),NCORES(NATOMS), C . LMAXAT(NATOMS) C COMMON/APARMS_EXTRA/RS_(NATOMS),REDF_(NATOMS),OVLF common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), u lmaxat(natoms),ktau(ua_),natau(neq_,ua_) C COMMON/CRHOAT/RO(441,UA_,1) c DIMENSION X(441),RMESH(441) C REAL*4 XC,YC,ZC DIMENSION XC(NAT_),YC(NAT_),ZC(NAT_) C DIMENSION NPAC(100) C LOGICAL OK C OK = .TRUE. C C* * * Initialize variables for subroutine molpot * * * C MESH = 441 C C Prepare coordinate vectors to input subroutine moldat C DO 10 I=1,NAT XC(I) = sngl(XV(I+1)) YC(I) = sngl(YV(I+1)) 10 ZC(I) = sngl(ZV(I+1)) C Initialize to zero the vector indicating for which atom the density C has already been calculated DO N = 1, 100 NPAC(N) = 0 ENDDO C C compute x and r mesh (441 points) C NBLOCK=11 I=1 X(I)=0.0D0 RMESH(I)=0.0D0 DELTAX=0.0025D0 DO 120 J=1,NBLOCK DO 121 K=1,40 I=I+1 X(I)=X(I-1)+DELTAX 121 CONTINUE C C For each new block, double the increment C DELTAX=DELTAX+DELTAX 120 CONTINUE C C Loop over prototypical atoms excluding outer sphere C NDAT1 = NDAT-1 DO 100 M=2,NDAT DO NR = 1, 441 RO(NR,M,1) = 0.D0 ENDDO IHOLE = 0 IF (M.EQ.2.AND.CHARELX.EQ.'ex') IHOLE=HOLE NZAT = NZEQ(M) IF(NZAT.NE.0) CION=CHARGE_ION(NZAT) ZAT = Z(M) C C.....CHANGE FOR EMPTY SPHERES; CHS=0.88534138D0/ZAT**(1.D0/3.D0) C IF(ZAT.NE.0.D0) THEN CHS=0.88534138D0/ZAT**(1.D0/3.D0) ELSE CHS=0.88534138D0 ENDIF C C Factor CHS is to go from X values to R values C (the latter in atomic units; See Herman-Skillman p.5-3) C DO 130 I=2,MESH RMESH(I)=CHS*X(I) 130 CONTINUE C IF(NZAT.EQ.0) GO TO 100 IF(NPAC(NZAT).EQ.0) THEN CALL atom_sub(NZAT,IHOLE,RMESH(1),RO(1,M,1),0,0,CION) IF(M.NE.2) NPAC(NZAT) = M GO TO 100 ELSE DO I = 1, 441 RO(I,M,1) = RO(I,NPAC(NZAT),1) ENDDO ENDIF C 100 CONTINUE C C* * * * Generate input structural parameters for subroutine molpot * * C C CALL MOLDAT(XC,YC,ZC,NZEQ(1),NEQAT(1),NAT,NDAT1,OK) C RETURN C END C C******************************* C subroutine atom_sub(iz,ihole,r_hs,rho0_hs,i_mode_atom, $ i_radial,xion) c c i_mode_atom = 1 pass_back P_nK corresponding to neutr c atom. i_radial designates radial function c which is passed back in array rho0_hs re c to mesh r_hs. c I_radial has same label convention c as ihole (1 = 1s1/2 ...). c = all else pass back charge density in rho0_hs. c c implicit real*8(a-h,o-z) c parameter ( mp = 251, ms = 30 ) c character*40 title c common/mesh_param/jlo common dgc(mp,ms),dpc(mp,ms),bidon(630),IDUMMY c c common /pass/ passd, passvt(251), passvc(251), passc(251) c rho0 not renormalized c common /rho/rho0(251) c dgc contains large component radial functions c common /deux/ dvn(251), dvf(251), d(251), dc(251), dgc(251,30) c passc and rho0 contain 4*pi*r^2*rho(r) c dimension r(mp),r_hs(440),rho0_hs(440) C dimension dum1(mp), dum2(mp) dimension vcoul(mp), rho0(mp), enp(ms) c title = ' ' c ifr=1 iprint=0 C amass=0.0d0 beta=0.0d0 c c There are no nodes in relativistic radial charge density c small=1.0d-11 c !Hence a lower limit on rho(r) can be used. dpas=0.05d0 dr1=dexp(-8.8d0) dex=exp(dpas) r_max=44.447d0 c c compute relativistic Hartree-Fock charge density (on log mesh) C and core state orbital wave function c open(unit=543,file='atom_.dat',status='unknown') c call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, 1 vcoul, rho0, dum1, dum2, enp, eatom) c c compute radial log mesh (see subroutine phase in J.J. Rehr's progr c FEFF.FOR) c ddex=dr1 do 10 i=1,251 r(i)=ddex ddex=ddex*dex 10 continue C DO JMP=1,MP WRITE(66,*) R(JMP),RHO0(JMP) ENDDO c do 15 i=1,441 rho0_hs(i)=0.0d0 15 continue c cman if(i_mode_atom.eq.1)goto 30 c if(i_mode_atom.eq.1)goto 31 c c using mesh form xainpot (r=0 not included) c do 30 i=1,441 if(r_hs(i).gt.r_max) goto 30 c c find nearest points c initialize hunting parameter (subroututine nearest) c jlo=1 call nearest(r,251,r_hs(i), 1 i_point_1,i_point_2,i_point_3) if(abs(rho0(i_point_3)).lt.small) goto 30 c interpolate charge density call interp_quad( r(i_point_1),rho0(i_point_1), 1 r(i_point_2),rho0(i_point_2), 1 r(i_point_3),rho0(i_point_3), 1 r_hs(i),rho0_hs(i) ) c c branch point c 30 continue 31 continue c c if(i_mode_atom.ne.1)goto 50 c c wave function generation c using mesh form xainpot (r=0 not included) c do 40 i=1,441 if(r_hs(i).gt.r_max) goto 50 c c find nearest points c initialize hunting parameter (subroututine nearest) c jlo=1 call nearest(r,251,r_hs(i), 1 i_point_1,i_point_2,i_point_3) c interpolate wavefunction call interp_quad( 1 r(i_point_1),dgc(i_point_1,i_radial), 1 r(i_point_2),dgc(i_point_2,i_radial), 1 r(i_point_3),dgc(i_point_3,i_radial), 1 r_hs(i),rho0_hs(i) 1 ) 40 continue c c branch point c 50 continue c return end SUBROUTINE NEAREST(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3) C C FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X C AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3 C This subroutine was taken from Numerical Recipes, C W. H. Press, B. F. Flanney, S. A. Teukolsky and W. T. C Vetterling, page 91. Originally called HUNT c IMPLICIT REAL*8(A-H,O-Z) COMMON/MESH_PARAM/JLO C DIMENSION XX(N) LOGICAL ASCND ASCND=XX(N).GT.XX(1) C C EXTRAPOLATE BELOW LOWEST POINT C IF(X.LE.XX(1))THEN I_POINT_1=1 I_POINT_2=2 I_POINT_3=3 RETURN END IF C C EXTRAPOLATE BEYOND HIGHEST POINT C IF(X.GE.XX(N))THEN I_POINT_1=N-2 I_POINT_2=N-1 I_POINT_3=N RETURN END IF IF(JLO.LE.0.OR.JLO.GT.N)THEN JLO=0 JHI=N+1 GO TO 3 ENDIF INC=1 IF(X.GE.XX(JLO).EQV.ASCND)THEN 1 JHI=JLO+INC IF(JHI.GT.N)THEN JHI=N+1 ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN JLO=JHI INC=INC+INC GO TO 1 ENDIF ELSE JHI=JLO 2 JLO=JHI-INC IF(JLO.LT.1)THEN JLO=0 ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN JHI=JLO INC=INC+INC GO TO 2 ENDIF ENDIF 3 IF(JHI-JLO.EQ.1)THEN IF((JLO+1).EQ.N)THEN I_POINT_1=JLO-1 I_POINT_2=JLO I_POINT_3=JLO+1 ELSE I_POINT_1=JLO I_POINT_2=JLO+1 I_POINT_3=JLO+2 END IF RETURN END IF JM=(JHI+JLO)/2 IF(X.GT.XX(JM).EQV.ASCND)THEN JLO=JM ELSE JHI=JM ENDIF GO TO 3 END C C SUBROUTINE INTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4) C C INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2) C TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT C PARAMETERS. THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C C IMPLICIT REAL*8(A-H,O-Z) C TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1) BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1) B = TOP/BOTTOM A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1) C = Y3 - A*X3*X3 - B*X3 Y4 = A*X4*X4 + B*X4 + C C RETURN END C*********************************************************************** C SUBROUTINE MOLDAT(XCOORD,YCOORD,ZCOORD,ZNUMBE,GROUPN,NATOMSM, 1 NTYPES,OK) C C 8-dec-86 C.Brouder C This subroutine builds the file containing the additional input C required for MOLPOT once CLEM has been run. C 15-dec-86 If program CONTINUUM is to be run with complex C potential, set all alpha parametres to zero. C If program MOLPOT is to be run with an outer sphere, C write corresponding parametres. C C Arguments description : C XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms C ZNUMBE Array of the atomic numbers of the atoms C GROUPN Array of the number of the group to which the C atoms belong. (A group is a class of atoms equivalent C by the symmetry operations of the symmetry group) C NATOMSM Number of atoms C NTYPES Number of groups (prototypical atoms) C C DATA description (Value of data is [value]) : C NRUNS Number of cluster for which potential is computed [1] C INV Logical unit from which output from CLEM is read [8] C C NOUT 0 No outer sphere, 1 an outer sphere [0] C NWR1 Punched output to be punched [PCH] C NWR2 Print charge densities, charge, potential [PRT] C 1NSPINS 1 spin restricted potential, 2 spin polarized potential [1] C EXAFCO Slater alpha parameter for exchange for the interstitial regi C OVLF Overlap factor of neighbouring spheres [.10] C CHPERC The charge radius of the atom, is defined as the radius C for which the integrated density of charge is Z*(1+CHPER C This is used to compute the muffin-tin radii [0.005] C NCUT A control number intended to change the mesh size for high C energy calculations [0] (= no change) C C NSYMBL 4 character description of the atom (Symbol + number) C NEQ 0 for prototypical atoms C NTYPE of the prototypical atom for atoms equivalent to N C NGBR The number of neighbours surrounding the atom. C NTYPE Type of the atom (Group number) C XV,YV,ZV Coordinates in atomic units C EXFACT Slater alpha parameter C C ALPHAP Alpha Parameter of elements, from Schwarz, (Phys.Rev.B 5(7) C 2466 (1972)) up to Z=41 (Nb), some possible "interpolation" C for the other elements. C NAMEAT Name of atoms C OUTER Logical. .TRUE. if MOLPOT is to be run with an outer sphere C BOHRAD Bohr radius in Angstrom C C*********************************************************************** C INCLUDE 'msxas3.inc' C COMMON/CONTINUUM/EMIN,EMAX,DELTA,CIP,GAMMA,EFTRI,IEXCPOT C REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM C COMMON/MOLINP/ 1 EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM, 1 NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_), 1 NAM(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 C PARAMETER (NEIMAX=nat_) REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS) INTEGER ZNUMBE(NATOMS),ZNBRE,GROUPN(NATOMS) INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX) LOGICAL OK,OUTER,PROTO,DEUX CHARACTER*5 NWR1,NWR2 REAL ALPHAP(100) DATA NRUNS/1/,INV/8/ DATA NOUT/0/,NSPINS/1/ DATA OVLF/0.0/,CHPERC/0.005/,NCUT/1/ C DATA BOHRAD/.529177/ DATA BOHRAD/1.0/ C H-Ne,Na-Ca,Sc-Zn,Ga-Zr,Nb-Sn,Sb-Nd,Pm-Yb DATA ALPHAP/.978,.773,.781,.768,.765,.759,.752,.744,.737,.731, 1 .731,.729,.728,.727,.726,.725,.723,.722,.721,.720, 1 .718,.717,.716,.714,.713,.712,.710,.709,.707,.707, 1 .707,.707,.707,.706,.706,.706,.706,.705,.705,.704, 1 .704,.704,.704,.704,.704,.704,.704,.704,.704,.704, 1 .703,.703,.703,.703,.703,.703,.703,.703,.703,.703, 1 .702,.702,.702,.702,.702,.702,.702,.702,.702,.702, 1 30*.702/ NWR1=' PCH' NWR2=' PRT' C C Check whether complex potential will be used C IF (IEXCPOT.EQ.4.OR.IEXCPOT.EQ.5) THEN DO 100 I=1,100 ALPHAP(I)=0. 100 CONTINUE END IF C C Ask whether an outer sphere is to be used. C 13-APR-87 In this new version, the file is always generated with an o C sphere. C OUTER=.TRUE. C C* * * * Open file and write header * * * * * * * C OPEN(UNIT=2,FILE='div/STRPARM.DAT',STATUS='UNKNOWN', & FORM='FORMATTED') C C Write first line C WRITE(2,2000) NRUNS,INV 2000 FORMAT(2I5) C C Compute EXAFCO (EXAFCO is taken as the average of all alpha parametr C and write second line. C C Correction for the presence of empty spheres: 27th Sept 2007 C NPA = 0 EXAFCO=0. DO 200 I=1,NATOMSM NZAT = ZNUMBE(I) IF(NZAT.NE.0) THEN NPA = NPA + 1 EXAFCO=EXAFCO+ALPHAP(NZAT) ENDIF 200 CONTINUE EXAFCO=EXAFCO/NPA IF (OUTER) THEN IITYPE=NTYPES+1 IIATOM=NATOMSM+1 NOUT=1 ELSE IITYPE=NTYPES IIATOM=NATOMSM NOUT=0 END IF WRITE(2,2010) IITYPE,IIATOM,NOUT,NWR1,NWR2,NSPINS,EXAFCO,OVLF, 1 CHPERC,NCUT 2010 FORMAT(3I5,2A5,I5,3F10.5,I5) C EXAFCOM=DBLE(EXAFCO) OVLFM=DBLE(OVLF) CHPERCM=DBLE(CHPERC) C C* * * * * * Write outer sphere description if any * * * * C IF (OUTER) THEN XV=0. YV=0. ZV=0. ITYPE=0 CALL GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, 1 NGBR,NEIGHB,NUMNEI,OK) IF (.NOT.OK) THEN CLOSE(UNIT=2) RETURN END IF EXFACT=EXAFCO ZNBRE=0 PROTO=.TRUE. N = 1 CALL WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN, 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) END IF C C* * * * * * Write prototypical atom description * * * * * C DO 300 NTYPE=1,NTYPES XV=XCOORD(NTYPE)/BOHRAD YV=YCOORD(NTYPE)/BOHRAD ZV=ZCOORD(NTYPE)/BOHRAD C C CALL GRPNEI(NTYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, 1 NGBR,NEIGHB,NUMNEI,OK) IF (.NOT.OK) THEN CLOSE(UNIT=2) RETURN END IF ZNBRE=ZNUMBE(NTYPE) C C.......CHANGE FOR ES C IF(ZNBRE.EQ.0.D0) THEN EXFACT=EXAFCO ELSE EXFACT=ALPHAP(ZNBRE) ENDIF PROTO=.TRUE. N=NTYPE+1 CALL WRIDAT(XV,YV,ZV,NTYPE,ZNBRE,NGBR,EXFACT,GROUPN, 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) 300 CONTINUE C C* * * * * Write non prototypical atom description * * * * * * C IF (NATOMSM.GT.NTYPES) THEN DO 400 I=NTYPES+1,NATOMSM XV=XCOORD(I)/BOHRAD YV=YCOORD(I)/BOHRAD ZV=ZCOORD(I)/BOHRAD ZNBRE=ZNUMBE(I) C C.......CHANGE FOR ES C IF(ZNBRE.EQ.0.D0) THEN EXFACT=EXAFCO ELSE EXFACT=ALPHAP(ZNBRE) ENDIF CALL GRPNEI(I,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, 1 NGBR,NEIGHB,NUMNEI,OK) IF (.NOT.OK) THEN C CLOSE(UNIT=2) RETURN END IF PROTO=.FALSE. N = I + 1 CALL WRIDAT(XV,YV,ZV,I,ZNBRE,NGBR,EXFACT,GROUPN, 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) 400 CONTINUE END IF C CLOSE (UNIT=2) C C * * * * * * * Create MOLSYM.COO * * * * * * * * C C Now we create a file called MOLSYM.COO which lists the coordinates C and the number of each atom in the cluster, according to the C FORMAT required by MOLSYM. This file will be used later on to C make the input file of MOLSYM. In this file, the atoms must be C ordered according to their group (all equivalent atoms must follow C each other), and numbered according to the way their are declared C in the input of MOLPOT. If an outer sphere is to be used, it must C be declared to be atom number 1. C According to the FORMAT required by MOLSYM, the atoms must C be written in pairs. The logical variable DEUX is here to say C that two atoms are available and it is time to write them. C OPEN(UNIT=2,FILE='div/molsym.coo',STATUS='unknown') C*************************************************** C*************************************************** DEUX=.TRUE. C**** IF (OUTER) THEN C**** XX1=0. C**** YY1=0. C** ZZ1=0. C** NN1=1 C** DEUX=.FALSE. C** END IF C X0 = XCOORD(1) Y0 = YCOORD(1) Z0 = ZCOORD(1) C DO 500 ITYPE=1,NTYPES DO 500 I=1,NATOMSM C C Order atoms according to their groups C IF (GROUPN(I).EQ.ITYPE) THEN IF (DEUX) THEN XX1=XCOORD(I)/BOHRAD - X0 YY1=YCOORD(I)/BOHRAD - Y0 ZZ1=ZCOORD(I)/BOHRAD - Z0 C*** IF (OUTER) THEN C*** NN1=I+1 C*** ELSE NN1=I C*** END IF DEUX=.FALSE. ELSE XX2=XCOORD(I)/BOHRAD - X0 YY2=YCOORD(I)/BOHRAD - Y0 ZZ2=ZCOORD(I)/BOHRAD - Z0 C*** IF (OUTER) THEN C*** NN2=I+1 C*** ELSE NN2=I C*** END IF WRITE (2,3000) XX1,YY1,ZZ1,NN1,XX2,YY2,ZZ2,NN2 3000 FORMAT(2(3F10.6,I5,5X)) DEUX=.TRUE. END IF END IF 500 CONTINUE C C If the number of atoms written in the file (including possibly C the outer sphere) is not even, there is an atom that is left C to be written, so write it. In any case, close the file. C IF (.NOT.DEUX) THEN WRITE (2,3010) XX1,YY1,ZZ1,NN1 3010 FORMAT(3F10.6,I5,5X) END IF CLOSE (UNIT=2) RETURN END C C*********************************************************************** C SUBROUTINE GRPNEI(ITYPE,XCOORD,YCOORD,ZCOORD,GROUPN,NATOMSM, 1 NGBR,NEIGHB,NUMNEI,OK) C C 9-dec-86 C.Brouder C This subroutine finds the groups of neighbours of atom number ITYPE C A group of neighbours of atom ITYPE is a set of all atoms C at the same distance from atom ITYPE and belonging to the same group C (i.e. equivalent to the same prototypical atom, i.e.having the same C group number GROUPN). C At the end, the groups of neigbours are sorted according to increasi C distances. C C Arguments description : C ITYPE # of atom (0 if outer sphere) whose neighbours C are to be determined. C XCOORD,YCOORD,ZCOORD Array of the coordinates of the atoms. C GROUPN Array of the number of the group to which the C atoms belong. (A group is a class of atoms equivalent C by the symmetry operations of the symmetry group). C NATOMSM Number of atoms C NGBR Number of groups of neighbours C NEIGHB # of an atom in the group of neigbours C NUMNEI Number of atoms in the group of neighbours C NEIMAX Maximum number of groups of neighbours. C C DISTAN Array of distances of neigbours C EPSILO If the distances are smaller than EPSILO, they are C supposed to be identical. C C********************************************************************* C INCLUDE 'msxas3.inc' C PARAMETER (NEIMAX=nat_) REAL XCOORD(NATOMS),YCOORD(NATOMS),ZCOORD(NATOMS) REAL DISTAN(NEIMAX) INTEGER GROUPN(NATOMS),NEIGHB(NEIMAX),NUMNEI(NEIMAX) LOGICAL OK,NEW DATA EPSILO/1.E-5/ NGBR=1 C C Initialize arrays C DO 100 I=1,NATOMSM NEIGHB(I)=0 NUMNEI(I)=0 100 CONTINUE IF (ITYPE.EQ.0) THEN X0=0. Y0=0. Z0=0. ELSE X0=XCOORD(ITYPE) Y0=YCOORD(ITYPE) Z0=ZCOORD(ITYPE) END IF C C Scan all other atoms C DO 200 I=1,NATOMSM IF (I.NE.ITYPE) THEN C C Compute distance C NEW=.TRUE. DISTAN(NGBR)=(XCOORD(I)-X0)*(XCOORD(I)-X0) DISTAN(NGBR)=DISTAN(NGBR)+(YCOORD(I)-Y0)*(YCOORD(I)-Y0) DISTAN(NGBR)=DISTAN(NGBR)+(ZCOORD(I)-Z0)*(ZCOORD(I)-Z0) DISTAN(NGBR)=SQRT(DISTAN(NGBR)) IF (NGBR.NE.1) THEN C C Check whether this distance already exists and the corresponding C atom belongs to the same group. C DO 210 I2=1,NGBR-1 IF ((ABS(DISTAN(I2)-DISTAN(NGBR)).LT.EPSILO).AND. 1 (GROUPN(NEIGHB(I2)).EQ.GROUPN(I))) THEN NEW=.FALSE. NUMNEI(I2)=NUMNEI(I2)+1 END IF 210 CONTINUE END IF C C If it does not, this is a new group C IF (NEW) THEN NUMNEI(NGBR)=1 NEIGHB(NGBR)=I NGBR=NGBR+1 IF (NGBR.GT.NEIMAX) THEN PRINT 4000 4000 FORMAT(' Too many neighbours, increase NEIMAX in', 1 ' subroutines GRPNEI and MOLDAT') OK=.FALSE. RETURN END IF END IF END IF 200 CONTINUE NGBR=NGBR-1 C C Order groups of neighbours according to increasing distances C DO 300 I=1,NGBR C C Look for the smallest remaining distance C DISMIN=1.E20 IDISMI=I DO 310 J=I,NGBR IF (DISTAN(J).LT.DISMIN) THEN DISMIN=DISTAN(J) IDISMI=J END IF 310 CONTINUE C C Transpose values C IF (IDISMI.NE.I) THEN N1TEMP=NEIGHB(I) N2TEMP=NUMNEI(I) DTEMPO=DISTAN(I) NEIGHB(I)=NEIGHB(IDISMI) NUMNEI(I)=NUMNEI(IDISMI) DISTAN(I)=DISTAN(IDISMI) NEIGHB(IDISMI)=N1TEMP NUMNEI(IDISMI)=N2TEMP DISTAN(IDISMI)=DTEMPO END IF 300 CONTINUE RETURN END C C*********************************************************************** C SUBROUTINE WRIDAT(XV,YV,ZV,ITYPE,ZNBRE,NGBR,EXFACT,GROUPN, 1 NUMNEI,NEIGHB,NATOMSM,OUTER,PROTO,N) C C This subroutine writes on file 2 the data collected by MOLDAT, C for each atom. There are many cases to consider : the outer sphere C (ITYPE=0), prototypical atoms (PROTO=.TRUE.), non prototypical atoms C (PROTO=.FALSE.) and in the latter cases, the outputs are different C if there is an outer sphere (OUTER=.TRUE.) or not. C Variable description C XV,YV,ZV Position C ITYPE # of atom whose data are involved C ZNBRE Z number of atom C NGBR Number of neighbours C EXFACT Alpha parametre C GROUPN Group numbers C NUMNEI Number of neighbours C NEIGHB Example of neighbour C NATOMSM Number of atoms C OUTER .TRUE. if there is an outer sphere C PROTO .TRUE. if this is a prototypical atom C C NSYMBL Symbol C C******************************************************************** C INCLUDE 'msxas3.inc' C REAL*8 EXAFCOM,EXFCTM,OVLFM,CHPERCM C COMMON/MOLINP/ 1 EXAFCOM,EXFCTM(NAT_),OVLFM,CHPERCM,IITYPE,IIATOM, 1 NGBRM(NAT_),NTYPEM(NAT_),NATAN(NAT_,UA_), 1 NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 C PARAMETER (NEIMAX=nat_) INTEGER GROUPN(NATOMS),ZNBRE INTEGER NEIGHB(NEIMAX),NUMNEI(NEIMAX) LOGICAL PROTO,OUTER CHARACTER*5 NWR1,NWR2 C C* * * * * * Initialize data * * * * * * * C C C NEQ (0 if prototypical atom, NTYPE of prototypical atom otherwise C IF (PROTO) THEN NEQ=0 ELSE IF (OUTER) THEN NEQ=GROUPN(ITYPE)+1 ELSE NEQ=GROUPN(ITYPE) END IF END IF C C NTYPE (if outer sphere, outer sphere is number 1, so add 1 to C all group numbers) C IF (PROTO) THEN IF (OUTER) THEN NTYPE=ITYPE+1 ELSE NTYPE=ITYPE END IF ELSE NTYPE=NEQ END IF C C* * * Initialize variables for subroutine molpot * * * C NGBRM(N)=NGBR NTYPEM(N)=NTYPE EXFCTM(N)=DBLE(EXFACT) C C* * * Initialize variables for subroutine molpot * * * C IF (PROTO) THEN DO 300 K=1,NGBR IF (OUTER) THEN NATAN(K,N) = GROUPN(NEIGHB(K)) + 1 NAT1(K,N) = NEIGHB(K) + 1 ELSE NATAN(K,N) = GROUPN(NEIGHB(K)) NAT1(K,N) = NEIGHB(K) ENDIF 300 NA(K,N) = NUMNEI(K) ENDIF C RETURN END C C*********************************************************************** C SUBROUTINE MOLPOT C C SPIN-RESTRICTED MOLECULAR POTENTIAL PROGRAM C GENERATES SUPERPOSED-ATOM POTENTIAL USED TO START SCF CALCULATION C implicit real*8 (a-h,o-z) include 'msxas3.inc' c include 'msxasc3.inc' c character*8 nsymbl c.. c common/dimens/nats,ndat,nout,lmaxx,irreps common/aparms/xv(natoms),yv(natoms),zv(natoms),z(natoms), u nsymbl(natoms),nzeq(natoms),neq(natoms),ncores(natoms), u lmaxat(natoms) common/aparms_extra/rs_(natoms),redf_(natoms),ovlf c integer trans common/transform/trans(natoms) C COMMON/MOLINP/ * EXFAC0,EXFACT(NAT_),OVLFM,CHPERC,NTYPES,NATOMSM, * NGBR(NAT_),NTYPE(NAT_),NATAN(NAT_,UA_), * NA(NAT_,UA_),NAT1(NAT_,UA_),NWR1,NWR2 C COMMON/CRHOAT/ RO(441,UA_,1) C COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT C COMMON/MTRAD/ RS(NAT_) C COMMON/STRUCT/NTNABS(NAT_),NGBRABS C DIMENSION R(441,UA_),V(441,1),RV(441,UA_),Q(441),ALPHA(441), 1 BETA(441),GAMMA(441,1),SNLO(441),XI(441),XJ(441), 2 ZPALPH(441),ROTOTL(441,1),ROT(441) C DIMENSION ZM(NAT_),NZM(NAT_),NIMAX(NAT_),AN(NAT_,NAT_), * FAC2(NAT_),RSC(NAT_) C CHARACTER*5 NWR1,NWR2 C c DATA PI/3.14159265358979/ c DATA PI4/12.56637061435916/,THIRD/.333333333333333/ C LOGICAL SKIP PI=3.14159265358979D0 PI4=12.56637061435916D0 THIRD=.333333333333333D0 NRUNS = 1 DO 999 IRUNS=1,NRUNS 1002 FORMAT(15I5) SKIP=.FALSE. C C.....MOUT: CONTROLS THE OUTPUT OF PROGRAM INPOT. IF MOUT=1 THIS C..... OUTPUT WILL CONTAIN THE OUTER SPHERE. IF MOUT=0 IT C..... WILL NOT. THIS VERSION INITIALIZED TO MOUT=0 C.....0VLF: THIS IS THE OVERLAP FACTOR FOR THE MUFFIN-TIN RADII C..... DEFAULT=0.1 IN SUBROUTINE MOLDAT C.....CHPERC: THIS IS THE PERCENTAGE OF ATOMIC CHARGE INSIDE THE C..... ATOMIC SPHERES WHEN APPLYING NORMAN CRITERIUM C..... DEFAULT=0.005 IN SUBROUTINE MOLDAT C MOUT=0 NOUT=1 NSPINS=1 NSAT=1 NCUT=1 FAC1=NSPINS NDAT=NATOMSM OPEN (UNIT=7,FILE='div/molinpot3.out',STATUS='unknown') DO 43 N=1,NATOMSM C READ(5,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N), C 1 EXFACT(N) 1001 FORMAT(1X,A8,3I5,4F10.6) WRITE(7,1001) NSYMBL(N),NEQ(N),NGBR(N),NTYPE(N),XV(N),YV(N),ZV(N), 1 EXFACT(N) FAC2(N)=6.D0*EXFACT(N)*(FAC1*3.D0/(32.D0*PI*PI))**THIRD IF(NEQ(N).NE.0) GO TO 443 NGBRS=NGBR(N) C READ(5,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS) C NATAN=TYPE OF NEIGHBOR NA=NUMBER OF ATOMS IN GROUP NAT1=LABEL OF C ONE OF THE NEIGHBORS C WRITE(7,1002) (NATAN(I,N),NA(I,N),NAT1(I,N),I=1,NGBRS) IF(SKIP) GO TO 4511 GO TO 43 4511 WRITE(7,1045) 1045 FORMAT(' DIFFERENT ATOMS MUST COME FIRST') SKIP=.FALSE. GO TO 43 443 IF(SKIP) GO TO 43 SKIP=.TRUE. NDAT=N-1 43 CONTINUE C C AN(I,N): DISTANCE OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I C WRITE(7,*) WRITE(7,*) 'DIST. OF PROTOTYPICAL ATOM N FROM NEIGHBORS OF TYPE I' ANMAX = 0.0D0 DO 44 N=1,NDAT ANPR=0.0D0 NGBRS=NGBR(N) IF(N.EQ.2) NGBRABS=NGBRS DO 44 I=1,NGBRS NT = NATAN(I,N) IF(N.EQ.2) NTNABS(I)=NT-1 C write(6,*) i,nt,ntnabs(i),ngbrabs NB=NAT1(I,N) AN(I,N)=DSQRT((XV(NB)-XV(N))**2+(YV(NB)-YV(N))**2+(ZV(NB)-ZV(N))** 1 2) WRITE(7,*) N, NT, AN(I,N) IF(I.EQ.1) THEN ANPR=AN(I,N) GO TO 440 ENDIF IF(AN(I,N).LT.ANPR) THEN WRITE(7,30) I,N 30 FORMAT(' **WARNING** : NEIGHBOR OF TYPE',I3,' TO ATOM',I3, * ' NOT ARRANGED IN ASCENDING ORDER OF DISTANCE') C C CALL EXIT C ENDIF 440 IF(N.NE.1) GO TO 44 IF(AN(I,N).GT.ANMAX) ANMAX = AN(I,N) 44 CONTINUE SKIP=NOUT.NE.0 WRITE(7,104) NATOMSM,NDAT,FAC1 104 FORMAT(30X,I3,7H ATOMS,,I3,17H DIFFERENT, FAC1=,F11.7) WRITE(7,105) (NSYMBL(N),NEQ(N),XV(N),YV(N),ZV(N),EXFACT(N),N=1, 1 NATOMSM) 105 FORMAT(//28X,6HSYMBOL,4X,2HEQ,5X,1HX,11X,1HY,11X,1HZ,7X,6HEXFACT 1 /(30X,A5,I6,4F11.7)) DO 1 N=1,NTYPES IF(SKIP) GO TO 89 WRITE(7,2002) NZEQ(N),NSAT 2002 FORMAT(6I4) KMAX=441 ZM(N)=NZEQ(N) NZM(N)=NZEQ(N) TZ=2.D0*ZM(N) GO TO 90 89 DELTAR=.88534138D0*.0025D0 NZM(1)=1 GO TO 91 90 IF(ZM(N).EQ.0.D0) THEN DELTAR=.88534138D0*.0025D0 ELSE DELTAR=.88534138D0*.0025D0/ZM(N)**THIRD ENDIF 91 I=1 R(1,N)=0.D0 DO 87 J=1,11 DO 88 K=1,40 I=I+1 88 R(I,N)=R(I-1,N)+DELTAR 87 DELTAR=2.0D0*DELTAR IF(SKIP) GO TO 49 DO 52 K=1,441 52 ROT(K)=RO(K,N,1) CALL MINTEGR(ROT,XI,R(1,N),441) Q(1)=0.D0 DO 10 I=2,441 10 Q(I)=ROT(I)/R(I,N) CALL MINTEGR(Q,XJ,R(1,N),441) C C RV=R*( COULOMB POTENTIAL ) C DO 12 I=1,441 12 RV(I,N)=-TZ+2.D0*(XI(I)+R(I,N)*(XJ(441)-XJ(I))) IF(NSPINS.EQ.1.AND.ZM(N).NE.0) 1 WRITE(7,101) N,(I,R(I,N),RV(I,N),ROT(I),XI(I),I=1,KMAX) 101 FORMAT(1H1,40X,22HATOMIC DATA FOR CENTER,I3,4X,/, & 2(9X,1HR,15X,2HRV, 1 14X,3HRHO,11X,6HCHARGE,3X),/,2(I4,1P4E15.6)) GO TO 1 49 DO 50 J=1,441 50 RV(J,N)=0.D0 1 SKIP=.FALSE. IF(NWR1.NE.' PCH') GO TO 1041 OPEN (UNIT=4,FORM='UNFORMATTED',STATUS='unknown') REWIND(4) WRITE(4) NATOMSM,NDAT,NOUT,EXFAC0,NSPINS KC=2 1041 DO 1000 M=1,NDAT N=NTYPE(M) NZM(M)=NZM(N) NIMAX(M)=441 IF(M.EQ.1.AND.NOUT.NE.0) GO TO 450 DO 1043 J=1,441 IF(R(J,N).LT.AN(1,M)) GO TO 1043 NIMAX(M)=J GO TO 450 1043 CONTINUE 450 NBRS=NGBR(M) IMAX=NIMAX(M) DO 600 I=1,441 ZPALPH(I)=0.D0 BETA(I)=0.D0 DO 600 ISPIN=1,NSPINS ROTOTL(I,ISPIN)=0.D0 600 GAMMA(I,ISPIN)=0.D0 DO 45 I=1,NBRS MVAL=NATAN(I,M) IF(NOUT.NE.0.AND.MVAL.EQ.1) GO TO 45 C C ITH SET OF NEIGHBORS TO CENTER M C N IS TYPE OF CENTER M C MVAL IS THE TYPE OF ITH SET OF NEIGHBORS TO CENTER M C IF(AN(I,M).GT..00001D0) GO TO 650 C C FOR A CENTER COINCIDING WITH THE MOLECULAR CENTER C AVERAGE VALUES ARE EQUAL TO THE VALUES AT THE POINT C DO 652 J=2,IMAX CALL MINTERP(R(J,N),RV(1,MVAL),XVAL,R(1,MVAL)) ZPALPH(J)=ZPALPH(J)+NA(I,M)*XVAL BETA(J)=BETA(J)-0.5D0*XVAL*NA(I,M)*R(J,N)**2 DO 652 ISPIN=1,NSPINS CALL MINTERP(R(J,N),RO(1,MVAL,ISPIN),XVAL,R(1,MVAL)) ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*XVAL/R(J,N) 652 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)-0.5D0*XVAL*NA(I,M)*R(J,N) DO 451 ISPIN=1,NSPINS CALL MINTEGR(RO(1,MVAL,ISPIN),SNLO,R(1,MVAL),441) DO 451 J=1,441 CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL)) XJ(J)=R(J,MVAL)*RV(J,MVAL) 451 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*XVAL CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) DO 452 J=1,441 CALL MINTERP(R(J,N),SNLO,XVAL,R(1,MVAL)) 452 BETA(J)=BETA(J)+NA(I,M)*XVAL GO TO 45 C C FOR SEPARATED CENTERS CALCULATE SPHERICAL AVERAGES AROUND CENTER M C 650 CALL MINTEGR(RV(1,MVAL),SNLO,R(1,MVAL),441) CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL) DO 65 J=2,IMAX 65 ZPALPH(J)=NA(I,M)*ALPHA(J)+ZPALPH(J) Q(1)=0.D0 C C SPHERICAL AVERAGE CHARGE DENSITY C DO 95 ISPIN=1,NSPINS DO 901 J=2,441 901 Q(J)=RO(J,MVAL,ISPIN)/R(J,MVAL) CALL MINTEGR(Q,SNLO,R(1,MVAL),441) CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,IMAX,N,MVAL) DO 95 J=2,IMAX 95 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)+NA(I,M)*ALPHA(J) IF(N.NE.1.OR.NOUT.EQ.0) GO TO 45 XJ(1)=0.D0 C C TOTAL CHARGE FOR OUTER SPHERE C DO 37 ISPIN=1,NSPINS DO 36 J=2,441 36 XJ(J)=-RO(J,MVAL,ISPIN)*(R(J,MVAL)-AN(I,M))**2/R(J,MVAL) CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) CALL ALPHA0(AN(I,M),SNLO,Q,R,441,N,MVAL) CALL MINTEGR(RO(1,MVAL,ISPIN),XJ,R(1,MVAL),441) DO 37 J=2,441 CALL MINTERP(R(J,N)-AN(I,M),XJ,XVAL,R(1,MVAL)) 37 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+NA(I,M)*(XVAL+0.5D0*Q(J)) C C INTEGRATED POTENTIAL FOR OUTER SPHERE C XI(1)=0.D0 XJ(1)=-RV(1,MVAL)*AN(I,M)**2 DO 46 J=2,441 XI(J)=RV(J,MVAL)*R(J,MVAL) 46 XJ(J)=-RV(J,MVAL)*(R(J,MVAL)-AN(I,M))**2 CALL MINTEGR(XI,Q,R(1,MVAL),441) CALL MINTEGR(XJ,SNLO,R(1,MVAL),441) CALL ALPHA0(AN(I,M),SNLO,ALPHA,R,441,N,MVAL) DO 47 J=2,441 CALL MINTERP(R(J,N)-AN(I,M),Q,XVAL,R(1,MVAL)) 47 BETA(J)=BETA(J)+NA(I,M)*(XVAL+0.5D0*ALPHA(J)) 45 CONTINUE IF(N.NE.1.OR.NOUT.EQ.0) GO TO 2003 DO 2005 J=1,IMAX BETA(J)=(BETA(J)+0.5D0*ZPALPH(J)*R(J,N)**2)*PI4 DO 2005 ISPIN=1,NSPINS ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N) 2005 GAMMA(J,ISPIN)=GAMMA(J,ISPIN)+0.5D0*ROTOTL(J,ISPIN)*R(J,N) GO TO 112 C C INTEGRATED POTENTIAL AND TOTAL CHARGE FOR MUFFIN-TIN SPHERE C GAMMA(I,ISPIN) IS TOTAL INTEGRATED CHARGE, BETA(I) IS INTEGRATED C POTENTIAL, ZPALPH(I) IS R*VCOULOMB CALCULATED WITH PROJECTED C DENSITY C 2003 DO 2001 J=1,IMAX ZPALPH(J)=ZPALPH(J)+RV(J,N) Q(J)=PI4*R(J,N)*ZPALPH(J) DO 2001 ISPIN=1,NSPINS 2001 ROTOTL(J,ISPIN)=ROTOTL(J,ISPIN)*R(J,N)+RO(J,N,ISPIN) DO 2004 ISPIN=1,NSPINS 2004 CALL MINTEGR(ROTOTL(1,ISPIN),GAMMA(1,ISPIN),R(1,N),IMAX) CALL MINTEGR(Q,BETA,R(1,N),IMAX) 112 DO 111 ISPIN=1,NSPINS V(1,ISPIN)=0 DO 111 J=2,IMAX C C VC(J) = ZPALPH(J)/R(J,N) C 111 V(J,ISPIN)=(ZPALPH(J)-FAC2(M)*(R(J,N)*DABS(ROTOTL(J,ISPIN)))**THIR 1D)/R(J,N) C C...FIND RADIUS CONTAINING THE ATOMIC NUMBER OF ELECTRONS WITHIN CHPERC C RSC(M) = AN(1,M)/2.D0 IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 14 IF(NZM(M).EQ.0) GO TO 14 DO 13 I=1,IMAX C IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 13 CHPCI=(ZM(M)-GAMMA(I,1))/ZM(M) IF(CHPCI.GT.CHPERC)GO TO 13 RSC(M) = R(I,M) GO TO 14 13 CONTINUE 14 IF(NWR2.NE.' PRT') GO TO 1032 WRITE(7,6)M 6 FORMAT(1H1,35X,11HATOM NUMBER,I6) WRITE(7,7) (NA(I,M),NATAN(I,M),AN(I,M),I=1,NBRS) 7 FORMAT(/ 23H NO. OF CENTERS TYPE,7X,8HDISTANCE/(5X,I4,10X,I 1 4,F17.8)) IF(NSPINS.EQ.1) WRITE(7,9)(J,R(J,N),ZPALPH(J),BETA(J),GAMMA(J,1),V 1 (J,1),ROTOTL(J,1),J=1,IMAX) 9 FORMAT(16X,1HR,16X,6HZPALPH,5X,20HINTEGRATED POTENTIAL,7X,12HTOTAL 1 CHARGE,13X,1HV,18X,3HRHO/(I4,6E20.8)) 1032 IF(NWR1.NE.' PCH') GO TO 1000 NIMAX(M)=NIMAX(M)-1 WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M), 1 ZV(M),EXFACT(M),KC KC=KC+1 DO 1014 ISPIN=1,NSPINS DO 1014 K=2,IMAX,5 KCARD=MIN0(IMAX,K+4) WRITE(4) KC,( V(I,ISPIN),I=K,KCARD) 1014 KC=KC+1 C DO 1020 K=2,IMAX,5 C KCARD=MIN0(IMAX,K+4) C WRITE(4,1015) KC,( VC(I),I=K,KCARD) C 1020 KC=KC+1 DO 2214 ISPIN=1,NSPINS DO 2214 K=2,IMAX,5 KCARD=MIN0(IMAX,K+4) WRITE(4) KC,(ROTOTL(I,ISPIN) ,I=K,KCARD) 2214 KC=KC+1 DO 1016 K=2,IMAX,5 KCARD=MIN0(IMAX,K+4) WRITE(4) KC,(BETA(I),I=K,KCARD) 1016 KC=KC+1 DO 1019 ISPIN=1,NSPINS DO 1019 K=2,IMAX,5 KCARD=MIN0(IMAX,K+4) WRITE(4) KC,(GAMMA(I,ISPIN) ,I=K,KCARD) 1019 KC=KC+1 1000 CONTINUE C WRITE(7,*) 'CHECKING MUFFIN-TIN RADII' IF(OPTRSH.EQ.'y') THEN WRITE(6,*) ' MT radii for Hydrogen atoms set to rsh' WRITE(7,*) ' MT radii for Hydrogen atoms set to rsh =', RSH ELSE WRITE(6,*) ' MT radii for Hydrogen atoms determined by stdcrm', & ' unless other options are specified' WRITE(7,*) ' MT radii for Hydrogen atoms determined by stdcrm', & ' unless other options are specified' ENDIF WRITE(7,*) ' M, Z(M), MN, Z(MN), AN(MN,M),', & ' RSC(M), RSC(MN), RS(M), RS(MN)' C C FIND MUFFIN-TIN RADIUS FOR PAIR IJ ACCORDING TO NORMAN CRITERIUM (STDCRM) C DO 18 M=1,NDAT IF(M.EQ.1.AND.NOUT.EQ.1) GO TO 18 NBRS=NGBR(M) IF(NZM(M).NE.0) THEN DO NG = 1, NBRS MN=NATAN(NG,M) IF(NZM(MN).NE.0) GO TO 191 ENDDO 191 RS(M)=AN(NG,M)*(1.D0+OVLF)/(1.D0+RSC(MN)/RSC(M)) C C IF OPTRSH='y' MT RADIUS FOR H ATOMs SET TO RSH IN INPUT ! Added 16 Jul 2013 C IF(NZM(M).EQ.1.AND.OPTRSH.EQ.'y') THEN WRITE(6,*) ' MT radius', RS(M),' for H atom', M, & ' set to', RSH RS(M) = RSH ENDIF WRITE(7,190) M, NZM(M), MN, NZM(MN), AN(NG,M), & RSC(M), RSC(MN), RS(M), RS(MN) GO TO 18 ENDIF MN = NATAN(1,M) IF (NZM(MN).EQ.0.D0) THEN RS(M) = AN(1,M)*(1.D0+OVLF)/2.D0 ELSE RS(M) = (AN(1,M)-RS(MN))*(1.D0+OVLF) ENDIF WRITE(7,190) M, NZM(M), MN, NZM(MN), AN(1,M), & RSC(M), RSC(MN), RS(M), RS(MN) 190 FORMAT(4I5, 5F10.5) IF(NORMAN.EQ.'stdfac'.OR.NORMAN.EQ.'scaled') *RS(M)=REDF_(M)*RSC(M) 18 CONTINUE IF(NOUT.EQ.1) RS(1) = ANMAX + RS(NDAT) IF(NDAT.EQ.NATOMSM) GO TO 5001 NDAT1=NDAT+1 DO 221 M=NDAT1,NATOMSM NZM(M)= NZM(NEQ(M)) RS(M)= RS(NEQ(M)) NIMAX(M)=0 WRITE(4) NSYMBL(M),NEQ(M),NZM(M),NIMAX(M),XV(M),YV(M), 1 ZV(M),EXFACT(M),KC 221 KC=KC+1 5001 CONTINUE IF (NORMAN.EQ.'extrad') THEN RS(1) = ANMAX + RS_(NDAT) DO 5002 M=2,NATOMSM 5002 RS(M)=RS_(M) END IF IF (NORMAN.NE.'extrad') THEN WRITE(6,*) WRITE(6,5003) 5003 FORMAT(1X,65('-')) WRITE(6,*) ' i rs(i) i=1,natoms ' WRITE(6,5004) (I, RS(I), I=1,NATOMSM) WRITE(6,*) ' N.B.: Order of atoms as reshuffled by', * ' symmetry routines ' 5004 FORMAT(8(I5,1X,F7.2)) WRITE(6,5003) WRITE(6,*) END IF IF(NWR1.NE.' PCH') GO TO 999 WRITE(7,*) WRITE(7,*) ' Radion, qion, ncut, rs(i), i=1,nat' WRITE(7,19) RADION,QION,NCUT,(RS(M),M=1,NATOMSM) 19 FORMAT(/,1X,2F10.5,I5/(8F10.5),//) 999 CONTINUE C REWIND(4) C RETURN END C CLAGRNG SUBROUTINE LAGRNG(F,LPLACE,B,RES) IMPLICIT REAL*8(A-H,O-Z) DIMENSION F(4),B(4) RES=0.D0 DO 5 N=1,4 M=LPLACE-2+N 5 RES=RES+B(N)*F(M) RETURN END CBSET SUBROUTINE BSET(PINTRP,B) IMPLICIT REAL*8(A-H,O-Z) DIMENSION B(4) PM=PINTRP*(PINTRP**2-1.D0)*(PINTRP-2.D0) B(1)=-PM/(6.D0*(PINTRP+1.D0)) B(2)= PM/(2.D0*PINTRP) B(3)=-PM/(2.D0*(PINTRP-1.D0)) B(4)= PM/(6.D0*(PINTRP-2.D0)) RETURN END CINTERP C L.F. MATTHEISS SUBROUTINE INTERP(B,X1,M2,D,R) C B IS THE RADIAL DISTANCE C X1 IS THE INTEGRATED FUNCTION C D IS THE INTERPOLATED VALUE OF THE INTEGRAL FROM 0 TO B. C R IS THE RADIAL MESH C SUBROUTINE MINTERP(B,X1,D,R) IMPLICIT REAL*8(A-H,O-Z) DIMENSION X1(441),R(441),B1(4),C(4) IF(B-R(2 ))10,11,12 10 D=0.0D0 GOTO 100 11 D=X1(2) GOTO 100 12 IF(B-R(440 ))15,14,13 13 D=X1(441) GOTO 100 14 D=X1(440) GOTO 100 15 DO 22 I=1,441 L=441+1-I IF(R(L)-B) 23,24,22 22 CONTINUE 23 LPLACE=L DO 29 N=1,11 ISCALE=41+40*(N-1)-LPLACE IF(ISCALE)25,46,25 25 IF(ISCALE-1)29,48,29 29 CONTINUE B1(1)=X1(LPLACE-1) B1(2)=X1(LPLACE) B1(3)=X1(LPLACE+1) B1(4)=X1(LPLACE+2) H=R(LPLACE+1 )-R(LPLACE ) 50 PINTRP=(B-R(LPLACE ))/H 51 CALL BSET(PINTRP,C) CALL LAGRNG(B1,2,C,D) 100 RETURN 24 D=X1(L) RETURN 46 B1(1)=X1(LPLACE-2) B1(2)=X1(LPLACE) B1(3)=X1(LPLACE+1) B1(4)=X1(LPLACE+2) H=R(LPLACE+1 )-R(LPLACE ) GOTO 50 48 B1(1)=X1(LPLACE-3) B1(2)=X1(LPLACE-1) B1(3)=X1(LPLACE+1) B1(4)=X1(LPLACE+2) H=R(LPLACE+2 )-R(LPLACE+1 ) PINTRP=(B-R(LPLACE-1 ))/H GO TO 51 END CINTEGR C SIMPSON'S RULE INTEGRATION C SUBROUTINE MINTEGR(X,Y,R,M2) IMPLICIT REAL*8(A-H,O-Z) DIMENSION X(441),Y(441),R(441) H=R(2) Y(1)=0.D0 Y(2)=H*(5.D0*X(1 )+8.D0*X(2 )-X(3 ))/12.D0 DO 20 J=1,11 DO 10 K=1,40 I=40*(J-1)+K IF(I.GT.M2) RETURN IF(I-440) 5,10,10 5 Y(I+2)=Y(I)+H*(X(I )+4.D0*X(I+1 )+X(I+2 ))/3.D0 10 CONTINUE H=H+H IF (I-440) 15,20,15 15 Y(I+2)=Y(I+1)+H*(5.D0*X(I+1 )+8.D0*X(I+2 )-X(I+3 ))/12.D0 20 CONTINUE RETURN END CALPHAO C L.F. MATTHEISS SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2) C AP IS THE DISTANCE OF THE NEIGHBORING ATOM C ZINT IS THE INDEFINITE INTEGRAL C ALPHA IS A TABLE OF THE DESIRED ALPHA FUNCTIONS C R IS THE RADIAL DISTANCE C IMAX IS THE NUMBER OF ALPHA FUNCTIONS TO BE COMPUTED C M1 IS THE ATOM NO. AT THE ORIGIN C M2 IS THE ATOM NO. AT AP C SUBROUTINE ALPHA0(AP,ZINT,ALPHA,R,IMAX,M1,M2) C IMPLICIT REAL*8(A-H,O-Z) C include 'msxas3.inc' C DIMENSION ZINT(441),ALPHA(441),R(441,UA_) DO 100 I=2,IMAX APLUSR=AP+R(I,M1) AMINSR=DABS(AP-R(I,M1)) CALL MINTERP(APLUSR,ZINT,XVAL1,R(1,M2)) CALL MINTERP(AMINSR,ZINT,XVAL2,R(1,M2)) ALPHA(I)=(XVAL1-XVAL2)/(2.0D0*AP) 100 CONTINUE RETURN END C SUBROUTINE INPOT C IMPLICIT REAL*8 (A-H,O-Z) C INCLUDE 'msxas3.inc' C character*2 potgen character*4 coor character*5 potype character*7 ionzst character*2 edge,charelx character*6 norman integer absorber,hole logical*4 vinput common/options/rsh,ovlpfac,vc0,rs0,vinput,absorber,hole,mode, & ionzst,potype,norman,coor,charelx,edge,potgen C C**** CONT_SUB DIMENSIONING VARIABLES C INTEGER AT_,D_,RD_,SD_ PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) C C**** C COMMON/MPARMS/ RADION,QION,NCUT,NOUT,MOUT,NSAT C COMMON/MTRAD/ RS(NAT_) C DIMENSION XV(NAT_),YV(NAT_),ZV(NAT_),Z(NAT_),NEQ1(NAT_), 1EXFACT(NAT_),NZ(NAT_),NSYMBL(NAT_),NEQ(NAT_),H(NAT_), 2VCONS(2),R(441,UA_),V(441,UA_),ICHG(10,UA_),KPLACE(NAT_), 3KMAX(NAT_),VINT(UA_),CHARGE(UA_,2),ROCON(2),RHO(441,UA_) C 4,VC(441,UA_) C DIMENSION RTEMP(440),VTEMP(441,2),GAMMA(440,2),DENSTEMP(441,2) EQUIVALENCE (VTEMP(1,1),BETA(1)),(ROTEMP(1,1),GAMMA(1,1)) DIMENSION BETA(440),ROTEMP(440,2) C DIMENSION VCTEMP(441) C C CC**** CONT_SUB COMMON BLOCKS C COMMON /DENS/ IRHO2,RHOTOT2(RD_,SD_),RHOINT2(2), $ vcoul(rd_,sd_),vcoulint(2) REAL*4 RHOTOT2,RHOINT2,vcoul,vcoulint C COMMON /FCNR/KXE2, H2(D_),VCONS2(2),R2(RD_,D_),V2(2,RD_,SD_), $ ICHG2(10,D_),KPLACE2(AT_),KMAX2(AT_) REAL*4 H2,R2,V2 COMPLEX VCONS2 C COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, 1 IMVHL,NEDHLP C CHARACTER*8 NAME0 ,NSYMBL2 C REAL*4 EFTR2,GAMMA2,E2,RS2,XV2,YV2,ZV2 REAL*4 EXFACT2,Z2,CIP,EMAX,EMIN,DE COMPLEX VCON2,XE2,EV2 COMMON/PARAM/EFTR2,GAMMA2,VCON2,XE2,EV2,E2,IOUT2,NAT2, 1 NDAT2,NSPINS2,NAS2,RS2(AT_),XV2(AT_),YV2(AT_),ZV2(AT_), 2 EXFACT2(AT_),Z2(AT_),LMAXX2(AT_),NZ2(AT_),NSYMBL2(AT_), 4 NEQ2(AT_),NAME0,CIP,EMAX,EMIN,DE C C ############MODIFIED TO INCLUDE THE TWO CORE STATE WAVE FUNCTIONS c ############FOR THE AUGER CALCULATION c common/pot_type/i_absorber,i_absorber_hole, 1 i_absorber_hole1,i_absorber_hole2, 2 i_norman,i_alpha,i_outer_sphere, 3 i_exc_pot,i_mode C C***** C C CHARACTER*8 NSYMBL C DATA PI/3.14159265358979D0/,THIRD/.333333333333333D0/ C C FORMAT FOR ALL FUNCTIONS OF RADIAL MESH POINTS C FORMAT FOR ERROR MESSAGE IF INPUT CARD IS OUT OF ORDER C 400 FORMAT(' CARD',I5,' OUT OF SEQUENCE') LOGICAL OUTER READ(4) NAT,NDAT,NOUT,EXFAC0,NSPINS C READ(10,8853)RADION,QION,NCUT,MOUT IF(NCUT.EQ.0) NCUT=2 C READ(10,8854)(RS(I),I=1,NAT) IF (NAT.EQ.0) STOP 4602 FAC1=NSPINS IF(NOUT.EQ.0) WRITE(7,110) NAT ROCON(2)=0 ROCON(1)=0 VCON=0.0D0 IN = 0 C C IN=1 SECTION. INPUT DATA FROM MOLECULAR POTENTIAL PROGRAM C IF (IN.GT.1) GO TO 4300 NC0=1 113 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,26H OUTER SPHERE AT CENTE *R 1 ) 110 FORMAT(1H1,30X,18HNUMBER OF CENTERS=,I5,17H NO OUTER SPHERE) IF(NOUT.NE.0) WRITE(7,113)NAT WRITE(7,8852)NCUT,RADION,QION 8852 FORMAT(30X,'NCUT=',I3,' RADION=',F7.3,' QION=', F7.1) VOLUME=0.0D0 DO 422 N=1,NAT OUTER=NOUT.NE.0.AND.N.EQ.1 READ(4) NSYMBL(N),NEQ(N),NZ(N),KMAX(N),XV(N),YV(N), U ZV(N),EXFACT(N),NC IF(NC.EQ.NC0+1) GO TO 423 WRITE(7,400) NC 423 NC0=NC Z(N)=NZ(N) IF(NEQ(N).NE.0) GO TO 439 KMAXN=KMAX(N) KMAXL=KMAXN C C CALCULATE RADIAL MESH FOR INPUT DATA C ZINO=Z(N) IF(NZ(N) .EQ. 0) ZINO=1.D0 HH=.0025D0*.88534138D0/ZINO**THIRD RTEMP(1)=HH KK=1 K0=2 DO 4285 I=1,11 DO 4286 K=K0,40 KK=KK+1 IF(KK.GT.KMAXN) GO TO 1014 4286 RTEMP(KK)=RTEMP(KK-1)+HH K0=1 4285 HH=2.0D0*HH 1014 DO 1020 ISPIN=1,NSPINS C C READ STARTING POTENTIAL C DO 1019 K=1,KMAXN,5 KCARD=MIN0(K+4,KMAXN) READ(4) NC,( VTEMP(I,ISPIN),I=K,KCARD) IF(NC.EQ.NC0+1) GO TO 1019 WRITE(7,400) NC 1019 NC0=NC 1020 CONTINUE C DO 1200 K=1,KMAXN,5 C KCARD=MIN0(K+4,KMAXN) C READ(4,1015) NC,( VCTEMP(I),I=K,KCARD) C IF(NC.EQ.NC0+1) GO TO 1200 C WRITE(7,400) NC C ERROR=.TRUE. C 1200 NC0=NC DO 2720 ISPIN=1,NSPINS C C READ STARTING CH[AARGE DENSITY C DO 2723 K=1,KMAXN,5 KCARD=MIN0(K+4,KMAXN) READ(4) NC,(DENSTEMP(I,ISPIN),I=K,KCARD) IF(NC.EQ.NC0+1) GO TO 2723 WRITE(7,400) NC 2723 NC0=NC 2720 CONTINUE C C CONVERT INPUT DATA TO FORM FOR MOLECULAR CALCULATION C KMIN=1 428 KPL=(KMAXN+KMIN)/2 IF(RTEMP(KPL)-RS(N)) 424,434,426 424 KMIN=KPL IF(KMAXN-KMIN-1) 427,427,428 426 KMAXN=KPL IF(KMAXN-KMIN-1) 427,427,428 427 KPL=KMIN 434 KPL0=KPL N40=40/NCUT KPL=KPL/NCUT IF(RTEMP(KPL*NCUT+NCUT)+RTEMP(KPL*NCUT)-2.D0*RS(N)) 429,430,430 429 KPL=KPL+1 430 IF(OUTER) GO TO 433 KMAX(N)=KPL+3 KMAXN=KMAX(N) NMOD=MOD(KMAXN,N40) IF(NMOD.GE.5.OR.NMOD.EQ.0) GO TO 431 KMAXN=KMAXN-NMOD 431 ICHGN=KMAXN DO 432 K=1,KMAXN KN=NCUT*K R(K,N)=RTEMP(KN) NS=N DO 4320 IS=1,NSPINS V(K,NS)=VTEMP(KN,IS) C VC(K,NS)=VCTEMP(KN) RHO(K,NS)=DENSTEMP(KN,IS) 4320 NS=NS+NDAT 432 CONTINUE IF(KMAXN.EQ.KMAX(N)) GO TO 441 KX1=KMAXN+1 KMAXN=KMAX(N)+1 IF(NCUT.EQ.1) GO TO 435 DO 436 K=KX1,KMAXN KN=(KX1+K-1)*NCUT/2 R(K,N)=RTEMP(KN) NS=N DO 4360 IS=1,NSPINS V(K,NS)=VTEMP(KN,IS) C VC(K,NS)=VCTEMP(KN) RHO(K,NS)=DENSTEMP(KN,IS) 4360 NS=NS+NDAT 436 CONTINUE GO TO 440 435 DO 437 K=KX1,KMAXN KN=(KX1+K-1)/2 IF(2*((K-KX1+1)/2).EQ.(K-KX1+1)) GO TO 438 R(K,N)=.5D0*(RTEMP(KN)+RTEMP(KN+1)) NS=N DO 4310 IS=1,NSPINS CALL DINTERP(RTEMP(KN-3),VTEMP(KN-3 ,IS),7,R(K,N),V(K,NS),DUMMY, 1 .FALSE.) C CALL DINTERP(RTEMP(KN-3),VCTEMP(KN-3 ),7,R(K,N),VC(K,NS),DUMMY, C 1 .FALSE.) CALL DINTERP(RTEMP(KN-3),DENSTEMP(KN-3 ,IS),7,R(K,N), 1 RHO(K,NS),DUMMY,.FALSE.) 4310 NS=NS+NDAT GO TO 437 438 R(K,N)=RTEMP(KN) NS=N DO 4311 IS=1,NSPINS V(K,NS)=VTEMP(KN,IS) C VC(K,NS)=VCTEMP(KN) RHO(K,NS)=DENSTEMP(KN,IS) 4311 NS=NS+NDAT 437 CONTINUE 440 IF( ABS(R(KPL,N)-RS(N)).LE. ABS(R(KPL+1,N)-RS(N))) GO TO 441 KPL=KPL+1 KMAX(N)=KMAX(N)+1 441 KPLACE(N)=KPL ICHG(1,N)=N40 DO 443 K=2,10 ICHG(K,N)=ICHG(K-1,N)+N40 IF(ICHG(K,N).GE.ICHGN) ICHG(K,N)=400/NCUT 443 CONTINUE GO TO 448 C C.....FOR OUTER REGION C 433 KMIN=(KPL-3)*NCUT KMAX(N)=MIN0((440/NCUT-KPL+4),200) ICHG(1,N)=(40-MOD(KMIN,40))/NCUT+1 ICHGN=1 IF(ICHG(1,N).GT.4) GO TO 444 ICHGN=ICHG(1,N)-1 DO 445 K=1,ICHGN KN=KMIN+NCUT*(2*K-ICHG(1,N)-1) R(K,N)=RTEMP(KN) NS=N DO 445 IS=1,NSPINS V(K,NS)=VTEMP(KN,IS) C VC(K,NS)=VCTEMP(KN) RHO(K,NS)=DENSTEMP(KN,IS) 445 NS=NS+NDAT ICHG(1,N)=ICHG(1,N)+N40 ICHGN=ICHGN+1 444 KMAXN=KMAX(N) DO 446 K=ICHGN,KMAXN KN=KMIN+(K-1)*NCUT R(K,N)=RTEMP(KN) NS=N DO 446 IS=1,NSPINS V(K,NS)=VTEMP(KN,IS) C VC(K,NS)=VCTEMP(KN) RHO(K,NS)=DENSTEMP(KN,IS) 446 NS=NS+NDAT DO 447 K=2,10 447 ICHG(K,N)=ICHG(K-1,N)+N40 KPLACE(N)=4 C C.....FOR ATOMIC SPHERES C 448 NQ=N K=KPL0 IF(RTEMP(K+1)+RTEMP(K)-2.D0*RS(N).LT.0.0D0 ) K=KPL0+1 C C READ INTEGRATED POTENTIAL AND INTERPOLATE FOR VALUE ON BOUNDARY C DO 1016 KK=1,KMAXL,5 KCARD=MIN0(KK+4,KMAXL) READ(4) NC,(BETA(I),I=KK,KCARD) IF(NC.EQ.NC0+1) GO TO 1016 WRITE(7,400) NC 1016 NC0=NC CALL DINTERP(RTEMP(K-3), BETA(K-3),7,RS(N), VINT(N),DUMMY,.FALSE.) C C READ TOTAL CHARGE AND INTERPOLATE FOR VALUE ON BOUNDARY C DO 1022 ISPIN=1,NSPINS DO 1021 KK=1,KMAXL,5 KCARD=MIN0(KK+4,KMAXL) READ(4) NC, (GAMMA(I,ISPIN),I=KK,KCARD) IF(NC.EQ.NC0+1) GO TO 1021 WRITE(7,400) NC 1021 NC0=NC 1022 CALL DINTERP(RTEMP(K-3),GAMMA(K-3,ISPIN),7,RS(N),CHARGE(N,ISPIN), 1 DUMMY,.FALSE.) GO TO 4281 C C.....FOR EQUIVALENT ATOMS C 439 NQ=NEQ(N) KPLACE(N)=KPLACE(NQ) 4281 IF(OUTER) GO TO 4280 VOLUME=VOLUME-RS(N)**3 VCON=VCON-VINT(NQ) DO 455 IS=1,NSPINS 455 ROCON(IS)=ROCON(IS)-CHARGE(NQ,IS) IF(NEQ(N).NE.0) GO TO 422 GO TO 4221 4280 VCON=VCON+VINT(NQ) VOLUME=VOLUME+RS(N)**3 DO 456 IS=1,NSPINS 456 ROCON(IS)=ROCON(IS)+CHARGE(NQ,IS) 4221 H(N)=R(2,N)-R(1,N) 422 CONTINUE VOLUME=1.3333333333333D0*PI*VOLUME VCON=VCON/VOLUME VCONC=VCON IF (RADION.NE.0) THEN DVSPH = -2.D0*QION/RADION VCONC = VCONC + DVSPH ENDIF NS=1 RH0 = 3.D0 / (NSPINS*4.D0*PI*RS0**3) c write (*,*) ' vc0 =', vc0, ' rs0 =',rs0 DO 453 IS=1,NSPINS ROCON(IS)=ROCON(IS)/VOLUME VCONS(IS)=VCON-6*EXFAC0*(3*FAC1*ROCON(IS)/(8*PI))**THIRD VC0X = VC0 - 6*EXFAC0*(3*FAC1*RH0/(8*PI))**THIRD IF(RADION.EQ.0) GO TO 453 VCONS(IS)=VCONS(IS)+DVSPH KX=KMAX(1) DO 451 K=1,KX IF(R(K,1).LT.RADION) GO TO 452 V(K,NS)=V(K,NS)-2.D0*QION/R(K,1) C VC(K,NS)=VC(K,NS)-2.*QION/R(K,1) GO TO 451 452 V(K,NS)=V(K,NS)+DVSPH C VC(K,NS)=VC(K,NS)+DVSPH 451 CONTINUE NS=NS+1 DO 454 N=2,NDAT KX=KMAX(N) DO 450 K=1,KX C VC(K,NS)=VC(K,NS)+DVSPH 450 V(K,NS)=V(K,NS)+DVSPH 454 NS=NS+1 453 CONTINUE GO TO 4220 4300 WRITE(7,105) 105 FORMAT(' IN IS EQUAL 2') C C OUTPUT AND CHECK FOR CONSISTENCY OF INPUT DATA C 4220 WRITE(7,111) 111 FORMAT(30X,10HATOM NO.,12X,8HPOSITION,14X,13HRADIUS EQ ) WRITE(7,112) (I,NSYMBL(I),NZ(I),XV(I),YV(I),ZV(I),RS(I),NEQ(I), 1 I=1,NAT) 112 FORMAT(26X,I3,A6,I6,4F10.4,I6) C IF(NOUT.NE.0.AND.NOUT.NE.1) GO TO 205 C GO TO 1130 C 205 WRITE(7,200) I,J C ERROR=.TRUE. DO 211 I=1,NAT IF(RS(I).LT.0.0D0) GO TO 213 IF(NEQ(I).EQ.0)GO TO 210 IF(NEQ(I).GE.I) GO TO 213 210 I1=I+1 IF(NOUT.EQ.0) GO TO 212 IF(NEQ(I).EQ.1) GO TO 213 212 IF(I1.GT.NAT) GO TO 216 GO TO 2135 213 CONTINUE C WRITE(6,200) I,J 2135 DO 211 J=I1,NAT RIJ = SQRT((XV(J)-XV(I))**2+(YV(J)-YV(I))**2+(ZV(J)-ZV(I))**2) IF(NOUT.EQ.1.AND.I.EQ.1) GO TO 214 RSUM = RS(I)+RS(J) IF (RSUM.GT.RIJ) GO TO 215 GO TO 211 214 RSUM = RIJ+RS(J) IF (RSUM.GT.RS(1)) GO TO 215 GO TO 211 215 CONTINUE C WRITE (6,200) I,J,RSUM,RIJ,RDIF 211 CONTINUE 216 IF(RADION.EQ.0.0D0) GO TO 217 IF(RADION.EQ.RS(1)) GO TO 217 KX=KMAX(1) DO 219 K=1,KX IF(RADION.GT.R(K,1)) GO TO 219 219 CONTINUE 217 CONTINUE NDUMMY = 0 C C SHIFT BACK ORIGIN TO PHOTOABSORBER C X0=XV(2) Y0=YV(2) Z0=ZV(2) C DO 150 N=1,NAT XV(N)=XV(N)-X0 YV(N)=YV(N)-Y0 ZV(N)=ZV(N)-Z0 NEQ1(N)=0 IF(NEQ(N).NE.0) NEQ1(N)=NEQ(N)-1 150 CONTINUE C C WRITE OUT POTENTIAL AND DENSITY FILES C IF (potype.EQ.'xalph') THEN OPEN (19, FILE = 'div/XALPHA.POT', STATUS = 'unknown') ELSE OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown') OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown') ENDIF C INV = 20 IF (potype.EQ.'xalph') INV = 19 INRHO= 9 NST=2 NC=2 DO 4401 N=NST,NAT WRITE(INV,311) NSYMBL(N),NEQ1(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N), 1 XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC 311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5) NC=NC+1 IF(NEQ(N).NE.0) GO TO 4401 WRITE(INV,308) (ICHG(I,N),I= 1,10),NC 308 FORMAT(10I5,T76,I5) NC=NC+1 WRITE(INV,319) NC,(R(I,N),I=1,5) 319 FORMAT(T76,I5,T2,1P5E14.7) NS=N NC=NC+1 KX=KMAX(N) NS = N DO 142 ISPIN=1,NSPINS DO 141 K=1,KX,5 KCARD=MIN0(KX,K+4) WRITE(INV,319) NC,(V(I,NS),I=K,KCARD) 141 NC=NC+1 142 NS=NS+NDAT NS=N IF (potype.NE.'xalph') THEN DO 555 ISPIN=1,NSPINS DO 551 K=1,KX,5 KCARD=MIN0(KX,K+4) WRITE(INRHO,319) NC,(RHO(I,NS),I=K,KCARD) 551 NC=NC+1 555 NS=NS+NDAT ENDIF 4401 CONTINUE C IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS) C IF (INV.EQ.20) THEN WRITE(INV,319) NC, VCONC WRITE( INRHO,319) NC,(ROCON(IS),IS=1,NSPINS) ENDIF C c CLOSE (4) IF(potype.EQ.'xalph') THEN CLOSE (UNIT=19) ELSE CLOSE (UNIT=20) CLOSE (UNIT=9) ENDIF C C CLOSE (UNIT=7) C C----------------------------------------------------------------------- C C PASS POTENTIAL AND/OR CHARGE DENSITY TO CONT_SUB. C C990 IF(IOUT_ASCII.NE.2) GO TO 999 C C----------------------------------------------------------------------- NAT2=NAT-NOUT NDAT2=NDAT-NOUT NSPINS2=NSPINS c c A.Kuzmin 10.06.93 c Correction of the atomic coordinates due to the outer c sphere non central position c xv0=0.D0 yv0=0.D0 zv0=0.D0 c if(nout.eq.1)then c xv0=xv(1) c yv0=yv(1) c zv0=zv(1) c endif c c End of correction c DO 780 I=1,NAT2 C C SKIP OUTER SPHERE C J=I+NOUT NSYMBL2(I)=NSYMBL(J) NZ2(I)=NZ(J) IF(NEQ(J).EQ.0)THEN NEQ2(I)=0 ELSE NEQ2(I)=NEQ(J)-NOUT END IF XV2(I)=SNGL(XV(J)-xv0) YV2(I)=SNGL(YV(J)-yv0) ZV2(I)=SNGL(ZV(J)-zv0) Z2(I)=SNGL(Z(J)) RS2(I)=SNGL(RS(J)) EXFACT2(I)=SNGL(EXFACT(J)) KMAX2(I)=KMAX(J) KPLACE2(I)=KPLACE(J) IF(NEQ(J).NE.0)GOTO 780 DO 735 K=1,10 ICHG2(K,I)=ICHG(K,J) 735 CONTINUE H2(I)=SNGL(R(2,J)-R(1,J)) ISDA=I JSDA=J DO 745 IS=1,NSPINS DO 740 K=1,KMAX(J) IF(IS.EQ.1)R2(K,ISDA)=SNGL(R(K,JSDA)) RHOTOT2(K,ISDA)=SNGL(RHO(K,JSDA)) V2(1,K,ISDA)=SNGL(V(K,JSDA)) V2(2,K,ISDA)=0.0 740 CONTINUE ISDA=ISDA+NDAT2 JSDA=JSDA+NDAT 745 CONTINUE 780 CONTINUE C RHKM1 = DBLE(RHOTOT2(KMAX2(1),1))/ 1 (4.D0*PI*DBLE(R2(KMAX2(1),1))**2) RHKM2 = DBLE(RHOTOT2(KMAX2(2),2))/ 1 (4.D0*PI*DBLE(R2(KMAX2(2),2))**2) RHKM = ( RHKM1 + RHKM2 ) / 2.D0 RSKM = (3.D0 / ( 4.D0 * PI * RHKM * NSPINS ) ) ** THIRD VCKM = DBLE((V2(1,KMAX2(1),1)+V2(1,KMAX2(2),2)))/2.D0 WRITE(*,*) ' input value for coulomb interst. potential =', 1 real(vc0) WRITE(*,*) ' and interstitial rs =', real(rs0) WRITE(*,*) ' lower bound for coulomb interst. potential =', 1 real(vckm) WRITE(*,*) ' and for interst. rs =',real(rskm) DO 790 M=1,NSPINS IF (VINPUT) THEN VCONS2(M) = CMPLX(VC0X) RHOINT2(M) = REAL(RH0) ELSE VCONS2(M)=CMPLX(SNGL(VCONS(M))) RHOINT2(M)=SNGL(ROCON(M)) ENDIF 790 CONTINUE C C C BRANCH POINT C RETURN END C SUBROUTINE DINTERP(R,P,N,RS,PS,DPS,DERIV) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL DERIV,NODRIV DIMENSION R(N),P(N) NODRIV=.NOT.DERIV DPS=0.0D0 PS=0.0D0 DO 1 J=1,N TERM=1.0D0 DENOM=1.0D0 DTERM=0.0D0 DO 2 I=1,N IF(I.EQ.J) GO TO 2 DENOM=DENOM*(R(J)-R(I)) TERM=TERM*(RS-R(I)) IF(NODRIV) GO TO 2 DTERM1=1.0D0 DO 3 K=1,N IF(K.EQ.J.OR.K.EQ.I) GO TO 3 DTERM1=DTERM1*(RS-R(K)) 3 CONTINUE DTERM=DTERM+DTERM1 2 CONTINUE IF(NODRIV) GO TO 1 DPS=DPS+DTERM*P(J)/DENOM 1 PS=PS+TERM*P(J)/DENOM RETURN END c----------------------------------------------------------------------- C SUBROUTINE CSBF(X0,Y0,MAX,SBF,DSBF) IMPLICIT REAL*8(A-H,O-Z) REAL*8 XF1 COMPLEX*8 X0,Y0 COMPLEX*16 X,Y,RAT,DSBF1,Z,SBFJ,B,A COMPLEX*16 SBFK,SBF1,SBF2 COMPLEX*16 SBF,DSBF INTEGER MAX,K,JMIN,KMAX DIMENSION SBF(MAX), DSBF(MAX) C C C GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR C FIRST DERIVATIVES WITH RESPECT TO R. X=ARGUMENT= Y*R. C IF Y=0, NO DERIVATIVES ARE CALCULATED. MAX MUST BE AT LEAST 3. C OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS. MSBF - MODI- C FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS; C MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS C C C X=DCMPLX(X0) Y=DCMPLX(Y0) IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 IF(ABS(X).LT.0.50D0 ) GO TO 18 C C BESSEL FUNCTIONS BY DOWNWARD RECURSION C SBF2=(0.0D0,0.0D0) SBF1=1.0D-25*(0.5D0,0.5D0) IF(ABS(X).LT.2.0D0) SBF1=1.0D-38*(0.5D0,0.5D0) JMIN=10+INT(ABS(X)) KMAX=MAX+JMIN-1 K=MAX XF1=2*KMAX+1 DO 10 J=1,KMAX SBFK=XF1*SBF1/X-SBF2 SBF2=SBF1 SBF1=SBFK XF1=XF1-2.0D0 IF (J.LT.JMIN) GO TO 10 SBF(K)=SBFK K=K-1 10 CONTINUE RAT=SIN(X)/(X*SBF(1)) DO 17 K=1,MAX 17 SBF(K)=RAT*SBF(K) DSBF1=-SBF(2) GO TO 26 C C SMALL ARGUMENTS C 18 Z=-(X*X*0.50D0) A=(1.0D0,0.0D0) MMX=MAX IF (MAX.EQ.1.AND.Y.NE.(0.0D0,0.0D0)) MMX=2 DO 30 J=1,MMX SBFJ=A B=A DO 31 I=1,20 B=B*Z/(I*(2*(J+I)-1)) SBFJ=SBFJ+B IF (ABS(B).LE.1.0D-07*ABS(SBFJ)) GO TO 29 31 CONTINUE 29 IF (J.EQ.2) DSBF1=-SBFJ IF (J.LE.MAX) SBF(J)=SBFJ 30 A=A*X/DCMPLX(FLOAT(2*J+1)) C C 26 IF (Y.EQ.(0.0D0,0.0D0)) RETURN DSBF(1)=Y*DSBF1 IF (MAX.EQ.1) RETURN DO 9 I=2,MAX 9 DSBF(I)=Y*(SBF(I-1)- DCMPLX(FLOAT(I))*SBF(I)/X) RETURN 99 WRITE(6,100) MAX 100 FORMAT (' SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8) STOP END C c subroutine cshf2(x0,y0,max,sbf,dsbf) implicit real*8(a-h,o-z) real*8 xf1 complex*8 x0,y0 complex*16 x,y,rat,z,sbfj,b,a complex*16 sbfk,sbf1,sbf2,cplu complex*16 sbf,dsbf integer max,k,jmin,kmax dimension sbf(max), dsbf(max) c c cshf2 - May 1992 c generates spherical hankel functions of type 2 of order 0 - max-1. c max must be at least 3. cshf2 is calculated as csbf - i*csnf, wher c csbf(csnf) are spherical Bessel(Neuman) functions. csbf(csnf) are c calculated using downward(upward) recurrence realations. c ***** This subroutine returns i*cshf2 = csnf + i*csbf and its c derivative if y0 ne. 0. In this case dsbf = i*y0*(cshf")'*** c c cplu = (0.d0,1.d0) c x=dcmplx(x0) y=dcmplx(y0) if (max.lt.1.or.max.gt.2000) go to 99 if(abs(x).lt.0.50D0 ) go to 18 c c bessel functions sbf by downward recursion c sbf2=(0.0D0,0.0D0) sbf1=1.0D-25*(0.5D0,0.5D0) if(abs(x).lt.2.0D0) sbf1=1.0d-38*(0.5D0,0.5D0) jmin=10+int(abs(x)) kmax=max+jmin-1 k=max xf1=2*kmax+1 do 10 j=1,kmax sbfk=xf1*sbf1/x-sbf2 sbf2=sbf1 sbf1=sbfk xf1=xf1-2.0d0 if (j.lt.jmin) go to 10 sbf(k)=sbfk k=k-1 10 continue rat=sin(x)/(x*sbf(1)) do 17 k=1,max 17 sbf(k)=rat*sbf(k) go to 2 c c sbf for small arguments c 18 z=-(x*x*0.50D0) a=(1.0D0,0.0D0) mmx=max if (max.eq.1.and.y.ne.(0.0D0,0.0D0)) mmx=2 do 30 j=1,mmx sbfj=a b=a do 31 i=1,20 b=b*z/(i*(2*(j+i)-1)) sbfj=sbfj+b if (abs(b).le.1.0d-07*abs(sbfj)) go to 29 31 continue 29 if (j.le.max) sbf(j)=sbfj 30 a=a*x/ dcmplx(float(2*j+1)) c c spherical neumann functions snf by upward recursion c damped in dsbf c 2 sbf2=-cos(x)/x sbf1=(sbf2-sin(x))/x dsbf(1)=sbf2 if (max.eq.1) go to 26 dsbf(2)=sbf1 if (max.eq.2) go to 26 xf1=3.0d0 do 22 i=3,max sbfk=xf1*sbf1/x-sbf2 dsbf(i)=sbfk sbf2=sbf1 sbf1=sbfk 22 xf1=xf1+2.0d0 c c hankel functions as sbf + i*snf c do 3 i=1,max 3 sbf(i) = cplu*sbf(i) + dsbf(i) 26 if (y.eq.(0.0D0,0.0D0)) return c c calculate derivative of shf c dsbf(1) = -y*sbf(2) if (max.eq.1) return do 9 i=2,max 9 dsbf(i)=y*(sbf(i-1)- dcmplx(float(i))*sbf(i)/x) return 99 write(6,100) max 100 format (' spherical bessel function routine - max=',i8) stop end c SUBROUTINE DEFINT(F,R,KMAX,ICHG,A,ID) DIMENSION F(KMAX),R(KMAX),ICHG(10) COMPLEX F,A,F0 C DATA S720,S251,S646,S264 /720.,251.,646.,264./ C DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ C H=R(2)-R(1) A0=0.0 K0=0 IF (ID.NE.1) GO TO 11 F0=(0.0,0.0) GO TO 12 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) 12 KX=KMAX N=1 A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* 1 F(K0+4))/S720 A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* 1 F(K0+4))/S720 A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* 1 F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX KICH=K-ICHG(N) IF (KICH.EQ.1) GO TO 30 IF (KICH.EQ.2) GO TO 40 A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 GO TO 50 30 H=H+H A=A+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 GO TO 50 40 N=N+1 A=A+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 50 CONTINUE RETURN END C C C SUBROUTINE defint0(F,DX,KMAX,A,ID) COMPLEX F, A, A0, F0 DIMENSION F(KMAX) C DATA S720,S251,S646,S264 /720.,251.,646.,264./ C DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ C H=DX A0=0.0 K0=0 IF (ID.NE.1) GO TO 11 F0=(0.0,0.0) GO TO 12 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) c 11 F0 = F(1) c K0 = 1 c write(6,*) 'defint', f0 12 KX=KMAX N=1 A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* 1 F(K0+4))/S720 A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* 1 F(K0+4))/S720 A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* 1 F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 50 CONTINUE RETURN C END C C SUBROUTINE defint1(F,DX,KMAX,A,ID) COMPLEX F, A, A0, F0 DIMENSION F(KMAX) C DATA S720,S251,S646,S264 /720.,251.,646.,264./ C DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ C H=DX A0=0.0 K0=0 IF (ID.NE.1) GO TO 11 F0=(0.0,0.0) GO TO 12 c 11 F0=5.0*F(1)-10.0*F(2)+10.0*F(3)-5.0*F(4)+F(5) 11 F0 = F(1) K0 = 1 12 KX=KMAX N=1 A=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19* 1 F(K0+4))/S720 A=A+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S11* 1 F(K0+4))/S720 A=A+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S19* 1 F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX A=A+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 50 CONTINUE RETURN C END C C SUBROUTINE INTEGR(F,R,KMAX,ICHG,A,ID) DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX) C DATA S720,S251,S646,S264 /720.,251.,646.,264./ C DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ C H=R(2)-R(1) A0=0.0 IF (ID.NE.1) GO TO 11 K0=0 F0=0.0 GO TO 12 11 K0=1 A(1)=0.0 F0=F(1) 12 KX=KMAX N=1 A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F 1 (K0+4))/S720 A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S 1 11*F(K0+4))/S720 A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 1 9*F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX KICH=K-ICHG(N) IF (KICH.EQ.1) GO TO 30 IF (KICH.EQ.2) GO TO 40 A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 GO TO 50 30 H=H+H A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 GO TO 50 40 N=N+1 A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 50 CONTINUE IF (MOD(ID,2).NE.0) RETURN DO 150 K=1,KMAX 150 A(K)=A(KMAX)-A(K) RETURN C # END C SUBROUTINE CINTEGR(F,R,KMAX,ICHG,A,ID) COMPLEX F,A,F0 DIMENSION F(KMAX),R(KMAX),ICHG(10),A(KMAX) C DATA S720,S251,S646,S264 /720.,251.,646.,264./ C DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ C H=R(2)-R(1) A0=0.0 IF (ID.NE.1) GO TO 11 K0=0 F0=(0.0,0.0) GO TO 12 11 K0=1 A(1)=(0.0,0.0) F0=F(1) 12 KX=KMAX N=1 A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F 1 (K0+4))/S720 A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S 1 11*F(K0+4))/S720 A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 1 9*F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX KICH=K-ICHG(N) IF (KICH.EQ.1) GO TO 30 IF (KICH.EQ.2) GO TO 40 A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 GO TO 50 30 H=H+H A(K)=A(K-1)+H*( 2.0*F(K)+ 7.0*F(K-1)- 4.0*F(K-2)+ F(K-3))/ 6.0 GO TO 50 40 N=N+1 A(K)=A(K-1)+H*(11.0*F(K)+25.0*F(K-1)-10.0*F(K-2)+4.0*F(K-3))/30.0 50 CONTINUE IF (MOD(ID,2).NE.0) RETURN DO 150 K=1,KMAX 150 A(K)=A(KMAX)-A(K) RETURN C # END C C SUBROUTINE INTEGRCM(F,DX,KMAX,A,ID) COMPLEX F,A,F0 DIMENSION F(KMAX),A(KMAX) C DATA S720,S251,S646,S264 /720.,251.,646.,264./ C DATA S106,S19,S346,S456,S74,S11/106.0,19.0,346.0,456.0,74.0,11.0/ C H=DX A0=0.0 IF (ID.NE.1) GO TO 11 K0=0 F0=(0.0,0.0) GO TO 12 11 K0=1 A(1)=(0.0,0.0) F0=F(1) 12 KX=KMAX A(K0+1)=A0+H*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+S106*F(K0+3)-S19*F 1 (K0+4))/S720 A(K0+2)=A(K0+1)+H*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)-S74*F(K0+3)+S 1 11*F(K0+4))/S720 A(K0+3)=A(K0+2)+H*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+S346*F(K0+3)-S1 1 9*F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX A(K)=A(K-1)+H*( 9.0*F(K)+19.0*F(K-1)- 5.0*F(K-2)+ F(K-3))/24.0 50 CONTINUE IF (MOD(ID,2).NE.0) RETURN DO 150 K=1,KMAX 150 A(K)=A(KMAX)-A(K) RETURN C # END C C SUBROUTINE INTEGRCMDP(F,DX,KMAX,A,ID) COMPLEX*16 F,A,F0 REAL*8 S106,S19,S346,S456,S74,S11,S720,S251,S646,S264,A0 DIMENSION F(KMAX),A(KMAX) C DATA S720,S251,S646,S264 /720.D0,251.D0,646.,264.D0/ C DATA S106,S19,S346,S456,S74,S11 /106.0D0,19.0D0,346.0D0,456.0D0, 1 74.0D0,11.0D0/ C H=DX A0=0.0D0 IF (ID.NE.1) GO TO 11 K0=0 F0=(0.0D0,0.0D0) GO TO 12 11 K0=1 A(1)=(0.0D0,0.0D0) F0=F(1) 12 KX=KMAX A(K0+1)=A0+DBLE(H)*(S251*F0+S646*F(K0+1)-S264*F(K0+2)+ 1 S106*F(K0+3)-S19*F(K0+4))/S720 A(K0+2)=A(K0+1)+DBLE(H)*(-S19*F0+S346*F(K0+1)+S456*F(K0+2)- 1 S74*F(K0+3)+S11*F(K0+4))/S720 A(K0+3)=A(K0+2)+DBLE(H)*(S11*F0-S74*F(K0+1)+S456*F(K0+2)+ 1 S346*F(K0+3)-S19*F(K0+4))/S720 K0=K0+4 DO 50 K=K0,KX A(K)=A(K-1)+DBLE(H)*( 9.0D0*F(K)+19.0D0*F(K-1)-5.0D0*F(K-2)+ 1 F(K-3))/24.0D0 50 CONTINUE IF (MOD(ID,2).NE.0) RETURN DO 150 K=1,KMAX 150 A(K)=A(KMAX)-A(K) RETURN C # END C C SUBROUTINE INTERP(R,P,N,RS,PS,DPS,DERIV) LOGICAL DERIV,NODRIV DIMENSION R(N),P(N) COMPLEX P,PS,DPS NODRIV=.NOT.DERIV DPS=(0.0,0.0) PS=(0.0,0.0) DO 1 J=1,N TERM=1.0 DENOM=1.0 DTERM=0.0 DO 2 I=1,N IF(I.EQ.J) GO TO 2 DENOM=DENOM*(R(J)-R(I)) TERM=TERM*(RS-R(I)) IF(NODRIV) GO TO 2 DTERM1=1.0 DO 3 K=1,N IF(K.EQ.J.OR.K.EQ.I) GO TO 3 DTERM1=DTERM1*(RS-R(K)) 3 CONTINUE DTERM=DTERM+DTERM1 2 CONTINUE IF(NODRIV) GO TO 1 DPS=DPS+DTERM*P(J)/DENOM 1 PS=PS+TERM *P(J)/DENOM RETURN C END C SUBROUTINE INTERPR(R,P,N,RS,PS,DPS,DERIV) LOGICAL DERIV,NODRIV DIMENSION R(N),P(N) NODRIV=.NOT.DERIV DPS=0.0 PS=0.0 DO 1 J=1,N TERM=1.0 DENOM=1.0 DTERM=0.0 DO 2 I=1,N IF(I.EQ.J) GO TO 2 DENOM=DENOM*(R(J)-R(I)) TERM=TERM*(RS-R(I)) IF(NODRIV) GO TO 2 DTERM1=1.0 DO 3 K=1,N IF(K.EQ.J.OR.K.EQ.I) GO TO 3 DTERM1=DTERM1*(RS-R(K)) 3 CONTINUE DTERM=DTERM+DTERM1 2 CONTINUE IF(NODRIV) GO TO 1 DPS=DPS+DTERM*P(J)/DENOM 1 PS=PS+TERM *P(J)/DENOM RETURN C END C C C SUBROUTINE SORT(NINI,VALIN,NFIN,VALFIN) C C Given a set of **real** numbers VALINI, this routine orders them and C suppresses the values appearing more than once. The remaining C values are stored in VALFIN. C C VALINI(K+1).GT.VALINI(K) : decreasing order C VALINI(K+1).LT.VALINI(K) : increasing order C C DIMENSION VALIN(NINI),VALINI(NINI),VALFIN(NINI) C LOGICAL BUBBLE C DATA SMALL /0.00001/ C C.....STORE INPUT ARRAY C DO I=1,NINI VALINI(I)=VALIN(I) ENDDO C DO J=1,NINI-1 K=J BUBBLE=.TRUE. 150 IF(K.GE.1.AND.BUBBLE) THEN IF(VALINI(K+1).LT.VALINI(K)) THEN R1=VALINI(K) VALINI(K)=VALINI(K+1) VALINI(K+1)=R1 ELSE BUBBLE=.FALSE. END IF K=K-1 GOTO 150 ENDIF ENDDO C JFIN=1 VALFIN(1)=VALINI(1) DO J=1,NINI-1 IF(ABS(VALFIN(JFIN)-VALINI(J+1)).GT.SMALL) THEN JFIN=JFIN+1 VALFIN(JFIN)=VALINI(J+1) ENDIF ENDDO NFIN=JFIN C RETURN C END C C SUBROUTINE STARTP(ZZ0,L,E,R,V,KMAX,KI,P) C IMPLICIT COMPLEX*16 (A-B) REAL*4 ZZ0,R REAL*8 XL,Z0,H,RC C COMPLEX*8 V COMPLEX*16 P,Z C DIMENSION R(KMAX),V(KMAX),Z(300),P(KMAX) C 1,ZA(150) C Z0=DBLE(ZZ0) RC = 1.0D0 C IF(L.GT.10) RC = 0.01/R(1) KM=KI/4 IF(KI.EQ.1) KM=1 KI1=KI+2 DO 1 K=1,KI1 1 Z(K)=DCMPLX(R(K)*V(K)) XL=DFLOAT(L) H=DBLE(KM*R(1)) B1=-2.0D0*Z0 B2=(22.D0*Z0+18.D0*Z(KM)-9.D0*Z(2*KM)+2.D0*Z(3*KM))/(6.D0*H)- 1 DBLE(E) B3=(-12.D0*Z0-15.D0*Z(KM)+12.D0*Z(2*KM)-3.D0*Z(3*KM))/(6.D0*H*H) B4=(2.D0*Z0+3.D0*Z(KM)-3.D0*Z(2*KM)+Z(3*KM))/(6.D0*H**3) A1=-Z0/(XL+1.0D0) A2=(B1*A1+B2)/(4.0D0*XL+6.0D0) A3=(B1*A2+B2*A1+B3)/(6.0D0*XL+12.0D0) A4=(B1*A3+B2*A2+B3*A1+B4)/(8.0D0*XL+20.0D0) A5=(B1*A4+B2*A3+B3*A2+B4*A1)/(10.D0*XL+30.D0) A6=(B1*A5+B2*A4+B3*A3+B4*A2)/(12.D0*XL+42.D0) A7=(B1*A6+B2*A5+B3*A4+B4*A3)/(14.D0*XL+56.D0) DO 4 K=1,KI1 4 P(K)=DCMPLX((1.0D0+DBLE(R(K))*(A1+DBLE(R(K))*(A2+DBLE(R(K))* 1 (A3+DBLE(R(K))*(A4+DBLE(R(K))*(A5+DBLE(R(K))* 2 (A6+DBLE(R(K))*A7)))))))*(DBLE(R(K))*RC)**(L+1)) C DO 2 K=1,KI1 C 2 ZA(K)=B1+R(K)*(B2+(R(K)*(B3+R(K)*B4))) C WRITE(6,3) (I,(R(I+J-1),Z(I+J-1),ZA(I+J-1),J=1,2),I=1,KI1,2) RETURN END C subroutine rhl(erl,eim,pi) c c c this is a new hl subroutine, using interpolation for the c real part while calculating the imaginary part is calculated c analitically. c it uses hl to calculate values at the mesh points for the inter c polation of the real part. the imaginary part is calculated c using subroutine imhl. c c written by jose mustre c polynomial in rs has a 3/2 power term. j.m. c implicit double precision (a-h,o-z) common /corr/ rs,blt,xk1,vii,index2 common /hlin/ xk common /cusp/ icusp c c for the right branch the interpolation has the form: c hl(rs,x) = e/x + f/x**2 + g/x**3 c where e is known and c f = sum (i=1,3) ff(i) rs**(i+1)/2 c g = sum (i=1,3) gg(i) rs**(i+1)/2 c c c lrs=number of rs panels, in this case one has 4 panels c nrs=number of standard rs values, also order of rs expansion c if you change nrs you need to change the expansion of hl c in powers of rs that only has 3 terms! c nleft=number of coefficients for xx0 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)r c do 1040 k=1,kx 1040 rid2(k)=rpi(k)*rpi2(k)*(r(k,n)**lk) call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id) do 1050 k=1,kx 1050 rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1)) call defint(rid,r(1,n),kx,ichg(1,n),dx1,id) dxdir=(dx+dx1)*2* * sqrt(xe/pai)/(nfis*nfis1*nfis2*ramf(nstart+np)) end if c c ###### now the exchange integral c lsum3=np+lk+l02i lsum4=l0i+lk+l01i if((lk.lt.lkmin1).or.(lk.gt.lkmax1).or. * (((lsum3/2)*2).ne.lsum3).or.(((lsum4/2)*2).ne.lsum4)) then dxexc=(0.,0.) else do 1060 k=1,kx 1060 rid(k)=r(k,n)*rpi1(k)*p(k,np+1)*(r(k,n)**lk) call cintegr (rid,r(1,n),kx,ichg(1,n),cri,id) do 1070 k=1,kx 1070 rid(k)=rpi(k)*rpi1(k)*cri(k)/(r(k,n)**(lk+1)) call defint(rid,r(1,n),kx,ichg(1,n),dx3,id) c c ####### now the other region where r'>r c do 1788 k=1,kx 1788 rid2(k)=rpi(k)*rpi1(k)*(r(k,n)**lk) call integr(rid2,r(1,n),kx,ichg(1,n),cri2,id) do 1799 k=1,kx 1799 rid(k)=r(k,n)*rpi2(k)*p(k,np+1)*cri2(k)/(r(k,n)**(lk+1)) call defint(rid,r(1,n),kx,ichg(1,n),dx4,id) dxexc=(dx3+dx4)*2* * sqrt(xe/pai)/(nfis1*nfis2*nfis*ramf(nstart+np)) end if c c ############## Write the auger matrix elements c c write(55,8111) 'L =',np,'LB =',lk,dxdir,dxexc c8111 format(2x,a3,i2,4x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5) write(55,8111) 'LB =',lk,dxdir,dxexc 8111 format(12x,a4,3x,i2,8x,f8.5,1x,f8.5,4x,f8.5,1x,f8.5) 2 continue 1 continue c write(55,*) 'nct=',nct end if return end c subroutine radialx_eels(neff) c include 'msxas3.inc' c integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) C c.....this subroutine calculates the radial matrix elements c.....necessary for eels cross-section c.....using a linear-log mesh c common/mtxele/ nstart,nlast c common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), & dxxdir,dxxexc complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, & dxxdir,dxxexc c common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,ev,xe character*8 nsymbl,name0 c common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) complex*16 sbf,dsbf,shf,dshf C COMMON /LLM/ ALPHA, BETA C COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C C COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_) C COMPLEX PX,DPX,PSX,DPSX,RAMFX c COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), & RAMFSOA(N_) COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA c C COMMON/PDQIX/RPIX(RDX_), FNISX COMPLEX RPIX C common /state/ natom(n_),ln(n_),nleq(at_), 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) C c ######### common pottype modified to consider also the Auger calcu c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode c common/auger/calctype,expmode,edge1,edge2 c common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), & ramfsr2(npss,nef_),ramfsr3(npss,nef_), & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,ramfprd,ramfprx, & p3irreg,p2irreg,trop1(rdx_) complex*16 trop(rdx_) real*4 einc,esct,scangl,qt,lambda complex qtc, arg, ydf, scprod c common/msbhf/ il(rdx_,lexp_,d_), kl(rdx_,lexp_,d_), kappa double precision kappa, il, kl c character*3 calctype, expmode, eikappr character*2 edge1,edge2 C common /lparam/lmax2(nat_),l0i c DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_) DIMENSION RID1(RDX_),RID2(RDX_),RID3(RDX_),RID4(RDX_) COMPLEX RID,RID1,RID2,RID3,RID4 COMPLEX VC,VCX,VCD,VCDX,VCDR,VCDXR C CHARACTER*2 RELC C C c*************************************************************************** c note that here rpix(k) = r**3*pi(k). c wf rpix(k) is already normalized c (see subroutine corewf) c*************************************************************************** c pi = 3.1415926 c id = 1 na = nas c c.....calculate direct and exchange Coulomb integral on absorber and different c.....spheres c nt0a=n0(na) ntxa=nt0a+nterms(na)-1 dxa = hx(na) nstart = nt0a nlast = ntxa c write(6,*) 'in radialx_eels', nt0a, ntxa c write(6,*) ' ' write(6,*)' writing eels (e2e) regular direct terms' write(55,100) write(55,821) c do 20 n1 = nt0a, ntxa l=ln(n1) if(l.gt.lmxels(3,na)) goto 20 do k = 1, kmx(na) rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) enddo c do 30 nat2 = 1, neff nb = nat2 if(neq(nat2).ne.0) nb = neq(nat2) nt0b=n0(nb) ntxb=nt0b+nterms(nb)-1 dxb = hx(nb) do 40 n2 = nt0b, ntxb lp = ln(n2) if(lp.gt.lmxels(1,nb)) goto 40 do 50 n3 = nt0b, ntxb ls = ln(n3) if(ls.gt.lmxels(2,nb)) goto 50 do k = 1, kmx(nb) rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 & /(alpha*rx(k,nb) + beta) enddo c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) lc_min=max(abs(l-l0i), abs(lp-ls)) lc_max=min(l+l0i, lp+ls) c if(na.eq.nb) then do lc = lc_min, lc_max, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle call coulss(rid1,rid2,il(1,l1,na), & kl(1,l1,na),kmx(na),dxa,pi,vc) write(55,10) na, l, lp, ls, lc, vc/ramfprd !, vc enddo endif c 50 continue c 40 continue c 30 continue 20 continue c write(55,821) write(55,104) write(55,821) c do 120 n1 = nt0a, ntxa l=ln(n1) if(l.gt.lmxels(3,na)) goto 120 do k = 1, kmx(na) rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) enddo c do 130 nat2 = 1, neff nb = nat2 if(neq(nat2).ne.0) nb = neq(nat2) nt0b=n0(nb) ntxb=nt0b+nterms(nb)-1 dxb = hx(nb) do 140 n2 = nt0b, ntxb lp = ln(n2) if(lp.gt.lmxels(1,nb)) goto 140 do 150 n3 = nt0b, ntxb ls = ln(n3) if(ls.gt.lmxels(2,nb)) goto 150 do k = 1, kmx(nb) rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 & /(alpha*rx(k,nb) + beta) enddo c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) lc_min=max(abs(l-l0i), abs(lp-ls)) lc_max=min(l+l0i, lp+ls) c if(na.ne.nb) then do lc=abs(l-l0i), l+l0i, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle do lcp=abs(lp-ls), lp+ls, 2 l1p = lcp + 1 if(l1p.gt.lexp_) cycle call coulds(rid1,rid2,dxa,dxb,il(1,l1,na), & il(1,l1p,nb),kmx(na),kmx(nb),pi,vcd) vcdr = vcd/ramfprd if(abs(vcdr).lt.1.e-9) cycle write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr enddo enddo endif c 150 continue c 140 continue c 130 continue 120 continue c write(6,*)' writing eels (e2e) regular exchange terms' write(55,821) write(55,102) write(55,821) c do 21 n1 = nt0a, ntxa l=ln(n1) if(l.gt.lmxels(2,na)) goto 21 do k = 1, kmx(na) rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) enddo c do 31 nat2 = 1, neff nb = nat2 if(neq(nat2).ne.0) nb = neq(nat2) nt0b=n0(nb) ntxb=nt0b+nterms(nb)-1 dxb = hx(nb) do 41 n2 = nt0b, ntxb lp = ln(n2) if(lp.gt.lmxels(1,nb)) goto 41 do 51 n3 = nt0b, ntxb ls = ln(n3) if(ls.gt.lmxels(3,nb)) goto 51 do k = 1, kmx(nb) rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 & /(alpha*rx(k,nb) + beta) enddo c ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na) lc_min=max(abs(l-l0i), abs(lp-ls)) lc_max=min(l+l0i, lp+ls) c if(na.eq.nb) then do lc = lc_min, lc_max, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle call coulss(rid3,rid4,il(1,l1,na), & kl(1,l1,na),kmx(na),dxa,pi,vcx) write(55,10) na, l, lp, ls, lc, vcx/ramfprx enddo endif c 51 continue c 41 continue c 31 continue 21 continue c write(55,821) write(55,106) write(55,821) C do 121 n1 = nt0a, ntxa l=ln(n1) if(l.gt.lmxels(2,na)) goto 121 do k = 1, kmx(na) rid3(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) enddo c do 131 nat2 = 1, neff nb = nat2 if(neq(nat2).ne.0) nb = neq(nat2) nt0b=n0(nb) ntxb=nt0b+nterms(nb)-1 dxb = hx(nb) do 141 n2 = nt0b, ntxb lp = ln(n2) if(lp.gt.lmxels(1,nb)) goto 141 do 151 n3 = nt0b, ntxb ls = ln(n3) if(ls.gt.lmxels(3,nb)) goto 151 do k = 1, kmx(nb) rid4(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 & /(alpha*rx(k,nb) + beta) enddo c ramfprx = ramfsr3(ls+1,nb)*ramfsr1(lp+1,nb)*ramfsr2(l+1,na) lc_min=max(abs(l-l0i), abs(lp-ls)) lc_max=min(l+l0i, lp+ls) c if(na.ne.nb) then do lc=abs(l-l0i), l+l0i, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle do lcp=abs(lp-ls), lp+ls, 2 l1p = lcp + 1 if(l1p.gt.lexp_) cycle call coulds(rid3,rid4,dxa,dxb,il(1,l1,na), & il(1,l1p,nb),kmx(na),kmx(nb),pi,vcdx) vcdxr = vcdx/ramfprx if(abs(vcdxr).lt.1.e-9) cycle write(55,11) na, nb, l, lp, ls, lc, lcp, vcdxr enddo enddo endif c 151 continue c 141 continue c 131 continue 121 continue c 10 format(5i5,4e15.7) 11 format(7i5,4e15.7) c c write(6,*) alpha, beta c if(calctype.eq.'els') then write(6,*) ' ' write(6,*)' writing eels irregular direct terms' write(55,821) write(55,101) write(55,821) c do 22 n1 = nt0a, ntxa l=ln(n1) if(l.gt.lmxels(3,na)) goto 22 do k = 1, kmx(na) rid1(k) = rpix(k)*p3(k,l+1,na)/(alpha*rx(k,na) + beta) if(l.le.5) then rid(k) = rpix(k)*p3irreg(k,l+1)/(alpha*rx(k,na) + beta) else rid(k) = (0.0,0.0) endif enddo c do 32 nat2 = 1, neff nb = nat2 if(neq(nat2).ne.0) nb = neq(nat2) nt0b=n0(nb) ntxb=nt0b+nterms(nb)-1 dxb = hx(nb) do 42 n2 = nt0b, ntxb lp = ln(n2) if(lp.gt.lmxels(1,nb)) goto 42 do 52 n3 = nt0b, ntxb ls = ln(n3) if(ls.gt.lmxels(2,nb)) goto 52 c do k = 1, kmx(nb) rid2(k) = p1(k,lp+1,nb)*p2(k,ls+1,nb)*rx(k,nb)**3 & /(alpha*rx(k,nb) + beta) & /ramfsr1(lp+1,nb)/ramfsr2(ls+1,nb) enddo c c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) c lc_min=max(abs(l-l0i), abs(lp-ls)) lc_max=min(l+l0i, lp+ls) c if(na.eq.nb) then do lc = lc_min, lc_max, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle call sstrop(rid2,il(1,l1,na), & kl(1,l1,na),kmx(na),dxa,pi,trop) do k = 1, kmx(na) rid4(k) = rid1(k)*trop(k) rid3(k) = rid(k)*trop(k) enddo call irregint1(rid3,rid4,kmx(na),dxa,vc) if(abs(vc/ramfsr3(l+1,na)).lt.1.e-10) cycle write(55,10) na, l, lp, ls, lc, vc/ramfsr3(l+1,na) enddo else do lc=abs(l-l0i), l+l0i, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle do lcp=abs(lp-ls), lp+ls, 2 l1p = lcp + 1 if(l1p.gt.lexp_) cycle call dstrop(rid2,dx2,il(1,l1,na), & il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1) do k = 1, kmx(na) rid4(k) = rid1(k)*trop1(k) rid3(k) = rid(k)*trop1(k) enddo call irregint1(rid3,rid4,kmx(na),dxa,vcd) vcdr = vcd/ramfsr3(l+1,na) if(abs(vcdr).lt.1.e-10) cycle write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr enddo enddo endif c 52 continue c 42 continue c 32 continue 22 continue c c write(6,*)' writing eels irregular exchange terms' write(55,821) write(55,103) write(55,821) c do 23 n1 = nt0a, ntxa l=ln(n1) if(l.gt.lmxels(2,na)) goto 23 do k = 1, kmx(na) rid1(k) = rpix(k)*p2(k,l+1,na)/(alpha*rx(k,na) + beta) if(l.le.5) then rid(k) = rpix(k)*p2irreg(k,l+1)/(alpha*rx(k,na) + beta) else rid(k) = (0.0,0.0) endif enddo c do 33 nat2 = 1, neff nb = nat2 if(neq(nat2).ne.0) nb = neq(nat2) nt0b=n0(nb) ntxb=nt0b+nterms(nb)-1 dxb = hx(nb) do 43 n2 = nt0b, ntxb lp = ln(n2) if(lp.gt.lmxels(1,nb)) goto 43 do 53 n3 = nt0b, ntxb ls = ln(n3) if(ls.gt.lmxels(3,nb)) goto 53 c do k = 1, kmx(nb) rid2(k) = p1(k,lp+1,nb)*p3(k,ls+1,nb)*rx(k,nb)**3 & /(alpha*rx(k,nb) + beta) & /ramfsr1(lp+1,nb)/ramfsr3(ls+1,nb) enddo c c ramfprd = ramfsr3(l+1,na)*ramfsr1(lp+1,nb)*ramfsr2(ls+1,nb) c lc_min=max(abs(l-l0i), abs(lp-ls)) lc_max=min(l+l0i, lp+ls) c if(na.eq.nb) then do lc = lc_min, lc_max, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle call sstrop(rid2,il(1,l1,na), & kl(1,l1,na),kmx(na),dxa,pi,trop) do k = 1, kmx(na) rid4(k) = rid1(k)*trop(k) rid3(k) = rid(k)*trop(k) enddo call irregint1(rid3,rid4,kmx(na),dxa,vc) if(abs(vc/ramfsr2(l+1,na)).lt.1.e-10) cycle write(55,10) na, l, lp, ls, lc, vc/ramfsr2(l+1,na) enddo else do lc=abs(l-l0i), l+l0i, 2 l1 = lc + 1 if(l1.gt.lexp_) cycle do lcp=abs(lp-ls), lp+ls, 2 l1p = lcp + 1 if(l1p.gt.lexp_) cycle call dstrop(rid2,dx2,il(1,l1,na), & il(1,l1p,nb),kmx(na),kmx(nb),pi,trop1) do k = 1, kmx(na) rid4(k) = rid1(k)*trop1(k) rid3(k) = rid(k)*trop1(k) enddo call irregint1(rid3,rid4,kmx(na),dxa,vcd) vcdr = vcd/ramfsr2(l+1,na) if(abs(vcdr).lt.1.e-10) cycle write(55,11) na, nb, l, lp, ls, lc, lcp, vcdr enddo enddo endif c 53 continue c 43 continue c 33 continue 23 continue c endif !end of if clause to write irregular terms in case of calctype = els c write(55,821) c 100 format(10x,'single site regular direct terms:') 101 format(10x,'irregular direct terms:') 102 format(10x,'single site regular exchange terms:') 103 format(10x,'irregular exchange terms') 104 format(10x,'two-site regular direct terms:') 106 format(10x,'two-site regular exchange terms:') 821 FORMAT(138('-')) c return end c c subroutine coulss(rho1,rho2,il,kl,kmx,dx,pi,vc) c include 'msxas3.inc' c dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx) dimension rid(rdx_), a(rdx_), p(rdx_) complex rho1, rho2, vc, vc1, vc2 complex*16 rid, a, p real*8 il, kl c id = 1 do k = 1, kmx rid(k) = il(k)*dcmplx(rho2(k)) enddo call integrcmdp(rid,dx,kmx,a,id) do k = 1, kmx rid(k) = kl(k)*dcmplx(rho2(k)) enddo call integrcmdp(rid,dx,kmx,p,id) c do k = 1, kmx rid(k) = (p(kmx)-p(k))*il(k)*dcmplx(rho1(k)) enddo call integrcmdp(rid,dx,kmx,p,id) c vc1 = cmplx(p(kmx)) c write(6,*) 'vc1 = ',vc1 do k = 1, kmx rid(k) = a(k)*kl(k)*dcmplx(rho1(k)) enddo call integrcmdp(rid,dx,kmx,p,id) c vc2 = cmplx(p(kmx)) c write(6,*) 'vc2 = ',vc2 vc = (vc1 + vc2)*8.0*pi c return end c c subroutine coulds(rho1,rho2,dx1,dx2,ila,ilb, & kmx1,kmx2,pi,vc) c include 'msxas3.inc' c dimension rho1(kmx1), rho2(kmx2), ila(kmx1), ilb(kmx2) dimension a1(rdx_), a2(rdx_), rid(rdx_) complex rho1, rho2, a1, a2, rid, vc1, vc2, vc real*8 ila, ilb c id = 1 do k = 1, kmx1 rid(k) = rho1(k)*real(ila(k)) enddo call integrcm(rid,dx1,kmx1,a1,id) c call interp(r1(kpl1-3),a1(kpl1-3),7,rs1,vc1,dummy,.false.) vc1 = a1(kmx1) c id = 1 do k = 1, kmx2 rid(k) = rho2(k)*real(ilb(k)) enddo call integrcm(rid,dx2,kmx2,a2,id) c call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.) vc2 = a2(kmx2) c vc = vc1*vc2*8.0*pi return end c c subroutine sstrop(rho2,il,kl,kmx,dx,pi,trop) c include 'msxas3.inc' c dimension rho2(kmx), il(kmx), kl(kmx), trop(kmx) dimension rid(rdx_), a(rdx_), p(rdx_) complex rho2 complex*16 rid, a, p, trop real*8 il, kl c id = 1 do k = 1, kmx rid(k) = il(k)*dcmplx(rho2(k)) enddo call integrcmdp(rid,dx,kmx,a,id) do k = 1, kmx rid(k) = kl(k)*dcmplx(rho2(k)) enddo call integrcmdp(rid,dx,kmx,p,id) c do k = 1, kmx rid(k) = (p(kmx)-p(k))*il(k) enddo c do k = 1, kmx trop(k) = (rid(k) + a(k)*kl(k))*8.0*pi enddo c c return end c c subroutine dstrop(rho2,dx2,ila,ilb,kmx1,kmx2,pi,rid) c include 'msxas3.inc' c dimension rho2(kmx2), ila(kmx1), ilb(kmx2) dimension a2(rdx_), rid(rdx_) complex rho2, a2, rid real*8 ila, ilb c id = 1 do k = 1, kmx2 rid(k) = rho2(k)*real(ilb(k)) enddo call integrcm(rid,dx2,kmx2,a2,id) c call interp(r2(kpl2-3),a2(kpl2-3),7,rs2,vc2,dummy,.false.) do k = 1, kmx1 rid(k) = ila(k)*a2(kmx2)*8.0*pi enddo c return end c c subroutine irregint(rho1,rho2,rl,hl,kmx,dx,vc) c include 'msxas3.inc' c dimension rho1(kmx), rho2(kmx), il(kmx), kl(kmx) dimension rid(rdx_), a(rdx_), p(rdx_) complex rho1, rho2, vc, vc1, vc2 complex rid, a, p, rl, hl c id = 1 do k = 1, kmx rid(k) = rl(k)*dcmplx(rho2(k)) enddo call integrcm(rid,dx,kmx,a,id) do k = 1, kmx rid(k) = hl(k)*dcmplx(rho2(k)) enddo call integrcm(rid,dx,kmx,p,id) c do k = 1, kmx rid(k) = (p(kmx)-p(k))*rl(k)*dcmplx(rho1(k)) enddo call integrcm(rid,dx,kmx,p,id) c vc1 = cmplx(p(kmx)) c write(6,*) 'vc1 = ',vc1 do k = 1, kmx rid(k) = a(k)*hl(k)*dcmplx(rho1(k)) enddo call integrcm(rid,dx,kmx,p,id) c vc2 = cmplx(p(kmx)) c write(6,*) 'vc2 = ',vc2 vc = (vc1 + vc2) c return end c c subroutine irregint1(rho1,rho2,kmx,dx,vc) c include 'msxas3.inc' c dimension rho1(kmx), rho2(kmx) dimension rid(rdx_), a(rdx_), p(rdx_) complex rho1, rho2, vc, vc1, vc2 complex rid, a, p c id = 1 do k = 1, kmx rid(k) = dcmplx(rho2(k)) enddo call integrcm(rid,dx,kmx,a,id) do k = 1, kmx rid(k) = dcmplx(rho1(k)) enddo call integrcm(rid,dx,kmx,p,id) c do k = 1, kmx rid(k) = (p(kmx)-p(k))*dcmplx(rho2(k)) enddo call integrcm(rid,dx,kmx,p,id) c vc1 = cmplx(p(kmx)) c write(6,*) 'vc1 = ',vc1 do k = 1, kmx rid(k) = a(k)*dcmplx(rho1(k)) enddo call integrcm(rid,dx,kmx,p,id) c vc2 = cmplx(p(kmx)) c vc = (vc1 + vc2) c return end c c subroutine setup c c include 'mscalc.inc' include 'msxas3.inc' integer at_,ltot_ parameter ( at_=nat_-1,ltot_=lmax_+1,n_=ltot_*ua_) c common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, 1 imvhl,nedhlp c common/funit/idat,iwr,iphas,iedl0,iwf c character*8 name0, name0i, nsymbl c common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,xe,ev c common /state/ natom(n_),ln(n_),nleq(at_), 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode common/auger/calctype,expmode,edge1,edge2 character*3 calctype, expmode character*2 edge1,edge2 common/lparam/lmax2(nat_),l0i c c ########## I introduce a common/l2holes to take into account the c ########## the orbital momentum of the two electrons which interac c ########## and give rise to the Auger decay; the two orbital momen c ########## are necessary in subroutine radial to do the loop over c ########## the interaction momentum c common/l2holes/l01i,l02i integer l01i,l02i c character*8 core_basis_name(25) integer core_basis_l(25) character*8 exc_basis_name integer exc_basis_l(lmax_+1),exc_basis_dim integer exc_basis_ndg c data core_basis_name/'1s1/2','2s1/2','2p1/2','2p3/2', 1'3s1/2','3p1/2','3p3/2','3d3/2','3d5/2','4s1/2','4p1/2', 2 '4p3/2','4d3/2','4d5/2','4f5/2','4f7/2','5s1/2','5p1/2', 3 '5p3/2','5d3/2','5d5/2','5f5/2','5f7/2','5g7/2','5g9/2'/ c data core_basis_l/0,0,1,1,0,1,1,2,2,0,1,1,2,2,3,3,0, 1 1,1,2,2,3,3,4,4/ c data exc_basis_name/'no sym'/ data lmaximum/lmax_/ data exc_basis_ndg/1/ c do 7001 i=1,lmaximum+1 exc_basis_l(i)=i-1 7001 continue exc_basis_dim=0 do 7002 i=1,ndat exc_basis_dim=exc_basis_dim+lmax2(i)+1 7002 continue c do 59 n=1,nat lmaxx(n)=0 n0(n)=0 n0l(n)=0 lmaxn(n)=0 nterms(n)=0 59 nls(n)=0 nuatom=0 write (6,327)iosym 327 format(1x,' symmetry information generated internally'/, x 1x,' symmetry information written to file',i3) c name0i=core_basis_name(i_absorber_hole) write(iwr,120) name0i write(iosym,120) name0i 120 format(1x,//,' core initial state of type: ',a5) c ndim=exc_basis_dim ndg=exc_basis_ndg name0=exc_basis_name c write (iosym,103) ndim,ndg,name0 103 format(' # basis function including o.s. =',i4,' degeneracy=', 1 i3,5x,a6) i_l=1 i_atom=1 l0i = core_basis_l(i_absorber_hole) c c ############## Modified to consider also the Auger part c if (calctype.eq.'aed') then l01i = core_basis_l(i_absorber_hole1) l02i = core_basis_l(i_absorber_hole2) end if c c do 125 n=1,ndim ln(n)=exc_basis_l(i_l) write (iosym,104) n, ln(n) 104 format ( 1x,'basis function no.',i5,' l=',i3) natom(n)=i_atom i_l=i_l+1 if(i_l.gt.(lmax2(i_atom)+1))then i_l=1 i_atom=i_atom+1 endif c write(iosym,106) natom(n) 106 format (30x, ' atom no.=',i3) c na=natom(n) lmaxn(na)=max0(lmaxn(na),ln(n)) nuatom=max0(nuatom,na) nterms(na)=nterms(na)+1 nls(na)=nls(na)+1 125 continue ctn write(6,1099) ndim write(iosym,112) nuatom, name0 112 format(' number of inequivalent atoms =',i4, * ' for representation:',a6) if (nuatom.ne.ndat) then write(6,122) nuatom, ndat stop endif 122 format(//,' fatal error: nuatom not equal ndat',2i5,//) c n0(1)=1 n0l(1)=1 lmaxx(1)=max0(lmaxx(1),lmaxn(1)) if(nuatom.eq.1) go to 127 do 124 na=2,nuatom n0(na)=n0(na-1)+nterms(na-1) n0l(na)=n0l(na-1)+nls(na-1) 124 lmaxx(na)=max0(lmaxn(na),lmaxx(na)) c branch point 127 continue return c end c c subroutine smtx(ne,lmax_mode) c c include 'mscalc.inc' include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) complex*16 sbf,dsbf,shf,dshf complex*16 sbfrs(ltot_),dsbfrs(ltot_) c common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), $ ichg(10,d_),kplace(at_),kmax(at_) complex vcons,v c common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, 1 imvhl,nedhlp c common /pdq/ p(rd_,f_),ps(n_),dps(n_),ramf(n_),pss(6),dpss(6) complex p,ps,dps,ramf,pss,dpss c character*8 name0 ,nsymbl c common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,ev,xe c common /seculr/ atm(n_) complex*16 atm,stmat c common /state/ natom(n_),ln(n_),nleq(at_), 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) c common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), $ dxdir,dxexc,nfis,nfis1,nfis2 real nfis,nfis2,nfis1 complex dmx,dmx1,qmx,qmx1,dxdir,dxexc c complex csqrt,arg,ramf0 c common/auger/calctype,expmode,edge1,edge2 character*3 calctype, expmode character*2 edge1,edge2 c xe= csqrt(ev) ns=(nns-1)*ndat c do 5 j=1,ndim 5 atm(j)=(0.0D0,0.0D0) c c calculate t-matrix elements: c stmat: inverse t-m elements (atomic spheres) c ramf: for normalization of ps(k) functions c do 60 na=1,nuatom WRITE(95,77) NA ns=ns+1 mout=1 nt0a=n0(na) ntxa=nt0a+nterms(na)-1 if (na.eq.nas) then nstart=nt0a nlast=ntxa endif l=-1 nlat=-1 arg=xe*rs(na) ml=lmaxn(na)+1 call csbf(arg,xe,ml,sbf,dsbf) call cshf2(arg,xe,ml,shf,dshf) npabs=0 do 45 nn=nt0a,ntxa l=ln(nn) nlat=nlat+1 npabs=npabs+1 if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45 call tmat(l,rs(na),kmax(na),z(na),h(na),r(1,na),v(1,ns), 1 ichg(1,na),mout,kplace(na),p(1,npabs),stmat,ps(nn), 2 dps(nn),ramf0) c atm(nn)=stmat ramf(nn)=ramf0 IF(LMAX_MODE.EQ.0) THEN write(95,1001)xe/0.52917715,stmat ELSE write(95,1002)xe/0.52917715,stmat ENDIF c C definition of stmat as exp(-i*delta)*sin(delta) c fasi=sign(-1.,real(cmplx(stmat)))* 1 real(asin(sqrt(abs(dimag(stmat))))) if(fasi.lt.0.0) fasi=fasi+3.1415926 write(30,1000)e,xe,na,nlat,stmat,fasi c write(30)e,xe,na,nlat,stmat c write(*,*)e,xe,na,nlat,stmat 1000 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3,2x,2e16.6,f10.5) 1001 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6) 1002 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9) 45 continue 60 continue C 77 FORMAT('-------------------------- ATOM ',I3, 1 ' -----------------------') c c calculate singular solution inside muffin tin sphere for the absorbing c atom, matching to sbf in interstitial region c nl=0 lmsing=5 mout=4 kp=kplace(nas) kpx=kmax(nas) do 92 k=kp-3,kpx if(r(k,nas)-rs(nas)) 92,93,93 92 continue c c define points (first) kp1 and kp2 outside the absorbing sphere c and use them to start computation of singular solution (s_l) c 93 kp1=k+1 kpl=kp1-3 nst=n0(nas) nlst=n0(nas)+nterms(nas)-1 l=-1 ml=lmaxn(nas)+1 arg=xe*r(kp1,nas) call cshf2(arg,xe,ml,sbf,dsbf) arg=xe*r(kp1-1,nas) call cshf2(arg,xe,ml,shf,dshf) arg=xe*rs(nas) call cshf2(arg,xe,ml,sbfrs,dsbfrs) do 95 n=nst,nlst l=ln(n) c c skip high and divergent l-values of c singular solution h_l c if(l.gt.lmsing)go to 95 nl=nl+1 np=npss+nl np1=nl c call tmat(l,rs(nas),kp1,z(nas),h(nas),r(1,nas),v(1,nas), $ichg(1,nas),mout,kpl,p(1,np),stmat,pss(np1),dpss(np1),ramf0) c c shfp = shf(l+1)*xepi c dshfp = dshf(l+1)*xepi c print *, ps(np),dps(np),shfp,dshfp c do 96 k=1,kpx c if(k.lt.kp2)then c p(k,np)=p(k,np)*(sbfrs(l+1)/pss(np1))*xepi !rescale h_l c else ! to match h_l at rs c p(k,np)=(0.,0.) c end if c 96 continue 95 continue c return end c subroutine tmat(l,rs,kmax,z,delh,r,v,ichg,mout,kplace,p,stmat, 1 ps,dps,ramf) c c include 'mscalc.inc' include 'msxas3.inc' integer ltot_, rd_ parameter (ltot_=lmax_+1, rd_=440) c c c c t-matrix calculation - integrates radial schrodinger equation c using numerov procedure - does outward and inward integration c for atomic spheres - gives inverse of t-matrix and log deriva- c tive at sphere surface. c c modified for complex potentials c c calculates : c c mout=4 solution matching to (0.,1.)*hf2 at r=rs c c c mout=1 atomic spheres t-matrix elements c returns: c stmat=[sbfc,ps]/[shfc,ps] (@rs atomic sphere c ramf=[sbfc,ps]*xe*rs**2 (@rc atomic sphere c c c common/bessel/sbfc(ltot_),dsbfc(ltot_),shfc(ltot_), 1 dshfc(ltot_) complex*16 sbfc,shfc,dsbfc,dshfc c common/param/eftr,gamma,vcon,xe,ev,e,iout complex vcon,xe,ev c c dimension v(kmax),p(kmax),r(kmax),ichg(10) complex v,p,ps,dps,ramf complex*16 stmat,x,ramff complex*16 pk,pk1,pkm,dkm,dk1,dk,gk,gk1,gkm complex*16 pn(rd_) data pi/3.141592653589793d0/ c c c kstop=1 a=l*(l+1) if(mout.eq.4) go to 60 c c outward integration for atomic spheres c ki=1 if(l.ge.5) ki=ichg(1) call startp(z,l,e,r,v,kmax,ki,pn) h=r(ki+1)-r(ki) hsq=h**2 pkm=pn(ki) pk1=pn(ki+1) dkm=-dcmplx((e-v(ki)-a/r(ki)**2)*hsq)*pn(ki)/12.d0 dk1=-dcmplx((e-v(ki+1)-a/r(ki+1)**2)*hsq)*pn(ki+1)/12.d0 kis=ki+2 n=1 if(ki.eq.ichg(1)) n=2 do 34 k=kis,kmax gk=dcmplx((e-v(k)-a/r(k)**2)*hsq)/12.d0 pk=dcmplx((2.d0*(pk1+5.d0*dk1)-(pkm-dkm))/(1.d0+gk)) pn(k)=pk if(k.lt.ichg(n)) go to 30 n=n+1 hsq=4.*hsq dkm=4.d0*dkm dk1=-4.d0*gk*pk pk1=pk go to 34 30 pkm=pk1 dkm=dk1 dk1=-gk*pk pk1=pk 34 continue c go to 78 c c inward integration to find solution matching to (0.,1.)*hf2 at r=rs c 60 n=11 61 n=n-1 if(n.eq.0) go to 66 kn=ichg(n) if(kn.ge.kmax) go to 61 c 66 kn=kmax pkm=sbfc(l+1)*dcmplx(xe/pi*r(kn)) pk1=shfc(l+1)*dcmplx(xe/pi*r(kn-1)) hsq=delh**2*4**n pn(kn)=pkm pn(kn-1)=pk1 dkm=-dcmplx((e-a/r(kn)**2-vcon))*pkm*dble(hsq)/12.d0 dk1=-dcmplx((e-a/r(kn-1)**2-vcon))*pk1*dble(hsq)/12.d0 k=kn+1 if(k.gt.kmax) go to 79 do 76 i=k,kmax 76 pn(i)=(0.0d0,0.0d0) 79 k=kn-1 73 k=k-1 74 gk=dcmplx((e-v(k)-a/r(k)**2))*dble(hsq)/12.d0 pk=dcmplx((2.d0*(pk1+5.d0*dk1)-pkm+dkm)/(1.d0+gk)) pn(k)=pk if(k.eq.kstop) go to 78 if(n.eq.0) go to 69 if(k.gt.ichg(n)) go to 69 if(k.le.2) go to 75 n=n-1 dk=-pk*gk gk1=dcmplx((e-v(k-2)-a/r(k-2)**2))*dble(hsq)/12.d0 pk1=dcmplx((2.d0*(pk+5.d0*dk)-pk1+dk1)/(1.d0+gk1)) dk1=-pk1*gk1/4.d0 hsq=hsq/4. gkm=dcmplx((e-v(k-1)-a/r(k-1)**2))*dble(hsq)/12.d0 dk=dk/4.d0 pkm=0.5d0*((pk-dk)+(pk1-dk1))/(1.d0-5.d0*gkm) dkm=-pkm*gkm k=k-3 c c keller modification subroutine tmat c pn(k+2)=pkm if(k+1.lt.kstop) go to 78 pn(k+1) = pk1 if(k+1.eq.kstop) go to 78 go to 74 69 pkm=pk1 dkm=dk1 dk1=-pk*gk pk1=pk go to 73 75 write(6,103) stop 103 format(//,18h error stop - tmat,//) c c 78 continue do 77 k=1,kmax 77 p(k)=cmplx(pn(k)/dble(r(k))) call interp(r(kplace-3),p(kplace-3),7,rs,ps,dps,.true.) if(mout.eq.4) return x=dcmplx(dps/ps) ramff=sbfc(l+1)*x-dsbfc(l+1) stmat=ramff/(shfc(l+1)*x-dshfc(l+1)) ramf=cmplx(ramff)*ps*rs*rs*xe return c end c c subroutine eikonal(nuatom,xe,z,rs,db) c include 'msxas3.inc' c integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c dimension z(at_), rs(at_) c common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), $ ichg(10,d_),kplace(at_),kmax(at_) complex vcons,v c complex xe c open(unit=45, file='tl/tbmat.dat',status='unknown') c write(45,*) 'impinging electron wave vector kappa =', real(xe) write(35,*) 'impinging electron wave vector kappa =', real(xe) write(6,*) ' impinging electron wave vector kappa =', real(xe) c do na=1,nuatom write(45,*)'atom number ', na,'(z =', z(na),')' write(35,*)'atom number ', na,'(z =', z(na),')' c write(6,*)' atom number ', na,'(z =', z(na),')' z0 = z(na) call tbmat(db,rs(na),kplace(na),z0,r(1,na),v(1,na),real(xe)) enddo c close(45) c c write(6,*) ' normal exit in subroutine eikonal ' c stop c return end c c subroutine tbmat(db,rs,kmax,z0,r,v,xer) c integer rd_ parameter (rd_=440, nt_=1500) c dimension v(kmax),r(kmax), z(rd_) complex v, z c dimension x(nt_), rx(nt_), rid(nt_), rid1(nt_) c complex cu, tb, zb, z1, zx, dzx, d2zx, rid, rid1, dbf, dbs c data pi/3.1415926/ c do i = 1, kmax z(i) = r(i)*v(i) c write(45,*) r(i), z(i) enddo c id = 1 !for subroutine defint idr = 0 !for subroutine defint cu = (0.0,1.0) c write(6,*) twz = -2.0*z0 c write(6,*) ' twz =', twz c c db = 0.01 c b0 = -5.3 c nb = (-b0 + log(rs))/db c do ib = 1, nb c b = exp((ib-1)*db + b0) nb = nint(rs/db) c write(6,*) 'nb =', nb do ib = 1, nb - 1 b = (ib-1)*db + db c dx = 0.005 nx = nint(rs/dx) rmx = nx*dx t = rmx/b rt = log(t + sqrt(t**2-1.0)) c nt = nint(rt/dx) c write(6,*) 'nt =', nt,' for ib =', ib if(nt.gt.nt_) then write(6,*) ' ' write(6,*) ' ' write(6,*) ' stop in subroutine tbmat ' write(6,*) ' increase dimension nt_; ', & ' it should be greater than nt =', nt write(6,*) ' ' write(6,*) ' ' call exit endif if(nt.le.4) cycle x(1) = dx rx(1) = b*(exp(dx) + exp(-dx))/2.0 c write(2,*) x(1), rx(1) do i = 2, nt x(i) = x(i-1) + dx rx(i) = b*(exp(x(i)) + exp(-x(i)))/2.0 c write(2,*) x(i), rx(i) enddo c do i = 1, nt jlo = 1 call nearest1(r, kmax, rx(i), ip1, ip2, ip3, jlo) c call cinterp_quad( r(ip1), z(ip1), r(ip2), z(ip2), & r(ip3),z(ip3),rx(i),zx,dzx,d2zx) rid(i) = zx - twz rid1(i) = zx enddo c call defint0(rid,dx,nt,zb,id) call defint0(rid1,dx,nt,z1,idr) c zbc = twz*rt dbf = zb + zbc c write(6,*) ' coulomb eikonal phase zbc =', zbc c write(6,*) ' eikonal phase zb =', zb c write(6,*) ' total eikonal phase dbf =', dbf c c write(6,*) ' integrated zx =', z1 c dbs = -dbf/xer/2.0 tb = cu/pi*(cexp(2.0*cu*dbs) - 1.0) c c write(6,*) ' eikonal t(b) =', tb,' at b =', b c write(45,'(3e15.7)') b, tb write(35,'(3e15.7)') b, tb c enddo c c return end c c subroutine vxc ( doit ) c include 'mscalc.inc' include 'msxas3.inc' integer at_,d_,rd_,sd_ parameter ( at_=nat_-1,d_=ua_-1,rd_=440,sd_=ua_-1) c c calculation of ex-correlation h-l potential c c c common /dens/ irho,rs(rd_,sd_),rsint(2), $ vcoul(rd_,sd_),vcoulint(2) common /fcnr/kxe, h(d_),vcons(2,2),r(rd_,d_),v(2,rd_,sd_), $ ichg(10,d_),kplace(at_),kmax(at_) c common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, 1 imvhl,nedhlp c common /hedin/ wp2,xk,e,eta2,pi,ot,kdens c c x_k_0 not divided by k_f c common/corr/r_s,blt,x_k_0 c character*8 name0 ,nsymbl common/param/eftr,gamma,vcon(2),xe,ev,ekn,iout,nat,ndat, 1 nspins,nas,rmuftin(at_),xv(at_),yv(at_),zv(at_),exfact(at_), 3 z(at_),lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex xe,ev external f1,f2,f3 real*8 r_s,blt,x_k_0,im_vxc,re_vxc,pi_8 real*4 re_vxc_4,im_vxc_4 logical doit, iskip nout = 0 anns=float(nspins) eps=1.e-3 eta=1.e-3 eta2=eta*eta ot=1./3. ts2=27.*27. t2=32. sqr3=sqrt(3.) pi=3.1415926 pi_8 = dble(pi) a=(4./(9.*pi))**ot eken=ekn-eftr c c do na = 1, ndat c print *, ' atom number =', na c do k = 1 , kmax(na) c print *, k, r(k,na), rs(k,na) c enddo c enddo c c calculate rs from charge density first time through subroutine: c remember that rhotot read in input is actually 4*pi*rho*r**2 c c print *, nspins, ndat, kmax(1), 'check point' if( .not. doit ) goto 100 do 50 isp=1,nspins do 40 nb=1,ndat ns=nb+(isp-1)*ndat do 30 k=1,kmax(nb) rs(k,ns)=((3.*(r(k,nb)**2))/(rs(k,ns)*anns))**ot c if(ns.eq.1) c & print *, 'r, rs(k,1) =', r(k,1), rs(k,1) 30 continue 40 continue rsint(isp)=(3./(pi*4.*rsint(isp)*anns))**ot 50 continue c c c calculate self-energy c 100 do 300 isp=1,nspins iskip=.false. do 280 nb=1,ndat+1 ns=nb+(isp-1)*ndat if(.not.iskip)then c c compute vxc for atomic and outer spheres c km=kmax(nb) else c c compute vxc for interstitial region c km=1 endif do 260 k=1,km if(.not.iskip)then rsp=rs(k,ns) else rsp=rsint(isp) endif ef=1./(a*rsp)**2 xk=sqrt(1.0+eken/ef) if(eken.lt.0.0) xk=1.0 wp2=4.*a*rsp/(3.*pi) wp=sqrt(wp2) xk2=xk*xk e=.5*xk2 xkp=xk+1. xkm=xk-1. xkpi=1./xkp if(nedhlp.eq.2)then c c define variables used by rehr's subroutine rhl c x_k_0=dble(xk/(a*rsp)) r_s=dble(rsp) call rhl(re_vxc,im_vxc,pi_8) c c conversion to single precision and ryd c re_vxc_4 = 2.0*sngl(re_vxc) c c conversion to single precision and ryd c im_vxc_4 = 2.0*sngl(im_vxc) if (iskip) goto 1200 v(1,k,ns)=vcoul(k,ns) + re_vxc_4 if(imvhl.ne.0)v(2,k,ns)=-im_vxc_4 + gamma goto 1210 1200 vcons(1,isp)=vcoulint(isp) + re_vxc_4 if(imvhl.ne.0)vcons(2,isp)=-im_vxc_4 + gamma 1210 continue if(imvhl.ne.0)goto 260 goto 210 end if c flg=alog((xkp+eta2)/(xkm+eta2)) edxc=(1.-xk2)/xk*.5*flg vedx=1.5*wp2*(1.+edxc) vsex = 0.0 vch = 0.0 if(nedhlp.ne.0) go to 199 if(nb.eq.1.and.nout.eq.1) go to 199 vsex=.75*wp2**2/xk*gauss(f2,xkm,xkp,eps) vch1=gauss(f3,0.,xkp,eps) vch2=gauss(f1,0.,xkpi,eps) vch=.75*wp2**2/xk*(vch1+vch2) 199 continue if (iskip) goto 200 v(1,k,ns)=vcoul(k,ns) - ef*(vedx+vsex+vch) goto 210 200 vcons(1,isp)=vcoulint(isp) - ef*(vedx+vsex+vch) 210 continue c c calculate vim, imaginary part of self energy: c if(imvhl.eq.0) goto 260 rfct = 1.0 ! renormalizes the imaginary part c if((icplxv.eq.1).and.(.not.iskip)) go to 260 if(wp2.ge.t2/ts2) go to 215 c1=ts2*wp2/16. phi=acos(1.-c1) phit=phi*ot xkl=1.+2./9.*(-1.+cos(phit)+sqr3*sin(phit)) goto 216 215 q=(16.-ts2*wp2)/54. del=(ts2*wp2-t2)*wp2/4. srdel=sqrt(del) v2=-q-srdel v2m=abs(-q-srdel) xkl=7./9.+ot*((-q+srdel)**ot+sign(1.,v2)*v2m**ot) 216 xkl2m=xkl**2-1. xkmm=1.+sqrt(-2./3.+sqrt(4./9.-4.*wp2+xkl2m**2)) if(abs(xkl-xkmm).gt.1.e-4) x write(iovrho,221) xkl,xkmm,nb,k,rsp 221 format(' xkl(=',e14.6,') not equal to xkmm(=',e14.6,') for ', x ' nb,k,rs=',2i10,e20.6) xmm=sqrt(1.+2.*wp) if(xkl.lt.xmm) write(iovrho,222) xkl,xmm,nb,k,rsp 222 format(' xkl(=',e14.6,') less than xmm(=',e14.6,') for ', x 'nb,k,rs=',2i10,e20.6) if(.not.iskip) v(2,k,ns)=gamma if(iskip) vcons(2,isp)=gamma if(xk.le.xkl) go to 260 del1=27.*xk2*wp2-4.*(xk2-ot)**3 if(del1.ge.0.) write(iovrho,223) nb,k,rsp 223 format(' discriminant del1 positive for nb,k,rs=',2i10,e20.6) xm2=-2*ot+sqrt(4./9.-4.*wp2+(xk2-1.)**2) c1=27.*xk2*wp2/(2.*(xk2-ot)**3) if(c1.gt.2.) write(iovrho,224) c1,nb,k,rsp 224 format(' c1(=',e14.6,') gt 2. for nb,k,rs=',2i10,e20.6) phi=acos(1.-c1) phit=ot*phi xk1=(1.-cos(phit)+sqr3*sin(phit))*(xk2-ot)/(3.*xk) xk12=xk1*xk1 an=xm2*(xk12*(1.-3.*wp)+6.*wp*(wp+xk*xk1)) ad=xk12*(xm2+3.*wp*(xk2-1.+2.*wp)) if (iskip) goto 258 v(2,k,ns)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma goto 260 258 vcons(2,isp)= rfct*ef*(3.*pi/8.*wp**3/xk*alog(an/ad))+gamma 260 continue if(nb.eq.ndat)iskip=.true. 280 continue 300 continue c c transfer constant for interstitial potential c vcon(1)=vcons(1,1) vcon(2)=vcons(2,1) c return end c FUNCTION F1(X) COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT YI=1./X YI2=YI*YI WQ=SQRT(WP2+OT*YI2+(.5*YI2)**2) T1=.5*(XK+YI)**2-E+WQ T2=.5*(XK-YI)**2-E+WQ R=(T1*T1+ETA2)/(T2*T2+ETA2) F1=.5*ALOG(R)*YI/WQ RETURN END FUNCTION F2(X) COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT X2=X*X WQ=SQRT(WP2+OT*X2+(.5*X2)**2) T1=.5-E-WQ T2=.5*(XK-X)**2-E-WQ T3=T2+2.*WQ T4=.5-E+WQ R=(T1*T1+ETA2)*(T3*T3+ETA2)/((T2*T2+ETA2)*(T4*T4+ETA2)) F2=.5*ALOG(R)/(WQ*X) RETURN END FUNCTION F3(X) COMMON /HEDIN/ WP2,XK,E,ETA2,PI,OT X2=X*X WQ=SQRT(WP2+OT*X2+(.5*X2)**2) T1=.5*(XK+X)**2-E+WQ T2=.5*(XK-X)**2-E+WQ R=(T1*T1+ETA2)/(T2*T2+ETA2) F3=.5*ALOG(R)/(WQ*X) RETURN END FUNCTION GAUSS(F,A,B,EPS) LOGICAL MFLAG,RFLAG EXTERNAL F DIMENSION W(12),X(12) C C ****************************************************************** C C ADAPTIVE GAUSSIAN QUADRATURE. C C GAUSS IS SET EQUAL TO THE APPROXIMATE VALUE OF THE INTEGRAL OF C THE FUNCTION F OVER THE INTERVAL (A,B), WITH ACCURACY PARAMETER C EPS. C C ****************************************************************** C DATA W */1.01228536E-01, 2.22381034E-01, 3.13706646E-01, * 3.62683783E-01, 2.71524594E-02, 6.22535239E-02, * 9.51585117E-02, 1.24628971E-01, 1.49595989E-01, * 1.69156519E-01, 1.82603415E-01, 1.89450610E-01/ DATA X */9.60289856E-01, 7.96666477E-01, 5.25532410E-01, * 1.83434642E-01, 9.89400935E-01, 9.44575023E-01, * 8.65631202E-01, 7.55404408E-01, 6.17876244E-01, * 4.58016778E-01, 2.81603551E-01, 9.50125098E-02/ C C ****************************************************************** C C START. C GAUSS=0. IF(B.EQ.A) RETURN CONST=0.005/(B-A) BB=A C C COMPUTATIONAL LOOP. C 1 AA=BB BB=B 2 C1=0.5*(BB+AA) C2=0.5*(BB-AA) S8=0. DO 3 I=1,4 U=C2*X(I) S8=S8+W(I)*(F(C1+U)+F(C1-U)) 3 CONTINUE S8=C2*S8 S16=0. DO 4 I=5,12 U=C2*X(I) S16=S16+W(I)*(F(C1+U)+F(C1-U)) 4 CONTINUE S16=C2*S16 IF( ABS(S16-S8) .LE. EPS*(1.+ABS(S16)) ) GO TO 5 BB=C1 IF( 1.+ABS(CONST*C2) .NE. 1. ) GO TO 2 GAUSS=0. CALL KERMTR('D103.1',LGFILE,MFLAG,RFLAG) IF(MFLAG) THEN IF(LGFILE.EQ.0) THEN WRITE(*,6) ELSE WRITE(LGFILE,6) ENDIF ENDIF IF(.NOT. RFLAG) CALL ABEND RETURN 5 GAUSS=GAUSS+S16 IF(BB.NE.B) GO TO 1 RETURN C 6 FORMAT( 4X, 'FUNCTION GAUSS ... TOO HIGH ACCURACY REQUIRED') END C SUBROUTINE KERSET(ERCODE,LGFILE,LIMITM,LIMITR) PARAMETER(KOUNTE = 28) CHARACTER*6 ERCODE, CODE(KOUNTE) LOGICAL MFLAG, RFLAG INTEGER KNTM(KOUNTE), KNTR(KOUNTE) DATA LOGF / 0 / DATA CODE(1), KNTM(1), KNTR(1) / 'C204.1', 100, 100 / DATA CODE(2), KNTM(2), KNTR(2) / 'C204.2', 100, 100 / DATA CODE(3), KNTM(3), KNTR(3) / 'C204.3', 100, 100 / DATA CODE(4), KNTM(4), KNTR(4) / 'C205.1', 100, 100 / DATA CODE(5), KNTM(5), KNTR(5) / 'C205.2', 100, 100 / DATA CODE(6), KNTM(6), KNTR(6) / 'C205.3', 100, 100 / DATA CODE(7), KNTM(7), KNTR(7) / 'C305.1', 100, 100 / DATA CODE(8), KNTM(8), KNTR(8) / 'C308.1', 100, 100 / DATA CODE(9), KNTM(9), KNTR(9) / 'C312.1', 100, 100 / DATA CODE(10),KNTM(10),KNTR(10) / 'C313.1', 100, 100 / DATA CODE(11),KNTM(11),KNTR(11) / 'C336.1', 100, 100 / DATA CODE(12),KNTM(12),KNTR(12) / 'C337.1', 100, 100 / DATA CODE(13),KNTM(13),KNTR(13) / 'C341.1', 100, 100 / DATA CODE(14),KNTM(14),KNTR(14) / 'D103.1', 100, 100 / DATA CODE(15),KNTM(15),KNTR(15) / 'D106.1', 100, 100 / DATA CODE(16),KNTM(16),KNTR(16) / 'D209.1', 100, 100 / DATA CODE(17),KNTM(17),KNTR(17) / 'D509.1', 100, 100 / DATA CODE(18),KNTM(18),KNTR(18) / 'E100.1', 100, 100 / DATA CODE(19),KNTM(19),KNTR(19) / 'E104.1', 100, 100 / DATA CODE(20),KNTM(20),KNTR(20) / 'E105.1', 100, 100 / DATA CODE(21),KNTM(21),KNTR(21) / 'E208.1', 100, 100 / DATA CODE(22),KNTM(22),KNTR(22) / 'E208.2', 100, 100 / DATA CODE(23),KNTM(23),KNTR(23) / 'F010.1', 100, 0 / DATA CODE(24),KNTM(24),KNTR(24) / 'F011.1', 100, 0 / DATA CODE(25),KNTM(25),KNTR(25) / 'F012.1', 100, 0 / DATA CODE(26),KNTM(26),KNTR(26) / 'F406.1', 100, 0 / DATA CODE(27),KNTM(27),KNTR(27) / 'G100.1', 100, 100 / DATA CODE(28),KNTM(28),KNTR(28) / 'G100.2', 100, 100 / LOGF = LGFILE IF(ERCODE .EQ. ' ') THEN L = 0 ELSE DO 10 L = 1, 6 IF(ERCODE(1:L) .EQ. ERCODE) GOTO 12 10 CONTINUE 12 CONTINUE ENDIF DO 14 I = 1, KOUNTE IF(L .EQ. 0) GOTO 13 IF(CODE(I)(1:L) .NE. ERCODE(1:L)) GOTO 14 13 KNTM(I) = LIMITM KNTR(I) = LIMITR 14 CONTINUE RETURN ENTRY KERMTR(ERCODE,LOG,MFLAG,RFLAG) LOG = LOGF DO 20 I = 1, KOUNTE IF(ERCODE .EQ. CODE(I)) GOTO 21 20 CONTINUE WRITE(*,1000) ERCODE CALL ABEND RETURN 21 RFLAG = KNTR(I) .GE. 1 IF(RFLAG .AND. (KNTR(I) .LT. 100)) KNTR(I) = KNTR(I) - 1 MFLAG = KNTM(I) .GE. 1 IF(MFLAG .AND. (KNTM(I) .LT. 100)) KNTM(I) = KNTM(I) - 1 IF(.NOT. RFLAG) THEN IF(LOGF .LT. 1) THEN WRITE(*,1001) CODE(I) ELSE WRITE(LOGF,1001) CODE(I) ENDIF ENDIF IF(MFLAG .AND. RFLAG) THEN IF(LOGF .LT. 1) THEN WRITE(*,1002) CODE(I) ELSE WRITE(LOGF,1002) CODE(I) ENDIF ENDIF RETURN 1000 FORMAT(' KERNLIB LIBRARY ERROR. ' / + ' ERROR CODE ',A6,' NOT RECOGNIZED BY KERMTR', + ' ERROR MONITOR. RUN ABORTED.') 1001 FORMAT(/' ***** RUN TERMINATED BY CERN LIBRARY ERROR ', + 'CONDITION ',A6) 1002 FORMAT(/' ***** CERN LIBRARY ERROR CONDITION ',A6) END C SUBROUTINE ABEND C C CERN PROGLIB# Z035 ABEND .VERSION KERNVAX 1.10 811126 STOP '*** ABEND ***' END C==================================================================== C SUBROUTINE GET_CORE_STATE C IMPLICIT REAL*8(A-H,O-Z) C c INCLUDE 'mscalc.inc' include 'msxas3.inc' c c ############ I include the file msxasc3.inc c include 'msxasc3.inc' cman integer rd_ PARAMETER(RD_=440) C COMMON/APARMS2/XV2(NAT_),YV2(NAT_),ZV2(NAT_),RS2(NAT_), U ALPHA2(NAT_),REDF2(NAT_),Z2(NAT_),Q2(NAT_),QSPNT2(2), U QINT2(2), U WATFAC(NAT_),ALPHA02,VOLINT2,OVOUT2,RMXOUT2,NSYMBL2(NAT_), U NZ2(NAT_) CHARACTER*8 NSYMBL2 C c #############common/pot_type modified to include the core states c #############to the two hole in the final state of Auger decay i_ c ##############common /pdqi modified to consider also the two auger wav C C common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, C * i_absorber_hole2,i_norman,i_alpha, C 1 i_outer_sphere,i_exc_pot,i_mode C COMMON/POT_TYPE/I_ABSORBER,I_ABSORBER_HOLE,I_ABSORBER_HOLE1, * I_ABSORBER_HOLE2,I_NORMAN,I_ALPHA, 1 I_OUTER_SPHERE,I_EXC_POT,I_MODE C COMMON/PDQI/RPI(RD_),RPI1(RD_),RPI2(RD_) REAL*4 RPI,RPI1,RPI2 INTEGER I_HOLE c INTEGER HOLE C DIMENSION R(440),P_NK(440),P_NK1(440),P_NK2(440),ICHG(12) C DATA THIRD,XINCR,CTFD &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/ C DATA KMX,MESH/RD_,440/ C IZ=NZ2(I_ABSORBER+I_OUTER_SPHERE) c open(unit=697,file='get1.dat',status='unknown') if(iz.eq.0) then iz=1 ! in case an empty sphere is the first atom write(6,*) ' warning check! empty sphere is the first atom ' endif I_RADIAL=I_ABSORBER_HOLE C C ######### Modified to consider also the Auger calculation C I_RADIAL1=I_ABSORBER_HOLE1 I_RADIAL2=I_ABSORBER_HOLE2 I_HOLE=0 NCUT=1 C C SET-UP HERMAN-SKILLMAN MESH FOR Z OF ABSORBING ATOM C MESH=MESH/NCUT H=XINCR*CTFD/(DFLOAT(IZ)**THIRD)*NCUT R(1)=H DO 10 N=1,12 10 ICHG(N)=(40/NCUT)*N N=1 DO 20 K=2,MESH R(K)=R(K-1)+H IF (K.LT.ICHG(N)) GO TO 20 H=H+H N=N+1 20 CONTINUE C C*** COMPUTE FUNCTION P_NK ON RADIAL MESH R C CALL ATOM_SUB(IZ,I_HOLE,R,P_NK,1,I_RADIAL,0.d0) C C C*** PASS VIA COMMON BLOCK THE FIRST KMX POINTS. NOTE THAT C P_NK IS NOT NORMALIZED SINCE Q_NK MUST ALSO BE CONSIDERED. C ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION C R*R_L = P_NK. THIS RELATION HOLDS IN THE LIMIT C --> INFINITY. C DO 30 I=1,KMX RPI(I)=SNGL(P_NK(I)) 30 CONTINUE c c ############# modified to make the calculations also for the two c ############# wave functions necessary for the auger decay calcula c ############# these two wavefunction are calculated with Z+1 appro c ############# with one hole=to the deeper first core hole (hole) c IF (calctype.EQ.'aed') THEN I_HOLE=HOLE2 CALL ATOM_SUB(IZ,I_HOLE,R,P_NK1,1,I_RADIAL1,0.d0) CALL ATOM_SUB(IZ,I_HOLE,R,P_NK2,1,I_RADIAL2,0.d0) DO 3011 I=1,KMX RPI1(I)=SNGL(P_NK1(I)) RPI2(I)=SNGL(P_NK2(I)) 3011 CONTINUE END IF C RETURN END c C SUBROUTINE COREWF(NAS,IZC,HOLE) C INCLUDE 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) C C COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C COMMON /LLM/ ALPHA, BETA C COMMON/PDQIX/RPIX(RDX_), FNISX COMPLEX RPIX C DOUBLE PRECISION CWFX(RDX_),RXD(RDX_),XION COMPLEX RIDX(RDX_),DX C INTEGER HOLE C DATA THIRD,XINCR,CTFD &/0.3333333333333333D0,0.0025D0,0.885341377000114D0/ C C IZ=IZC ITYRADIAL=HOLE C XION=0 ITYHOLE=0 C KMXN = KMX(NAS) DO I = 1, KMXN RXD(I) = DBLE(RX(I,NAS)) ENDDO c write(6,*) ' corewf: kmx = ', kmxn C C*** COMPUTE FUNCTION P_NK ON RADIAL MESH RD AND LL MESH RX C XION = 0.D0 CALL GET_INTRP_CORE(IZ,ITYHOLE,ITYRADIAL,XION,CWFX,RXD,KMXN) C C*** NOTE THAT CWFX=P_NK (UPPER COMPONENT OF DIRAC EQU.) IS NOT NORMALIZED C SINCE ALSO Q_NK (LOWER COMPONENT) MUST ALSO BE CONSIDERED. C ALSO NOTE THE RELATION TO THE SCHRODINGER RADIAL FUNCTION R*R_L = P_NK. C THIS RELATION HOLDS IN THE LIMIT C --> INFINITY. c c.....Find normalization constant in ll-mesh. c do i = 1, kmxn xi = sngl(cwfx(i)) rpix(i)=cmplx(xi) c write(6,*) rx(i,nas), xi enddo c dh = x(2,n) - x(1,n) c write(6,*) ' dh ', dh, hx(n), alpha, beta n = nas id = 1 do k = 1,kmxn ridx(k)=rpix(k)**2*rx(k,n)/(alpha*rx(k,n) + beta) enddo call defint0(ridx,hx(n),kmxn,dx,id) fnisx=sqrt(real(dx)) c c write(6,*) 'corewf: fnisx = ', fnisx c do k=1,kmxn rpix(k)=rx(k,n)**2*rpix(k)/fnisx enddo c RETURN END C C C*********************************************************************** C subroutine get_intrp_core(iz,ihole,i_radial,xion,cwfx,rx,kmxn) c c implicit real*8(a-h,o-z) c c parameter ( mp = 251, ms = 30 ) c character*40 title c common/mesh_param/jlo common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy c c For interpolation on rx mesh c dimension rx(kmxn), cwfx(kmxn) dimension p(0:mp), rat(0:mp), r(mp) c c dimension dum1(mp), dum2(mp) dimension vcoul(mp), rho0(mp), enp(ms) c title = ' ' c ifr=1 iprint=0 C amass=0.0d0 beta=0.0d0 c c There are no nodes in relativistic radial charge density c small=1.0d-11 c !Hence a lower limit on rho(r) can be used. dpas=0.05d0 dr1=dexp(-8.8d0) dex=exp(dpas) r_max=44.447d0 c radius=10.0d0 c xion=0.d0 c c compute relativistic Hartrer-Fock-Slater charge density (on log mesh) c call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, 1 vcoul, rho0, dum1, dum2, enp, eatom) c c compute radial log mesh (see subroutine phase in J.J. Rehr's program c FEFF.FOR) c ddex=dr1 do 10 i=1,251 r(i)=ddex ddex=ddex*dex 10 continue c c write(6,*) ' interpolating on rx mesh ' c Dump upper componen of Dirac wf into p c p(0) = 0.d-8 rat(0) = 0.d-8 do i = 1, 251 p(i) = dgc(i,i_radial) rat(i) = r(i) c write(6,*) rat(i), p(i) enddo c do i=1,kmxn if(rx(i).gt.r_max) goto 60 c find nearest points c initialize hunting parameter (subroututine nearest) c jlo=1 call nearest(rat,252,rx(i), 1 i_point_1,i_point_2,i_point_3) c i_point_1 = i_point_1 -1 i_point_2 = i_point_2 -1 i_point_3 = i_point_3 -1 c c interpolate wavefunction c call interp_quad( rat(i_point_1),p(i_point_1), 1 rat(i_point_2),p(i_point_2), 1 rat(i_point_3),p(i_point_3), 1 rx(i),cwfx(i) ) enddo c 60 continue c return end C C C*********************************************************************** c subroutine input_cont(id,potype,potgen,lmax_mode,lmaxt) c include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c c modified input subroutine for (optionally) complex potentials c common /dens/ irho,rhotot(rd_,sd_),rhoconi(2), $ vcoul(rd_,sd_),vcoulint(2) common/auger/calctype,expmode,edge1,edge2 c common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(2,rd_,sd_), $ ichg(10,d_),kplace(at_),kmax(at_) complex vcons c common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, 1 imvhl,nedhlp c character*8 name0 ,nsymbl character*3 calctype, expmode character*5 potype character*2 potgen character*2 edge1,edge2 c ctn common block from msxas3.inc c .... redundant variables with param.... c common/continuum/xemin,xemax,xdelta,xcip,xgamma,xeftri,iexcpot c common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,xe,ev c common /state/ natom(n_),ln(n_),nleq(at_), 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode c !pass pots and rhos to this sub common/out_ascii/iout_ascii c common/lparam/lmax2(nat_),l0i c logical check c character*65 exc_pot_label(5) character*65 exc_pot_label_extnl(6) data exc_pot_label/ &'generating final potential (x_alpha exchange)', &'generating final potential (real dirac-hara exchange)', &'generating final potential (real hedin-lundqvist exchange)', &'generating final potential (complex dirac-hara exchange)', &'generating final potential (complex hedin-lundqvist exchange)' &/ data exc_pot_label_extnl/ &'potential from extnl file (x_alpha exchange)', &'potential from extnl file (real dirac-hara exchange)', &'potential from extnl file (real hedin-lundqvist exchange)', &'potential form extnl file (complex dirac-hara exchange)', &'potential form extnl file (complex hedin-lundqvist exchange)', &'potential form extnl file (potential from lmto calculation)' &/ c data lunout/7/, ot/.333333/, pi/3.1415926/ c c**** definitions for this version of continuum c iout=2 nspins=1 iout_ascii=2 c !output check files iovrho=13 iosym=14 c c*** define state dependent parameters c read cip (core ionization potential),emin,emax and deltae c in order to check array sizes. ctn read(5,*) cip,emin_exc,emax_exc,de_exc ctn read(5,*) i_exc_pot,gamma,eftri ctn initializes from common continuum c emin_exc=xemin emax_exc=xemax de_exc=xdelta cip=xcip gamma=xgamma eftri=xeftri i_exc_pot=iexcpot ctn write(*,*)'dans inpot_cont:' ctn write(*,*) cip,emin_exc,emax_exc,de_exc ctn write(*,*) i_exc_pot,gamma,eftri c c de_exc = 0.05 c con = 27.2116/7.62 c wvb = sqrt(con*emin_exc) c wve = sqrt(con*emax_exc) c kxe = nint((wve-wvb)/0.05 + 1.) c kxe = nint(alog(emax_exc - emin_exc + 1.)/de_exc + 1.) kxe = nint((xemax-xemin)/xdelta + 1.) if(kxe.gt.nep_)then c write(lunout,730) kxe write(6,730) kxe 730 format(//, & ' increase the dummy dimensioning variable, nep_. ', & /,'it should be at least equal to: ', i5,/) write(6,'(3f10.5)') xemax, xemin, xdelta call exit end if c !define absorbing atom nas=i_absorber c emin=emin_exc emax=emax_exc de=de_exc if(i_exc_pot.eq.1)then c !define exchange potential types nedhlp=0 irho=0 imvhl=0 if(i_mode.eq.1)then print 745,exc_pot_label_extnl(1) else print 745,exc_pot_label(1) end if 745 format(2x,a65) else if(i_exc_pot.eq.2)then nedhlp=1 irho=2 imvhl=0 if(i_mode.eq.1)then print 745,exc_pot_label_extnl(2) else print 745,exc_pot_label(2) end if else if(i_exc_pot.eq.3)then c c nedhlp=2 !use rehr's approximation to re(vxc) c nedhlp=0 !use exact integral expression for re(vxc) irho=2 imvhl=0 if(i_mode.eq.1)then print 745,exc_pot_label_extnl(3) else print 745,exc_pot_label(3) end if else if(i_exc_pot.eq.4)then nedhlp=1 irho=2 imvhl=1 if(i_mode.eq.1)then print 745,exc_pot_label_extnl(4) else print 745,exc_pot_label(4) end if else if(i_exc_pot.eq.5) then c c nedhlp=2 !use rehr's approximation to re(vxc) and im(vxc) c nedhlp=0 !use exact integral expression for vxc c irho=2 imvhl=1 if(i_mode.eq.1)then print 745,exc_pot_label_extnl(5) else print 745,exc_pot_label(5) end if else if(i_exc_pot.eq.6) then irho = 0 print 745, exc_pot_label_extnl(6) c end if c if(irho.ne.0)then i_alpha=0 else i_alpha=1 end if if (i_mode.eq.1)then c call get_external_pot if(potype.eq.' lmto') print 745, exc_pot_label_extnl(6) call get_ext_pot_lmto(potype) else call vgen end if c c... calculate fermi level eftr = vcint + kf**2 - .72*3./2.*kf/pi*2. c if (irho.eq.0) then eftr = real(vcons(1))/2. else fmkf = (3.*pi**2*rhoconi(1))**ot eftr = real(vcons(1)) + fmkf*(fmkf - 2.16/pi) endif c if (eftri.ne.0.0) eftr = eftri c if (lmax_mode.eq.0) then c write(lunout,741) write(6,741) lmaxt 741 format(/,1x,' lmax constant on each atom equal to: ', i5) c else if (lmax_mode.eq.1) then c write(lunout,741) write(6,742) emax 742 format(/,1x,' lmax assignment based on', & ' lmax = r_mt * k_max + 2',/, & ' at energy emax =',f12.6) c else c write(lunout,741) write(6,743) 743 format(/,1x,' lmax assignment based on', & ' l_max = r_mt * k_e + 2',/, & ' where e is the running energy') c endif c ###### problem: for low energy continuum auger electron it can happen c that lmax2 is less than the higher value of the orbital mom c allowed for the continuum auger electron; thus I set the lm c value equal to the lmax_ value given in the include file c msxas3.inc c l_max = 0 c if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or. & (calctype.eq.'rex').or.(calctype.eq.'led')) then c c !assign lmax values and check max(lm) c if (lmax_mode.eq.0) then do i=1,ndat lmax2(i) = lmaxt c write(lunout,842) lmax2(i),i write(6,842) lmax2(i),i 842 format(10x,' lmax =', i3, ' on center =', i3) enddo c else if (lmax_mode.eq.1) then do i=1,ndat lmax2(i) = nint(rs(i)*sqrt(emax)) + 2 if(l_max.lt.lmax2(i)) l_max=lmax2(i) c write(lunout,843) lmax2(i),i write(6,843) lmax2(i),i 843 format(10x,' optimal lmax =', i3, ' on center =', i3) enddo c else do i=1,ndat lmax2(i) = nint(rs(i)*sqrt(emax)) + 2 if(l_max.lt.lmax2(i)) l_max=lmax2(i) if(i.eq.ndat) then c write(lunout,844) write(6,844) endif 844 format(1x,' optimal lmax chosen according to the running', & ' energy e for each atom') enddo c endif c c...give warning for insufficient lmax dimensions c check = .false. if(lmax_mode.ne.0) then if(l_max.gt.lmax_) then c manolo check=.true. c write(lunout,746)l_max write(6,746)l_max 746 format(///, & ' increase the dummy dimensioning variable, lmax_. ', & /,' it should be at least equal to: ', i5) call exit endif else if(lmaxt.gt.lmax_) then c manolo check=.true. c write(lunout,746)lmaxt write(6,746)lmaxt call exit endif endif c c else c c ##### auger part: c do i=1,ndat lmax2(i)=lmax_ l_max=lmax_ enddo end if c c...set lmax equal on any atom if check='true' c if ((calctype.eq.'xpd').or.(calctype.eq.'xas').or. & (calctype.eq.'rex').or.(calctype.eq.'led')) then if(check) then do i=1,ndat lmax2(i) = l_max write(6,7422)lmax2(i),i 7422 format(10x,' lmax =', i3, ' on center =', i3) enddo c write(6,*) ' ' write(6,*)' ** input_cont warning **' write(6,*)' -> estimated l_max is greater than lmax_' write(6,*)' computation proceeds with l_max=lmax_' write(6,*)' but convergence is not guaranteed' c endif c else c do i=1,ndat c lmax2(i) = l_max c write(6,7422)lmax2(i),i c enddo endif c write(6,*) c c write (iovrho,408) nedhlp,irho,imvhl,eftr,gamma 408 format(' nedhlp=',i5,' irho=',i5,' imvhl=',i5, x /,' eftr = ',f10.6,' gamma =',f10.6) write (iovrho,409) nat,ndat,nspins, 1 inmsh,inv,inrho,insym,iovrho,iosym 409 format(9i5) c write(iovrho,110) nat if (iovrho .ne. 6 ) write(6,110) nat 110 format(/,2x,18hnumber of centers=,i5,/) c c store coulomb potential if energy dependent exchange is to be used c if(irho.ne.0)then do 4304 isp=1,nspins do 4303 nb=1,ndat ns=nb+(isp-1)*ndat do 4302 k=1,kmax(nb) vcoul(k,ns)=v(1,k,ns) 4302 continue 4303 continue vcoulint(isp)=real(vcons(isp)) 4304 continue end if c c check for consistency of input data: c write(iovrho,111) 111 format(30x,10hatom no.,12x,8hposition,14x,13hradius eq ) write(iovrho,112) (i,nsymbl(i),nz(i),xv(i),yv(i),zv(i),rs(i), 1 neq(i),i=1,nat) write (iovrho,112) 112 format(26x,i3,2x,a4,i6,4f10.4,i6) do 211 i=1,nat if(rs(i).lt.0.0) then write(iovrho,201) i, rs(i) write(6,201) i, rs(i) call exit endif if(neq(i).eq.0)go to 210 if(neq(i).ge.i) go to 213 210 i1=i+1 if(i1.gt.nat) go to 5000 go to 2135 213 write(iovrho,202) neq(i), i write(6,202) neq(i), i call exit 2135 do 211 j=i1,nat rij = sqrt((xv(j)-xv(i))**2+(yv(j)-yv(i))**2+(zv(j)-zv(i))**2) rsum = rs(i)+rs(j) rdif = rsum-rij if (rsum.gt.rij) go to 215 go to 211 215 write (iovrho,200) i,j,rsum,rij,rdif 200 format(' spheres',2i5,' overlap ',3f12.6) 201 format(' sphere',i5,' has negative rs', f12.6) 202 format(' neq(i)',i5,' for atom i=', i5,' is inconsistent' ) 211 continue c 5000 return end c C SUBROUTINE GET_EXTERNAL_POT C c INCLUDE 'mscalc.inc' include 'msxas3.inc' INTEGER AT_,D_,RD_,SD_ PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2), $ VCOUL(RD_,SD_),VCOULINT(2) C COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_), $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_) COMPLEX VCONS C COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, 1 IMVHL,NEDHLP C CHARACTER*8 NAME0 ,NSYMBL C COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE COMPLEX VCON,XE,EV C COMMON/DIMENS2/NAT2,NDAT2 C cman DATA INV,INRHO/2,3/ inv=2 inrho=3 C NAT = NAT2 - 1 NDAT = NDAT2 - 1 C OPEN(INV, status='unknown') DO 4444 N=1,NAT READ (INV,311) NSYMBL(N),NEQ(N), NZ(N),IDUMMY,KMAX(N), 1 KPLACE(N),XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC 311 FORMAT (1X,A4,3I2,2I4,5F11.6,T76,I5) Z(N)=NZ(N) IF(NEQ(N).NE.0) GO TO 4444 C C RECONSTRUCT RADIAL MESH C READ (INV,308) (ICHG(I,N),I=1,10),NC 308 FORMAT(10I5,T76,I5) KX=KMAX(N) READ (INV,319) NC,(R(I,N),I=1,5) H(N)=R(2,N)-R(1,N) HH=H(N) ICH=1 KICH=ICHG(ICH,N) DO 133 K=3,KX R(K,N)=R(K-1,N)+HH IF (K.LT.KICH) GO TO 133 ICH=ICH+1 KICH=ICHG(ICH,N) HH=HH+HH 133 CONTINUE 319 FORMAT(T76,I5,T2,1P5E14.7) H(N)=R(2,N)-R(1,N) NS=N C DO 142 ISPIN=1,NSPINS DO 141 K=1,KX,5 KCARD=MIN0(KX,K+4) READ (INV,319) NC,(V(1,I,NS),I=K,KCARD) DO 7474 KKK=K,KCARD 7474 V(2,KKK,NS) = 0.000 141 CONTINUE 142 NS=NS+NDAT C IF(IRHO.EQ.0) GOTO 4444 OPEN(INRHO, status='unknown') DO 423 ISPIN=1,NSPINS NS=N+(ISPIN-1)*NDAT DO 424 K=1,KX,5 KCARD=MIN0(KX,K+4) READ(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD) 424 CONTINUE 423 CONTINUE 4444 CONTINUE C C READ INTERSTITIAL V AND RHO C READ (INV,319) NC,(VCONS(ISPIN),ISPIN=1,NSPINS) IF(IRHO.NE.0)READ (INRHO,319) NC,(RHOCONI(ISPIN),ISPIN=1,NSPINS) C WRITE(6,120) INV 120 FORMAT (' STARTING POTENTIAL READ IN FROM FILE',I4) IF( IRHO .NE. 0) WRITE(6,121) INRHO 121 FORMAT (' STARTING CHARGE DENSITY READ IN FROM FILE',I4) C REWIND(INV) REWIND(INRHO) C RETURN END C SUBROUTINE GET_EXT_POT_LMTO(potype) C include 'msxas3.inc' C INTEGER AT_,D_,RD_,SD_ PARAMETER ( AT_=NAT_-1,D_=UA_-1,RD_=440,SD_=UA_-1) C PARAMETER (MRP = 500) C COMMON /DENS/ IRHO,RHOTOT(RD_,SD_),RHOCONI(2), $ VCOUL(RD_,SD_),VCOULINT(2) C COMMON /FCNR/KXE, H(D_),VCONS(2),R(RD_,D_),V(2,RD_,SD_), $ ICHG(10,D_),KPLACE(AT_),KMAX(AT_) COMPLEX VCONS C COMMON /FLAG/ INMSH,INV,INRHO,INSYM,IOVRHO,IOSYM, 1 IMVHL,NEDHLP C CHARACTER*8 NAME0 ,NSYMBL C COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE COMPLEX VCON,XE,EV C COMMON/DIMENS2/NAT2,NDAT2 C common/aparms/xa(natoms),ya(natoms),za(natoms),zat(natoms), & nsymbla(natoms),nzeq(natoms),neqa(natoms),ncores(natoms), & lmaxat(natoms) C REAL*8 xa,ya,za,zat CHARACTER*8 nsymbla C DIMENSION RL(MRP,D_), VCL(MRP,SD_), RHOL(MRP,SD_), HL(D_), & VLMTO(MRP,SD_), KMXP(SD_), KPLP(SD_), RSL(SD_), & NPAC(-10:100), NZL(D_), KMX(SD_), ICHGL(SD_,D_) C DIMENSION RHS(MRP,D_), VHS(MRP,SD_), RHOHS(MRP,SD_) C REAL*8 RL, VCL, RHOL, HL, VLMTO, RSL, RHS, VHS, RHOHS, & HR, VINT, RHOINT, DVT, DVTRHOINT C EXTERNAL NEAREST C CHARACTER*5 POTYPE CHARACTER*5 CHECK C DATA THIRD,XINCR,CTFD &/0.33333333,0.0025E0,0.88534137E0/ C INP=2 C NDUMMY = 0 NSPINS = 1 NAT = NAT2 - 1 NDAT = NDAT2 - 1 C OPEN(INP, file='data/inpot.ext',status='unknown') C C Initialize to zero the vector indicating for which atomic species C the lmto data have been already interpolated. Positions from 1 to C 100 indicates physical atoms, from 0 to -1010 empty inequivalent C spheres C DO N = -10, 100 NPAC(N) = 0 ENDDO C C VCOULINT : interstitial Coulomb potential in Ry C RHOCONI : interstitial charge density in Ry C VCLMTO : intsrstitial LMTO potential in Ry C READ(INP,*) VCOULINT(1), RHOCONI(1), VCLMTO C NES=1 C DO N=1,NDAT C READ(INP,*,END=50) NZL(N), KMX(N), RSL(N) WRITE(6,*) 'N=',N,'ZATL(N)=', NZL(N),'KMX(N)=',KMX(N), & 'RS(N)=',RSL(N) IF (KMX(N).GT.MRP) THEN WRITE(6,*) ' ' WRITE(6,*) ' ' WRITE(6,*)' MRP =', MRP,' TOO SMALL, INCREASE UP TO ', KMX(N) WRITE(6,*) ' ' WRITE(6,*) ' ' CALL EXIT ENDIF C IF(NZL(N).NE.0) THEN NPAC(NZL(N)) = N C WRITE(6,*) 'N, NZL(N), NPAC(NZL(N))', N, NZL(N) , NPAC(NZL(N)) ELSE NES=NES-1 NPAC(NES)=N C WRITE(6,*) 'N, NZL(N), NES, NPAC(NES)', N,NZL(N),NES,NPAC(NES) ENDIF C C NOTE: COULOMB AND LMTO POTENTIALS ARE MULTIPLIED BY RL C DO K = 1, KMX(N) READ(INP,*) RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N) C WRITE(6,*) K, RL(K,N), VCL(K,N), RHOL(K,N), VLMTO(K,N) ENDDO C C SET-UP HERMAN-SKILLMAN MESH FOR ATOM OF ATOMIC NUMBER Z C MESH=400 NCUT=1 MESH=MESH/NCUT IF(NZL(N).EQ.0) THEN HL(N)=DBLE(XINCR*CTFD*NCUT) ELSE HL(N)=DBLE(XINCR*CTFD/(FLOAT(NZL(N))**THIRD)*NCUT) ENDIF HR = HL(N) RHS(1,N)=HR DO 10 K=1,12 10 ICHGL(K,N)=(40/NCUT)*K I=1 DO 20 K=2,MESH RHS(K,N)=RHS(K-1,N)+HR IF (K.LT.ICHGL(I,N)) GO TO 20 HR=HR+HR I=I+1 20 CONTINUE C C FIND KMAX(N) IN THE H-S MESH ACCORDING TO RS(N) C KMXP(N) = 0 KPLP(N) = 0 DO K = 1, MESH IF (RHS(K,N).GT.RSL(N)) GO TO 40 ENDDO 40 KPLP(N) = K - 1 KMXP(N) = K + 2 C WRITE(6,*) 'ATOMIC SPECIES, HS KPLACE AND KMAX' WRITE(6,*) 'N=',N, 'KPLP(N)= ',KPLP(N), ' KMXP(N)= ', KMXP(N) C WRITE(6,*) 'RHSMAX=', RHS(400,N), 'RSL(N) =', RSL(N) C DO I=1,KMXP(N) C FIND NEAREST POINTS C INITIALIZE HUNTING PARAMETER (SUBROUTUTINE NEAREST) C CALL NEAREST(RL(1,N), KMX(N), RHS(I,N), IP1, IP2, IP3) C IF(IRHO.NE.0) THEN C C INTERPOLATE COULOMB POTENTIAL C CALL INTERP_QUAD( RL(IP1,N),VCL(IP1,N),RL(IP2,N),VCL(IP2,N), & RL(IP3,N),VCL(IP3,N),RHS(I,N),VHS(I,N)) C C INTERPOLATE CHARGE DENSITY C CALL INTERP_QUAD( RL(IP1,N),RHOL(IP1,N),RL(IP2,N), & RHOL(IP2,N),RL(IP3,N),RHOL(IP3,N), & RHS(I,N),RHOHS(I,N)) ELSE C C INTERPOLATE LMTO POTENTIAL C CALL INTERP_QUAD( RL(IP1,N),VLMTO(IP1,N), & RL(IP2,N),VLMTO(IP2,N), & RL(IP3,N),VLMTO(IP3,N),RHS(I,N),VHS(I,N)) ENDIF ENDDO C WRITE(6,*) 'INTERPOLATED VALUES ON HS MESH' C DO I = 1, KMXP(N) C WRITE(6,*) I, RHS(I,N), VHS(I,N), RHOHS(I,N) IF(RHOHS(I,N).LT.0.D0) THEN WRITE(6,*) ' WARNING: DENSITY INTERPOLATED TO NEGATIVE', & ' VALUES AT RHS =', RHS(I,N),' FOR ATOM', & ' NUMBER N =', N CALL EXIT ENDIF ENDDO C C......TEST LAST THREE INTERPOLATED VALUES C SMALL=0.005 C DO I = KPLP(N) + 1, KMXP(N) KP = KMX(N) C IF(IRHO.NE.0) THEN CALL DINTERP(RL(KP-5,N),VCL(KP-5,N),5,RHS(I,N),VINT,DVT, & .TRUE.) CALL DINTERP(RL(KP-5,N),RHOL(KP-5,N),5,RHS(I,N),RHOINT, & DVTRHOINT,.TRUE.) IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN CHECK='OK' WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, & 'FOR VC ', CHECK ELSE CHECK='NOTOK' WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, & 'FOR VC ', CHECK WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N) ENDIF C IF(DABS(RHOHS(I,N)-RHOINT).LT.DBLE(SMALL)) THEN CHECK='OK' WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, & 'FOR RHO ', CHECK ELSE CHECK='NOTOK' WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, & 'FOR DENSITY RHO ', CHECK WRITE(6,*) I, RHS(I,N), RHOINT, RHOHS(I,N) ENDIF C ELSE C CALL DINTERP(RL(KP-5,N),VLMTO(KP-5,N),5,RHS(I,N),VINT,DVT, & .TRUE.) IF(DABS(VHS(I,N)-VINT).LT.DBLE(SMALL)) THEN CHECK='OK' WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, & 'FOR VLMTO ', CHECK ELSE CHECK='NOTOK' WRITE(6,*) 'CHECK ON THE INTERPOLATED VALUE AT I =',I, & 'FOR VLMTO ', CHECK WRITE(6,*) I, RHS(I,N), VINT, VHS(I,N) ENDIF C ENDIF C ENDDO C C ENDDO C 50 CONTINUE C CLOSE(2) C C write(6,*) npac(22), npac(8), npac(0), npac(-1) DO 60 I=1,NAT XV(I) = SNGL(XA(I+1)) - SNGL(XA(2)) YV(I) = SNGL(YA(I+1)) - SNGL(YA(2)) ZV(I) = SNGL(ZA(I+1)) - SNGL(ZA(2)) NSYMBL(I) = NSYMBLA(I+1) NEQ(I) = NEQA(I+1) c write(6,*) NEQ(I), NSYMBL(I) IF(NEQ(I).NE.0) NEQ(I) = NEQ(I) - 1 NZ(I) = NZEQ(I+1) C N = NPAC(NZ(I)) IF(NZ(I).NE.0) THEN C N = NPAC(NZ(I)) C WRITE(6,*) 'N, NZ(I), NPAC(NZ(I))', N, NZ(I), NPAC(NZ(I)) C ELSE C IF(NSYMBL(I).EQ.'ES') THEN N=NPAC(0) ELSE NES=ICHAR('0')-ICHAR(NSYMBL(I)(2:2)) N=NPAC(NES) C WRITE(6,*) ICHAR('0'),ICHAR(NSYMBL(I)(2:2)) C WRITE(6,*) ' NES = ',NES, ' N = ', N ENDIF C ENDIF KPLACE(I) = KPLP(N) KMAX(I) = KMXP(N) RS(I) = REAL(RSL(N)) EXFACT(I) = 0.0 C IF(NEQ(I).NE.0) GO TO 60 C H(I) = REAL(HL(N)) DO K = 1,10 ICHG(K,I) = ICHGL(K,N) ENDDO DO K = 1, KMAX(I) R(K,I) = SNGL(RHS(K,N)) V(2,K,I) = 0.0 IF(IRHO.NE.0) THEN V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N)) RHOTOT(K,I) = SNGL(RHOHS(K,N)) ELSE V(1,K,I) = SNGL(VHS(K,N)/RHS(K,N)) ENDIF ENDDO IF(IRHO.NE.0) THEN VCONS(1) = CMPLX(VCOULINT(1)) ELSE VCONS(1) = CMPLX(VCLMTO) ENDIF 60 CONTINUE C C.....WRITE OUT POTENTIAL AND DENSITY FILES C IF (potype.EQ.' lmto') THEN OPEN (19, FILE = 'div/LMTO.POT', STATUS = 'unknown') ELSE OPEN (20, FILE = 'div/COUL.POT', STATUS = 'unknown') OPEN (9, FILE = 'div/RHO.DENS', STATUS = 'unknown') ENDIF C INV = 20 IF (potype.EQ.' lmto') INV = 19 INRHO= 9 NST=1 NC=2 DO 4401 N=NST,NAT WRITE(INV,311) NSYMBL(N),NEQ(N),NZ(N),NDUMMY,KMAX(N),KPLACE(N), 1 XV(N),YV(N),ZV(N),RS(N),EXFACT(N),NC 311 FORMAT(A5,3I2,2I4,5F11.6,T76,I5) NC=NC+1 IF(NEQ(N).NE.0) GO TO 4401 WRITE(INV,308) (ICHG(I,N),I= 1,10),NC 308 FORMAT(10I5,T76,I5) NC=NC+1 WRITE(INV,319) NC,(R(I,N),I=1,5) 319 FORMAT(T76,I5,T2,1P5E14.7) NS=N NC=NC+1 KX=KMAX(N) NS = N DO 142 ISPIN=1,NSPINS DO 141 K=1,KX,5 KCARD=MIN0(KX,K+4) WRITE(INV,319) NC,(V(1,I,NS),I=K,KCARD) 141 NC=NC+1 142 NS=NS+NDAT NS=N IF (potype.NE.' lmto') THEN DO 555 ISPIN=1,NSPINS DO 551 K=1,KX,5 KCARD=MIN0(KX,K+4) WRITE(INRHO,319) NC,(RHOTOT(I,NS),I=K,KCARD) 551 NC=NC+1 555 NS=NS+NDAT ENDIF 4401 CONTINUE C IF(INV.EQ.19) WRITE( INV,319) NC,(VCONS(IS),IS=1,NSPINS) C IF (INV.EQ.20) THEN WRITE(INV,319) NC, REAL(VCONS(1)) WRITE( INRHO,319) NC,(RHOCONI(IS),IS=1,NSPINS) ENDIF C IF(potype.EQ.' lmto') THEN CLOSE (UNIT=19) ELSE CLOSE (UNIT=20) CLOSE (UNIT=9) ENDIF C C STOP RETURN END C C C-------------------------------------------------------------- subroutine writewf(lxp) include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE COMPLEX VCON,XE,EV CHARACTER*8 NSYMBL,NAME0 c common /pdq/ p(rd_,f_),ps(n_),dps(n_), * ramf(n_),pss(6),dpss(6) complex p,ps,dps,ramf,pss,dpss c common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), $ ichg(10,d_),kplace(at_),kmax(at_) complex vcons,v c common/funit/idat,iwr,iphas,iedl0,iwf common/mtxele/ nstart,nlast,dmx(2),dmx1(2),qmx(3),qmx1(3), $ dxdir,dxexc,nfis,nfis1,nfis2 real nfis,nfis2,nfis1 complex dmx,dmx1,qmx,qmx1,dxdir,dxexc c nlastl = nstart + lxp c c write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)' write(iwf,*) e, xe, real(vcon) c c write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10) c write(iwf,*) write(iwf,*) ' -- absorber excited regular wf for all l -- ' write(iwf,*) c do 1 i=nstart,nlastl write(iwf,*) ' l= ', i-1 do 2 j=1,kmax(nas) write(iwf,*) r(j,1),p(j,i)/ramf(i) 2 continue 1 continue c write(iwf,*) write(iwf,*) ' -- absorber irregular wf for l less than 6 -- ' write(iwf,*) ' radial coor --- wf ' write(iwf,*) c do 3 i= 1, 6 write(iwf,*) ' l= ', i-1 do 4 j=1,kmax(nas) write(iwf,*) r(j,1),p(j,i+npss) 4 continue 3 continue c return end c c C-------------------------------------------------------------- subroutine writeelswf include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c COMMON/PARAM/EFTR,GAMMA,VCON,XE,EV,E,IOUT,NAT,NDAT,NSPINS, 1 NAS,RS(AT_),XV(AT_),YV(AT_),ZV(AT_),EXFACT(AT_),Z(AT_), 3 LMAXX(AT_),NZ(AT_),NSYMBL(AT_), 4 NEQ(AT_),NAME0,CIP,EMAX,EMIN,DE COMPLEX VCON,XE,EV CHARACTER*8 NSYMBL,NAME0 C COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C c common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), & ramfsr2(npss,nef_),ramfsr3(npss,nef_), & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg real*4 einc,esct,scangl,qt,lambda c c common/funit/idat,iwr,iphas,iedl0,iwf c c write(6,*) 'iwf,iwr,iphas,iedl0,iwf', idat,iwr,iphas,iedl0,iwf write(iwf,*) 'energy -- xe (complex wv) -- vcon (real part ip)' write(iwf,*) e, xe, real(vcon) c c write(iwf,*) lxp, kmax(nas), (ichg(i,1),i=1,10) c write(iwf,*) write(iwf,*) ' -- absorber excited regular wf for all l -- ' write(iwf,*) c do i=1,lmxels(1,nas) write(iwf,*) ' inc l= ', i-1 do j=1,kmx(nas) write(iwf,10) rx(j,1),p1(j,i,nas)/ramfsr1(i,nas) enddo enddo c c do i=1,lmxels(2,nas) write(iwf,*) ' sct l= ', i-1 do j=1,kmx(nas) write(iwf,10) rx(j,1),p2(j,i,nas)/ramfsr2(i,nas) enddo enddo c c do i=1,lmxels(3,nas) write(iwf,*) ' exc l= ', i-1 do j=1,kmx(nas) write(iwf,10) rx(j,1),p3(j,i,nas)/ramfsr3(i,nas) enddo enddo c c 10 format(7e15.7) c write(iwf,*) write(iwf,*) ' -- absorber irregular wf for l less than 6 -- ' write(iwf,*) ' radial coor --- wf ' write(iwf,*) c do 3 i= 1, 6 write(iwf,*) ' l= ', i-1 do 4 j=1,kmx(nas) write(iwf,10) rx(j,1),p3irreg(j,i) 4 continue 3 continue c return end c c c********************************************************************** c subroutine scfdat (title, ifr, iz, ihole, xion,amass, beta,iprint, 1 vcoul, srho, dgc0, dpc0, enp, eatom) c c single configuration dirac-fock atom code c c input: c title - any name that will be written into output files. c ifr - specify aadditional output file atom(ifr).dat c iz - atomic number c ihole - remove one electron from orbital #ihole. c complete list is in subroutine getorb. c xion - ionicity (iz-number of electrons) c amass - mass of nucleus; 0. - for point nucleus. c beta - thickness parameter for nuclear charge distribution c beta=0. for uniform distribution c iprint - if iprint>0 additional output is written into atom(ifr).dat c output: c vcoul - total coulomb potential (hartrees) c srho - total charge density (bohr**-3) c dgc0 - upper components of dirac spinors c dpc0 - lower components of dirac spinors c enp - energy eigenvalues (hartrees) c eatom - total atomic energy (hartrees) c written by a. ankudinov, univ. of washington c c programming language fortran 77 c c based on modifications of the code ACRV of J.P. Desclaux c [Comp Phys Comm. 9, 31 (1975)] and some subroutines from c the FEFF code, J.J. Rehr, J. Mustre de Leon, S.I. Zabinsky c and R.C. Albers, [J. Am. Chem. Soc 113,5135(1991) c c version 1 (5-22-96) c c********************************************************************** implicit double precision (a-h,o-z) parameter ( mp = 251, ms = 30 ) c c save central atom dirac components, see comments below. c dimension dgc0(mp), dpc0(mp) dimension vcoul(mp), srho(mp), enp(ms) character*(*) title character*40 ttl character*512 slog common /charact/ ttl character*30 fname c c this programm uses cofcon cofdat dsordf ictime iowrdf c lagdat messer nucdev ortdat potrdf soldir common cg(mp,ms),cp(mp,ms),bg(10,ms),bp(10,ms),fl(ms),ibgp c cg (cp) large (small) components c bg (bp) development coefficients at the origin of large c (small) component c fl power of the first term of development limits. c ibgp first dimension of the arrays bg and bp c c gg,gp are the output from soldir c common/comdir/cl,dz,gg(mp),ag(10),gp(mp),ap(10),bid(3*mp+30) common/itescf/testy,rap(2),teste,nz,norb,norbsc common/mulabk/afgk common/inelma/nem dimension afgk( 30, 30, 0:3) common/messag/dlabpr,numerr character*8 dprlab, dlabpr common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/scrhf1/eps(435),nre(30),ipl common/snoyau/dvn(251),anoy(10),nuc common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim data dprlab/' scfdat'/ c c *** copy input parameters to common blocks c ttl = title lttl = istrln(title) if (lttl.le.0) ttl='atomic data' nz=iz dz=nz c c *** desclaux standard opinion. be careful when changing. c nuc=11 c c nuc - number of points inside nucleus (suggested value 11) c nes=50 c c nes number of attempts in program soldir c differ from desclaux nes=40 c niter=30 c c equivalent to desclaux niter=1130 c niter =1000*n1+100*n2+n3 c n3 is the number of iterations per orbital c testy=1.d-5 c c testy precision for the wave functions c hx=5.d-2 dr(1)=exp(-8.8D0)*iz c c dr(1)=exp(-8.8) c hx exponential step c dr1 first tabulation point multiplied by nz c desclaux dr1=0.01 correspond to iz=66 c teste=5.d-6 rap(1)=1.d2 rap(2)=1.d1 c c teste precision for the one-electron energies c rap tests of precision for soldir c ido=1 c c equivalent to ido=ndep=1 c calculate initial orbitals using thomas-fermi model ido=1 c option to read from cards(ido=2) destroyed c nmax=251 - set in subroutine inmuat c scc=0.3 - set in subroutine inmuat c *** end of desclaux standard opinion on parameters c if (iprint .ge. 1) then c c prepare file for atom output c write(fname,14) ifr 14 format('atom', i2.2, '.dat') open (unit=16, file=fname, status='unknown') c call chopen (ios, fname, 'atom') c call head (16) write(16,*) ' free atom ', ifr lttl = istrln(ttl) if (iprint .ge. 1) write(16,40) ttl(1:lttl) 40 format (1h1,40x,a) endif c c initialize the rest of the data and calculate initial w.f. c jfail = 0 ibgp = 10 numerr = 0 nz = iz call inmuat (ihole, xion) c c iholep is the index for core hole orbital in all arrays c for 90% of atoms iholep=ihole c a = - xion - 1 call wfirdf ( en, a, nq, kap, nmax, ido, amass, beta) j = 1 ind = 1 nter = 0 do 41 i=1, norb 41 scw(i) = 0.D0 test1 = testy / rap(1) test2 = testy / rap(2) netir = abs(niter) * norb if (iprint .ge. 1) then write(16,210) niter, teste, testy 210 format (5x,'number of iterations',i4,//, 1 5x,'precision of the energies',1pe9.2,//, 2 23x,'wave functions ',1pe9.2,/) write(16,220) idim, dr(1), hx 220 format (' the integration is made on ', i3, 1 ' points-the first is equal to ' ,f7.4,/, 2 ' and the step-size pas = ',f7.4,/) write(16,230) test1, nes 230 format ('matching of w.f. with precision', 1pe9.2, 2 ' in ',i3,' attempts ',/) if (nuc.gt.1) write(16,250) 250 format (1h0,30x,'finite nucleus case used'/) endif c c muatco - programm to calculate angular coefficients c call muatco if (numerr .ne. 0) go to 711 c c iteration over the number of cycles c 101 iort = 0 nter = nter + 1 if (niter .ge. 0) go to 105 c c orthogonalization by schmidt procedure c 104 call ortdat (j) 105 method = 1 c c calculate lagrange parameters c if (nre(j).gt.0 .and. ipl.ne.0) call lagdat (j,1) c c calculate electron potential c call potrdf (j) e = en(j) np = idim c c resolution of the dirac equation c ifail = 0 ainf = cg(nmax(j),j) call soldir (en(j), fl(j), bg(1,j), bp(1,j), ainf, 1 nq(j), kap(j), nmax(j), ifail) if (ifail .ne. 0 .and. jfail .eq. 0) jfail = j if (jfail .eq. j .and. ifail .eq.0 ) jfail = 0 if (numerr.eq.0) go to 111 if (iort.ne.0 .or. niter.lt.0) go to 711 iort = 1 go to 104 111 sce(j) = abs((e-en(j)) / en(j)) c c variation of the wave function using two iterations c k = nmax(j) pr = 0.D0 do 121 i = 1, k w = cg(i,j) - gg(i) if (abs(w).le.abs(pr)) go to 115 pr = w a = cg(i,j) b = gg(i) 115 w = cp(i,j) - gp(i) if (abs(w).le.abs(pr)) go to 121 pr = w a = cp(i,j) b = gp(i) 121 continue write(slog,'(i4,i3,2(1pe11.2),2(1pd16.6),4x,a,i2)') 1 nter, j, sce(j), pr, a, b, 'method', method call wlog(slog,0) c c acceleration of the convergence c b = scc(j) call cofcon (a, b, pr, scw(j)) scc(j) = b do 151 i = 1,k gg(i) = b*gg(i) + a*cg(i,j) 151 gp(i) = b*gp(i) + a*cp(i,j) do 155 i=1,ndor ag(i) = b*ag(i) + a*bg(i,j) 155 ap(i) = b*ap(i) + a*bp(i,j) c c normalization of the wave function c a = dsordf (j,k,0,4,fl(j)) a = sqrt(a) do 171 i=1, np cg(i,j) = gg(i) / a 171 cp(i,j) = gp(i) / a do 175 i=1, ndor bg(i,j) = ag(i) / a 175 bp(i,j) = ap(i) / a c c determination of the next orbital to calculate c if (nter.lt.norbsc .or. (ind.lt.0 .and. j.lt.norbsc) ) then j = j+1 go to 451 endif j = j+1 pr=0.D0 do 301 i=1, norbsc w = abs(scw(i)) if (w.gt.pr) then pr = w j = i endif 301 continue if (j.gt.norbsc) j = 1 if (pr.gt.testy) go to 421 pr = 0.D0 do 321 i=1, norbsc w = abs(sce(i)) if (w.gt.pr) then pr = w j = i endif 321 continue if (pr.ge.teste) go to 421 if (ind.lt.0) go to 999 ind = -1 j = 1 go to 451 421 ind = 1 451 if (nter.le.netir) go to 101 numerr = 192011 c c **** number of iterations exceeded the limit c dlabpr = dprlab 711 call messer stop 999 if (numerr .eq. 0) then if (jfail.ne.0) then call wlog( 1 'failed to match lower component, results are meaningless',1) stop endif c c tabulation of the results c if (iprint .ge. 1) call tabrat call etotal( kap, xnel, en, iprint, eatom) c c return coulomb potential c do 800 i=1, idim 800 srho(i) = 0.0D0 do 830 j=1, norb do 830 i=1, nmax(j) 830 srho(i) = srho(i) + xnel(j) * (cg(i,j)**2 + cp(i,j)**2) call potslw( vcoul, srho, dr, hx, idim) do 810 i=1, 251 810 vcoul(i) = vcoul(i) - nz/dr(i) c c return srho as density instead of 4*pi*density*r**2 c do 860 i = 1, 251 c srho(i) = srho(i) / (dr(i)**2) / 4. / pi c srho(i) = srho(i) / 4. / pi c 860 continue c do 870 ispinr = 1, 30 do 852 i = 1, 251 dgc0(i) = cg( i, ispinr) dpc0(i) = cp( i, ispinr) 852 continue enp(ispinr) = en(ispinr) 870 continue endif if (iprint .ge. 1) close(unit=16) return end double precision function akeato (i,j,k) c angular coefficient by the direct coulomb integral fk c for orbitals i and j implicit double precision (a-h,o-z) common/mulabk/afgk dimension afgk(30,30,0:3) c c afgk angular coefficients by integrales fk and gk c coefficient of integral fk(i;j) is in afgk(min,max) c and that of integral gk(i;j) is in afgk(max,min) c max=max(i,j) min=min(i,j) c if (i .le. j) then akeato=afgk(i,j,k/2) else akeato=afgk(j,i,k/2) endif return entry bkeato (i,j,k) c c angular coefficient at the exchange coulomb integral gk c bkeato=0.0d 00 if (i .lt. j) then bkeato=afgk(j,i,k/2) elseif (i.gt.j) then bkeato=afgk(i,j,k/2) endif return end double precision function aprdev (a,b,l) c c the result of this function is the coefficient of the term of c power for the product of two polynomes, whose coefficients are c in rows a and b c implicit double precision (a-h,o-z) dimension a(10),b(10) aprdev=0.0d 00 do 11 m=1,l 11 aprdev=aprdev+a(m)*b(l+1-m) return end subroutine bkmrdf (i,j,k) c c angular coefficients for the breit term c i and j are the numbers of orbitals c k is the value of k in uk(1,2) c this programm uses cwig3j c coefficients for magnetic interaction are in cmag c and those for retarded term are in cret c the order correspond to -1 0 and +1 c implicit double precision (a-h,o-z) common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/tabre/cmag(3),cret(3) do 12 l=1,3 cmag(l)=0.0d 00 12 cret(l)=0.0d 00 ji=2* abs(kap(i))-1 jj=2* abs(kap(j))-1 kam=kap(j)-kap(i) l=k-1 do 51 m=1,3 if (l.lt.0) go to 51 a=cwig3j(ji,jj,l+l,-1,1,2)**2 if (a.eq.0.0d 00) go to 51 c=l+l+1 if (m-2) 14,16,17 14 cm=(kam+k)**2 cz=kam*kam-k*k cp=(k-kam)**2 n=k 15 l1=l+1 am=(kam-l)*(kam+l1)/c az=(kam*kam+l*l1)/c ap=(l+kam)*(kam-l1)/c d=n*(k+k+1) go to 31 16 d=k*(k+1) cm=(kap(i)+kap(j))**2 cz=cm cp=cm go to 41 17 cm=(kam-l)**2 cz=kam*kam-l*l cp=(kam+l)**2 n=l c=-c go to 15 31 c= abs(c)*d if (c.ne.0.0d 00) c=n/c cret(1)=cret(1)+a*(am-c*cm) cret(2)=cret(2)+(a+a)*(az-c*cz) cret(3)=cret(3)+a*(ap-c*cp) 41 if (d.eq.0.0d 00) go to 51 a=a/d cmag(1)=cmag(1)+cm*a cmag(2)=cmag(2)+cz*(a+a) cmag(3)=cmag(3)+cp*a 51 l=l+1 return end subroutine cofcon (a,b,p,q) c c acceleration of the convergence in the iterative process c b is the part of final iteration n is a function of the error (p) c (p) at iteration n and the error (q) at the iteration n-1. c if the product p*q is positive b is increased by 0.1 c zero b is unchanged c negative b is decreased by 0.1 c b is between 0.1 and 0.9 c a = 1. - b c ** at the end makes q=p c implicit double precision (a-h,o-z) if (p*q) 11,31,21 11 if (b .ge. 0.2D0) b = b - 0.1D0 go to 31 21 if (b .le. 0.8D0) b = b + 0.1D0 31 a = 1.0D0 - b q=p return end double precision function cwig3j (j1,j2,j3,m1,m2,ient) c c wigner 3j coefficient for integers (ient=1) c or semiintegers (ient=2) c other arguments should be multiplied by ient c implicit double precision (a-h,o-z) save character*512 slog dimension al(32),m(12) data ini/1/,idim/31/ c c idim-1 is the largest argument of factorial in calculations c m3=-m1-m2 if (ini) 1,21,1 c c initialisation of the log's of the factorials c 1 ini=0 al(1)=0.0d 00 do 11 i=1,idim b=i 11 al(i+1)=al(i)+ log(b) 21 cwig3j=0.0d 00 if (((ient-1)*(ient-2)).ne.0) go to 101 ii=ient+ient c c test triangular inequalities, parity and maximum values of m c if (( abs(m1)+ abs(m2)).eq.0.and.mod(j1+j2+j3,ii).ne.0) go to 99 m(1)=j1+j2-j3 m(2)=j2+j3-j1 m(3)=j3+j1-j2 m(4)=j1+m1 m(5)=j1-m1 m(6)=j2+m2 m(7)=j2-m2 m(8)=j3+m3 m(9)=j3-m3 m(10)=j1+j2+j3+ient m(11)=j2-j3-m1 m(12)=j1-j3+m2 do 41 i=1,12 if (i.gt.10) go to 31 if (m(i).lt.0) go to 99 31 if (mod(m(i),ient).ne.0) go to 101 m(i)=m(i)/ient if (m(i).gt.idim) go to 101 41 continue c c calculate 3j coefficient c max0= max(m(11),m(12),0)+1 min0= min(m(1),m(5),m(6))+1 isig=1 if (mod(max0-1,2).ne.0) isig=-isig c=-al(m(10)+1) do 61 i=1,9 61 c=c+al(m(i)+1) c=c/2.0d 00 do 71 i=max0,min0 j=2-i b=al(i)+al(j+m(1))+al(j+m(5))+al(j+m(6))+al(i-m(11))+al(i-m(12)) cwig3j=cwig3j+isig* exp(c-b) 71 isig=-isig if (mod(j1-j2-m3,ii).ne.0) cwig3j=-cwig3j 99 return 101 write(slog,'(a,6i5)') 'error in cwig3j ',j1,j2,j3,m1,m2,ient call wlog(slog,1) stop end double precision function dentfa (dr,dz,ch) c c analitical approximation of potential is created for electrons in c thomas-fermi model for atom or free ion. dr distance from nucleus c with charge dz c ch=ionicity = number of electrons-dz-1 c implicit double precision (a-h,o-z) dentfa=0.0d 00 if ((dz+ch).lt.1.0d-04) return w=dr*(dz+ch)**(1.D0/3.D0) w=sqrt(w/0.8853D0) t=w*(0.60112D0*w+1.81061D0)+1.D0 w=w*(w*(w*(w*(0.04793D0*w+0.21465D0)+0.77112D0)+1.39515D0)+ 1 1.81061D0)+1D0 dentfa=(dz+ch)*(1.0d 00-(t/w)**2)/dr return end double precision function dsordf (i,j,n,jnd,a) c c * calculation of diff. integrals* c integration by simpson method of the hg*(r**n) c hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) if jnd=1 c hg=expression above multiplied by dg if jnd=-1 c hg(l)=cg(l,i)*cp(l,j) if jnd=2 c hg=expression above multiplied by dg if jnd=-2 c hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j) if jnd=3 c hg(l)=dg(l)*dg(l)+dp(l)*dp(l) if jnd=4 c hg is constructed by calling program if jnd>=5 c cg(l,i) large component of the orbital i c cp(l,j) small component of the orbital j c a is such that dg,dp or hg following the case c behave at the origin as cte*r**a c the integration is made as far as dr(j) for jnd>3 c c the development limits at the origin (used for calculation c of integral form 0 to dr(1) ) of functions dg,dp and hg are c supposed to be in blocks ag,ap and chg respectively c this program utilises aprdev c implicit double precision (a-h,o-z) common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) dimension hg(251),chg(10) common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim dimension bgi(10),bgj(10),bpi(10),bpj(10) c c construction of the array hg c if (jnd.le.3) go to 11 max0=j b=a go to 101 11 max0= min(nmax(i),nmax(j)) do 15 l= 1,ibgp bgi(l) = bg(l,i) bgj(l) = bg(l,j) bpi(l) = bp(l,i) 15 bpj(l) = bp(l,j) if ( abs(jnd)-2) 21,55,101 21 do 31 l=1,max0 31 hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) do 45 l=1,ndor 45 chg(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l) go to 81 55 do 61 l=1,max0 61 hg(l)=cg(l,i)*cp(l,j) do 71 l=1,ndor 71 chg(l)=aprdev(bgi,bpj,l) 81 b=fl(i)+fl(j) if (jnd.gt.0) go to 301 do 85 l=1,max0 85 hg(l)=hg(l)*dg(l) do 87 l=1,ndor 87 ap(l)=chg(l) b=b+a do 95 l=1,ndor 95 chg(l)=aprdev(ap,ag,l) go to 301 101 if (jnd-4) 201,111,301 111 do 121 l=1,max0 121 hg(l)=dg(l)*dg(l)+dp(l)*dp(l) b=b+b do 131 l=1,ndor 131 chg(l)=aprdev(ag,ag,l)+aprdev(ap,ap,l) go to 301 201 do 221 l=1,max0 221 hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j) b=a+fl(i) do 241 l=1,ndor 241 chg(l)=aprdev(bgi,ag,l)+aprdev(bpj,ap,l) c c integration of the hg c 301 dsordf=0.0d 00 io=n+1 do 305 l=1,max0 305 hg(l)=hg(l)*(dr(l)**io) do 311 l=2,max0,2 311 dsordf=dsordf+hg(l)+hg(l)+hg(l+1) dsordf=hx*(dsordf+dsordf+hg(1)-hg(max0))/3.0d 00 c c integral from 0 to dr(1) c b=b+n do 331 l=1,ndor b=b+1.0d 00 331 dsordf=dsordf+chg(l)*(dr(1)**b)/b return end subroutine etotal (kap,xnel,en,iprint,eatom) c c combined from original subroutines tabfgk,tabbre,tabrat. c kap quantique number "kappa" c xnel occupation of orbitales (can be fractional) c en one-electron energies c fdrirk function calculating radial integrals rk c akeato angular coefficient for integrals fk, for the c integrals fk(i;i) gives angular coefficients multiplied by 2 c bkeato angular coefficient for integrals gk c coul ener(1) direct coulomb interaction c ech ener(2) exchange coulomb interaction c * average value of the breit hamiltonian * c fdrocc function of the orbitals' occupations. c bkmrdf is a programm to calculate angular coefficients c ema ener(3) magnetic energy c ere ener(4) retardation term c sous programmes utilises akeato,bkeato c fdrocc fdrirk bkmrdf c implicit double precision (a-h,o-z) dimension kap(30),xnel(30),en(30) common/itescf/testy,rap(2),teste,nz,norb,norbsc dimension ener(4) dimension cer(17) common/tabre/cmag(3),cret(3) common/inelma/nem character*4 iner(4) character*512 slog data iner/'coul','ech.','mag.','ret.'/ do 10 i = 1,4 10 ener(i)=0.0d 00 iv=0 c c fk integrales c do 40 i=1,norb l= abs(kap(i))-1 do 40 j=1,i a=1.0d 00 if (j.eq.i) a=a+a m= abs(kap(j))-1 kmi=2* min(l,m) k=0 20 iv=iv+1 cer(iv)=fdrirk(i,i,j,j,k) ener(1)=ener(1)+cer(iv)*akeato(i,j,k)/a if (iv.lt.3) go to 30 iv=0 30 k=k+2 if (k.le.kmi) go to 20 40 continue iv=0 if (norb.gt.1) then c c gk integrales c do 70 i=2,norb i1=i-1 do 70 j=1,i1 l= abs(kap(i)) m= abs(kap(j)) k= abs(l-m) if ((kap(i)*kap(j)).lt.0) k=k+1 kmi=l+m-1 50 iv=iv+1 cer(iv)=fdrirk(i,j,i,j,k) ener(2) = ener(2) -cer(iv)*bkeato(i,j,k) if (iv.lt.3) go to 60 iv=0 60 k=k+2 if (k.le.kmi) go to 50 70 continue endif c nem=1 c c direct integrales c ik=0 do 140 j=1,norb jj=2* abs(kap(j))-1 do 140 i=1,j ji=2* abs(kap(i))-1 k=1 kma= min(ji,jj) 110 ik=ik+1 cer(ik)=fdrirk(j,j,i,i,k) if (i.ne.j) go to 120 call bkmrdf (j,j,k) ener(3)=ener(3)+(cmag(1)+cmag(2)+cmag(3))*cer(ik)* 1 fdmocc(j,j)/2.0d 00 120 if (ik.lt.3) go to 130 ik=0 130 k=k+2 if (k.le.kma) go to 110 140 continue if (norb.gt.1) then c c exchange integrales c do 201 j=2,norb lj= abs(kap(j)) na=-1 if (kap(j).gt.0) go to 121 na=-na lj=lj-1 121 jp=j-1 do 201 l=1,jp ll= abs(kap(l)) nb=-1 if (kap(l).gt.0) go to 131 nb=-nb ll=ll-1 131 b=fdmocc(j,l) nm1= abs(lj+na-ll) nmp1=ll+lj+nb nmm1=ll+lj+na np1= abs(ll+nb-lj) k= min(nm1,np1) kma=max(nmp1,nmm1) if (mod(k+ll+lj,2).eq.0) k=k+1 nb= abs(kap(j))+ abs(kap(l)) 141 call bkmrdf (j,l,k) do 151 i=1,3 151 cer(i)=0.0d 00 if (nb.le.k.and.kap(l).lt.0.and.kap(j).gt.0) go to 161 cer(1)=fdrirk(l,j,l,j,k) cer(2)=fdrirk(0,0,j,l,k) 161 if (nb.le.k.and.kap(l).gt.0.and.kap(j).lt.0) go to 171 cer(3)=fdrirk(j,l,j,l,k) if (cer(2).ne.0.0d 00) go to 171 cer(2)=fdrirk(0,0,l,j,k) 171 do 185 i=1,3 ener(3) =ener(3) +cmag(i)*cer(i)*b 185 ener(4) =ener(4) +cret(i)*cer(i)*b k=k+2 if (k.le.kma) go to 141 201 continue endif c c total energy c eatom = -(ener(1)+ener(2))+ener(3)+ener(4) do 212 j=1,norb 212 eatom = eatom + en(j)*xnel(j) if (iprint .ge. 1) write(16,'(a,1pd18.7)') 'etot',eatom write(slog,'(a,1pd18.7)') 'etot',eatom call wlog(slog,0) do 215 i=1,4 if (iprint .ge. 1) write(16,'(a4,1pd18.7)') iner(i),ener(i) write(slog,'(a4,1pd18.7)') iner(i),ener(i) 215 call wlog(slog,0) return end c double precision function fdmocc (i,j) c c product of the occupation numbers of the orbitals i and j c implicit double precision (a-h,o-z) common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) if (j.eq.i) then fdmocc=xnel(i)*(xnel(j)-1) a=2* abs(kap(i)) fdmocc=fdmocc*a/(a-1.0D0) else fdmocc=xnel(i)*xnel(j) endif return end c double precision function fdrirk (i,j,l,m,k) c c * calculate radial integrales rk * c rk = integral of f(r) * uk(r,s) * g(s) c uk(r,s) = rinf**k / rsup**(k+1) rinf=min(r,s) rsup=max(r,s) c if nem=0 f(.)=cg(.,i)*cg(.,j)+cp(.,i)*cp(.,j) c g(.)=cg(.,l)*cg(.,m)+cp(.,l)*cp(.,m) c if nem non zero f(.)=cg(.,i)*cp(.,j) c g(.)=cg(.,l)*cp(.,m) c cg (cp) large (small) componenents of the orbitales c moreover if nem > or =0 the integration is made from 0 to infinity, c and otherwise from 0 to r. c this programm uses yzkrdf and dsordf c implicit double precision (a-h,o-z) common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) c c comdir is used just to exchange variables between dsordf,yzkrdf,fdrirk c dimension hg(251) common/inelma/nem common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim save fdrirk=0.0d 00 if (i.le.0.or.j.le.0) go to 201 call yzkrdf (i,j,k) nn= abs(kap(i))+ abs(kap(j)) nn=max(nn-k,1) a=k+1 do 21 n=1,ndor 21 hg(n)=0.0d 00 do 31 n=1,ndor if (nn.gt.ndor) go to 31 hg(nn)=-ag(n) 31 nn=nn+1 do 41 n=1,ndor 41 ag(n)=hg(n) ag(1)=ag(1)+ap(1) 201 if (l.le.0.or.m.le.0) return n=-1 if (nem.ne.0) n=-2 fdrirk=dsordf(l,m,-1,n,a) return end c subroutine getorb (iz, ihole, xion, norb, norbco, 1 iholep, den, nqn, nk, xnel, xnval) c c Gets orbital data for chosen element. Input is iz, atomic number c of desired element, other arguments are output. c Feel free to change occupation numbers for element of interest. c ival(i) is necessary only for partly nonlocal exchange model. c iocc(i) and ival(i) can be fractional c But you have to keep the sum of iocc(i) equal to nuclear charge. c Also ival(i) should be equal to iocc(i) or zero. c Otherwise you have to change this subroutine or contact authors c for help. c implicit double precision (a-h, o-z) c c Written by Steven Zabinsky, July 1989 c modified (20 aug 1989) table increased to at no 97 c Recipe for final state configuration is changed. Valence c electron occupations are added. ala 17.1.1996 c Table for each element has occupation of the various levels. c The order of the levels in each array is: c element level principal qn (nqn), kappa qn (nk) c 1 1s 1 -1 c 2 2s 2 -1 c 3 2p1/2 2 1 c 4 2p3/2 2 -2 c 5 3s 3 -1 c 6 3p1/2 3 1 c 7 3p3/2 3 -2 c 8 3d3/2 3 2 c 9 3d5/2 3 -3 c 10 4s 4 -1 c 11 4p1/2 4 1 c 12 4p3/2 4 -2 c 13 4d3/2 4 2 c 14 4d5/2 4 -3 c 15 4f5/2 4 3 c 16 4f7/2 4 -4 c 17 5s 5 -1 c 18 5p1/2 5 1 c 19 5p3/2 5 -2 c 20 5d3/2 5 2 c 21 5d5/2 5 -3 c 22 5f5/2 5 3 c 23 5f7/2 5 -4 c 24 6s 6 -1 c 25 6p1/2 6 1 c 26 6p3/2 6 -2 c 27 6d3/2 6 2 c 28 6d5/2 6 -3 c 29 7s 7 -1 c dimension den(30), nqn(30), nk(30), xnel(30), xnval(30) dimension kappa (29) real iocc, ival dimension iocc (97, 29), ival (97, 29) dimension nnum (29) character*512 slog c c kappa quantum number for each orbital c k = - (j + 1/2) if l = j - 1/2 c k = + (j + 1/2) if l = j + 1/2 c data kappa /-1,-1, 1,-2,-1, 1,-2, 2,-3,-1, 1,-2, 2,-3, 3, 1 -4,-1, 1,-2, 2, -3, 3,-4,-1, 1, -2, 2,-3,-1/ c c principal quantum number (energy eigenvalue) c data nnum /1,2,2,2,3, 3,3,3,3,4, 4,4,4,4,4, 1 4,5,5,5,5, 5,5,5,6,6, 6,6,6,7/ c c occupation of each level for z = 1, 97 c data (iocc( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 1,i),i=1,29) /1,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 2,i),i=1,29) /2,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 3,i),i=1,29) /2,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 3,i),i=1,29) /0,1,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 4,i),i=1,29) /2,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 4,i),i=1,29) /0,2,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 5,i),i=1,29) /2,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 5,i),i=1,29) /0,2,1,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 6,i),i=1,29) /2,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 6,i),i=1,29) /0,2,2,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 7,i),i=1,29) /2,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 7,i),i=1,29) /0,2,2,1,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 8,i),i=1,29) /2,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 8,i),i=1,29) /0,2,2,2,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc( 9,i),i=1,29) /2,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival( 9,i),i=1,29) /0,2,2,3,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(10,i),i=1,29) /2,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(10,i),i=1,29) /0,2,2,4,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(11,i),i=1,29) /2,2,2,4,1, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(11,i),i=1,29) /0,0,0,0,1, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(12,i),i=1,29) /2,2,2,4,2, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(12,i),i=1,29) /0,0,0,0,2, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(13,i),i=1,29) /2,2,2,4,2, 1,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(13,i),i=1,29) /0,0,0,0,2, 1,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(14,i),i=1,29) /2,2,2,4,2, 2,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(14,i),i=1,29) /0,0,0,0,2, 2,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(15,i),i=1,29) /2,2,2,4,2, 2,1,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(15,i),i=1,29) /0,0,0,0,2, 2,1,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(16,i),i=1,29) /2,2,2,4,2, 2,2,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(16,i),i=1,29) /0,0,0,0,2, 2,2,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(17,i),i=1,29) /2,2,2,4,2, 2,3,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(17,i),i=1,29) /0,0,0,0,2, 2,3,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(18,i),i=1,29) /2,2,2,4,2, 2,4,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(18,i),i=1,29) /0,0,0,0,2, 2,4,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(19,i),i=1,29) /2,2,2,4,2, 2,4,0,0,1, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(19,i),i=1,29) /0,0,0,0,0, 0,0,0,0,1, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(20,i),i=1,29) /2,2,2,4,2, 2,4,0,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(20,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(21,i),i=1,29) /2,2,2,4,2, 2,4,1,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(21,i),i=1,29) /0,0,0,0,0, 0,0,1,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(22,i),i=1,29) /2,2,2,4,2, 2,4,2,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(22,i),i=1,29) /0,0,0,0,0, 0,0,2,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(23,i),i=1,29) /2,2,2,4,2, 2,4,3,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(23,i),i=1,29) /0,0,0,0,0, 0,0,3,0,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(24,i),i=1,29) /2,2,2,4,2, 2,4,4,1,1, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(24,i),i=1,29) /0,0,0,0,0, 0,0,4,1,1, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(25,i),i=1,29) /2,2,2,4,2, 2,4,4,1,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(25,i),i=1,29) /0,0,0,0,0, 0,0,4,1,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(26,i),i=1,29) /2,2,2,4,2, 2,4,4,2,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(26,i),i=1,29) /0,0,0,0,0, 0,0,4,2,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(27,i),i=1,29) /2,2,2,4,2, 2,4,4,3,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(27,i),i=1,29) /0,0,0,0,0, 0,0,4,3,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(28,i),i=1,29) /2,2,2,4,2, 2,4,4,4,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(28,i),i=1,29) /0,0,0,0,0, 0,0,4,4,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(29,i),i=1,29) /2,2,2,4,2, 2,4,4,6,1, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(29,i),i=1,29) /0,0,0,0,0, 0,0,4,6,1, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(30,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(30,i),i=1,29) /0,0,0,0,0, 0,0,4,6,2, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(31,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 1,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(31,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 1,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(32,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(32,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(33,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,1,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(33,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,1,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(34,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,2,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(34,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,2,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(35,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,3,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(35,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,3,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(36,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(36,i),i=1,29) /0,0,0,0,0, 0,0,0,0,2, 2,4,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(37,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(37,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(38,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,0,0,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(38,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(39,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,1,0,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(39,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,1,0,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(40,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,2,0,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(40,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,2,0,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(41,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,0,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(41,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,0,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(42,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(42,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,1,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(43,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,1,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(43,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,1,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(44,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,3,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(44,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,3,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(45,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,4,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(45,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,4,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(46,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(46,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(47,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(47,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, 1 0,1,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(48,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(48,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,4,6,0, 1 0,2,0,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(49,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(49,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,1,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(50,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ data (ival(50,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,2,0,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(51,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ data (ival(51,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,2,1,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(52,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ data (ival(52,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,2,2,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(53,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ data (ival(53,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,2,3,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(54,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ data (ival(54,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,2,2,4,0, 0,0,0,0,0, 0,0,0,0/ data (iocc(55,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,4,0, 0,0,0,1,0, 0,0,0,0/ data (ival(55,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,1,0, 0,0,0,0/ data (iocc(56,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(56,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(57,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,0, 1 0,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ data (ival(57,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ data (iocc(58,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,2, 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(58,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,2, 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(59,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,3, 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(59,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,3, 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(60,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,4, 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(60,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,4, 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(61,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,5, 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(61,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,5, 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(62,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 0,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(62,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 0,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(63,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 1,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(63,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 1,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(64,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 1,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ data (ival(64,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 1,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ data (iocc(65,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 3,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(65,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 3,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(66,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 4,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(66,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 4,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(67,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 5,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(67,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 5,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(68,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 6,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(68,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 6,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(69,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 7,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(69,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 7,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(70,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,0, 0,0,0,2,0, 0,0,0,0/ data (ival(70,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,6, 1 8,0,0,0,0, 0,0,0,2,0, 0,0,0,0/ data (iocc(71,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,1, 0,0,0,2,0, 0,0,0,0/ data (ival(71,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,1, 0,0,0,2,0, 0,0,0,0/ data (iocc(72,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,2, 0,0,0,2,0, 0,0,0,0/ data (ival(72,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,2, 0,0,0,2,0, 0,0,0,0/ data (iocc(73,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,3, 0,0,0,2,0, 0,0,0,0/ data (ival(73,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,3, 0,0,0,2,0, 0,0,0,0/ data (iocc(74,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 0,0,0,2,0, 0,0,0,0/ data (ival(74,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 0,0,0,2,0, 0,0,0,0/ data (iocc(75,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 1,0,0,2,0, 0,0,0,0/ data (ival(75,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 1,0,0,2,0, 0,0,0,0/ data (iocc(76,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 2,0,0,2,0, 0,0,0,0/ data (ival(76,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 2,0,0,2,0, 0,0,0,0/ data (iocc(77,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 3,0,0,2,0, 0,0,0,0/ data (ival(77,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 3,0,0,2,0, 0,0,0,0/ data (iocc(78,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 5,0,0,1,0, 0,0,0,0/ data (ival(78,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 5,0,0,1,0, 0,0,0,0/ data (iocc(79,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,1,0, 0,0,0,0/ data (ival(79,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 6,0,0,1,0, 0,0,0,0/ data (iocc(80,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,0, 0,0,0,0/ data (ival(80,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,4, 6,0,0,2,0, 0,0,0,0/ data (iocc(81,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,1, 0,0,0,0/ data (ival(81,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,1, 0,0,0,0/ data (iocc(82,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 0,0,0,0/ data (ival(82,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,2, 0,0,0,0/ data (iocc(83,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 1,0,0,0/ data (ival(83,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,2, 1,0,0,0/ data (iocc(84,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 2,0,0,0/ data (ival(84,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,2, 2,0,0,0/ data (iocc(85,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 3,0,0,0/ data (ival(85,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,2, 3,0,0,0/ data (iocc(86,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,0/ data (ival(86,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,2,2, 4,0,0,0/ data (iocc(87,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,1/ data (ival(87,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,1/ data (iocc(88,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 4,0,0,2/ data (ival(88,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,0,0,2/ data (iocc(89,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 4,1,0,2/ data (ival(89,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,1,0,2/ data (iocc(90,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,0,0,2,2, 4,2,0,2/ data (ival(90,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,0,0,0,0, 0,2,0,2/ data (iocc(91,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,2,0,2,2, 4,1,0,2/ data (ival(91,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,2,0,0,0, 0,1,0,2/ data (iocc(92,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,3,0,2,2, 4,1,0,2/ data (ival(92,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,3,0,0,0, 0,1,0,2/ data (iocc(93,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,4,0,2,2, 4,1,0,2/ data (ival(93,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,4,0,0,0, 0,1,0,2/ data (iocc(94,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,6,0,2,2, 4,0,0,2/ data (ival(94,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,6,0,0,0, 0,0,0,2/ data (iocc(95,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,6,1,2,2, 4,0,0,2/ data (ival(95,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,6,1,0,0, 0,0,0,2/ data (iocc(96,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,6,2,2,2, 4,0,0,2/ data (ival(96,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,6,2,0,0, 0,0,0,2/ data (iocc(97,i),i=1,29) /2,2,2,4,2, 2,4,4,6,2, 2,4,4,6,6, 1 8,2,2,4,4, 6,6,3,2,2, 4,0,0,2/ data (ival(97,i),i=1,29) /0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 1 0,0,0,0,0, 0,6,3,0,0, 0,0,0,2/ if (iz .lt. 1 .or. iz .ge. 97) then 8 format(' Atomic number ', i5, ' not available.') write(slog,8) iz call wlog(slog,1) stop endif ion = nint(xion) delion=xion-ion index = iz - ion ilast = 0 iscr = 0 iion = 0 iholep = ihole c c find last occupied orbital (ilast) and iion for delion.ge.0 c do 30 i=29,1,-1 if (iion.eq.0 .and. dble(iocc(index,i)).gt.delion) iion=i if (ilast.eq.0 .and. iocc(index,i).gt.0) ilast=i 30 continue c open(unit=91,file='getorbtuo.dat',status='unknown') c iz=29 if (ihole.eq.0) go to 11 if (ihole.gt.0 .and. iocc(index,ihole) .lt. 1 .or. 1 (ihole.eq.ilast .and. iocc(index,ihole)-real(delion).lt.1) ) then c call wlog(' Cannot remove an electron from this level',1) write(6,*)' Cannot remove an electron from level =', ihole write(6,*) ' stop in getorb ' stop 'GETORB-1' endif 11 continue c c the recipe for final state atomic configuration is changed c from iz+1 prescription, since sometimes it changed occupation c numbers in more than two orbitals. This could be consistent c only with s02=0.0. New recipe remedy this deficiency. c c find where to put screening electron c index1 = index + 1 do 10 i = 1, 29 10 if (iscr.eq.0 .and. (iocc(index1,i)-iocc(index,i)).gt.0.5) iscr=i c c special case of hydrogen like ion c if (index.eq.1) iscr=2 c c find where to add or subtract charge delion (iion). c if (delion .ge. 0) then c removal of electron charge c iion is already found c if (delion .lt. 0) then c c addition of electron charge c iion = iscr c c except special cases c if (ihole.ne.0 .and. 1 iocc(index,iscr)+1-real(delion).gt.2*abs(kappa(iscr))) then iion = ilast if (ilast.eq.iscr .or. iocc(index,ilast)-real(delion).gt. 1 2*abs(kappa(ilast)) ) iion = ilast + 1 endif endif norb = 0 do 20 i = 1, 29 if (iocc(index,i).gt.0 .or. (i.eq.iscr .and. ihole.gt.0) 1 .or. (i.eq.iion .and. iocc(index,i)-real(delion).gt.0)) then if (i.ne.ihole .or. iocc(index,i).ge.1) then norb = norb + 1 nqn(norb) = nnum(i) nk(norb) = kappa(i) xnel(norb) = dble(iocc(index,i)) if (i.eq.ihole) then xnel(norb) = xnel(norb) - 1 iholep = norb endif if (i.eq.iscr .and. ihole.gt.0) xnel(norb)=xnel(norb)+1 xnval(norb)= dble(ival(index,i)) if (i.eq.ihole .and. xnval(norb).ge.1) 1 xnval(norb) = xnval(norb) - 1 if (i.eq.iscr .and. ihole.gt.0) 1 xnval(norb) = xnval(norb) + 1 if (i.eq.iion) xnel(norb) = xnel(norb) - delion if (i.eq.iion) xnval(norb) = xnval(norb) - delion den(norb) = 0.0D0 endif endif 20 continue norbco = norb c c check that all occupation numbers are within limits c do 50 i = 1, norb if ( xnel(i).lt.0 .or. xnel(i).gt.2*abs(nk(i)) .or. 1 xnval(i).lt.0 .or. xnval(i).gt.2*abs(nk(i)) ) then write (slog,55) i 55 format(' error in getorb.f. Check occupation number for ', 1 i3, '-th orbital. May be a problem with ionicity.') call wlog(slog,1) stop endif 50 continue c do 60 i=1,norb c60 xnval(i) = 0.0d0 c60 xnval(i) = xnel(i) return end subroutine inmuat (ihole, xionin) implicit double precision (a-h,o-z) common/itescf/testy,rap(2),teste,nz,norb,norbsc c the meaning of common variables is described below common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) c dimension xnval(30) c c en one-electron energies c scc factors for acceleration of convergence c scw precisions of wave functions c sce precisions of one-electron energies c nmax number of tabulation points for orbitals c common/scrhf1/eps(435),nre(30),ipl c c eps non diagonal lagrange parameters c nre distingue: - the shell is closed (nre <0) c the shell is open (nre>0) c - the orbitals in the integral rk if abs(nre) > or =2 c ipl define the existence of lagrange parameters (ipl>0) c common/snoyau/dvn(251),anoy(10),nuc c c dvn nuclear potential c anoy development coefficients at the origin of nuclear potential c this development is supposed to be written anoy(i)*r**(i-1) c nuc index of nuclear radius (nuc=1 for point charge) c common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim data ideps/435/ ndor=10 call getorb( nz, ihole, xionin, norb, norbsc, 1 iholep, en, nq, kap, xnel, xnval) xk=0 do 411 i=1,norb 411 xk=xk+xnel(i) if ( abs(nz-xionin-xk) .gt. 0.001D0) then call wlog('check number of electrons in getorb.f',1) stop endif norbsc=norb c c nz atomic number noi ionicity (nz-number of electrons) c norb number of orbitals c xnel(i) number of electrons on orbital i. c first norbsc orbitals will be determined selfconsistently, c the rest of orbitals are orthogonolized if iorth is non null, c and their energies are those on cards if iene is non null c or otherwise are the values obtained from solving dirac equation c nes number of attempts in program soldir c nuc number of points inside nucleus (11 by default) c do 171 i=1,ideps 171 eps(i)=0.0d 00 idim = 251 if (mod(idim,2) .eq. 0) idim=idim-1 ipl=0 c c ipl=0 means no orbitals with the same kappa and no c orthogonalization needed. Thus it will remain zero only c for hydrogen atom. c do 401 i=1,norb nre(i)=-1 llq= abs(kap(i)) l=llq+llq if (kap(i).lt.0) llq=llq-1 if (llq.lt.0.or.llq.ge.nq(i).or.llq.gt.3) then call wlog('kappa out of range, check getorb.f',1) stop endif nmax(i)=idim scc(i)=0.3d0 if (xnel(i) .lt. l) nre(i)=1 do 385 j=1,i-1 if (kap(j).ne.kap(i)) go to 385 if (nre(j).gt.0.or.nre(i).gt.0) ipl=ipl+1 385 continue 401 continue return end c subroutine intdir(gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0) c c solution of the inhomogenios dirac equation c gg gp initially exchage terms, at the time of return - wave functions c ag and ap development coefficients of gg and gp c ggmat gpmat values at the matching point for the inward integration c en one-electron energy c fl power of the first development term at the origin c agi (api) initial values of the first development coefficients c at the origin of a large (small) component c ainf initial value for large component at point dr(max0) c - at the end of tabulation of gg gp c implicit double precision (a-h,o-z) save common/comdir/cl,dz,bid1(522),dv(251),av(10),bid2(522) common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim common/subdir/ell,fk,ccl,imm,nd,node,mat common/messag/dlabpr,numerr character*8 dlabpr dimension gg(251),gp(251),ag(10),ap(10),coc(5),cop(5),dg(5),dp(5) data cop/2.51d+02,-1.274d+03,2.616d+03,-2.774d+03,1.901d+03/, 1coc/-1.9d+01,1.06d+02,-2.64d+02,6.46d+02,2.51d+02/, 2cmixn/4.73d+02/,cmixd/5.02d+02/,hxd/7.2d+02/,npi/5/,icall/0/ c c numerical method is a 5-point predictor-corrector method c predicted value p(n) = y(n-1) + c * somme de i=1,5 cop(i)*y'(n-i) c corrected value c(n) = y(n-1) + c * somme de i=1,4 coc(i)*y'(n-i) c + coc(5)*p'(n) c final value y(n) = cmix*c(n) + (1.-cmix)*p(n) c cmix=cmixn/cmixd c if (icall.eq.0) then icall=1 c=cmixn/cmixd a=1.0d 00-c cmc=c*coc(5) f=coc(1) do 1 j=2,npi g=coc(j) coc(j)=c*f+a*cop(j) 1 f=g coc(1)=c*cop(1) endif c=hx/hxd ec=en/cl ag(1)=agi ap(1)=api if (imm) 81,15,26 c c search for the second sign change point c 15 mat=npi j=1 16 mat=mat+2 if (mat.ge.np) then c c i had trouble with screened k-hole for la, for f-electrons. c below i still define matching point if one electron energy is c not less than -1ev. ala, january 1995 c if (ec .gt. -0.0003D0) then mat = np - 12 go to 25 endif numerr=56011 c c * fail to find matching point c if you got this error with fractional ionicity, try c slightly different.(xion=xion+0.01) c return endif f=dv(mat)+ell/(dr(mat)*dr(mat)) f=(f-ec)*j if (f) 25,25,16 25 j=-j if (j.lt.0) go to 16 if (mat .ge. np-npi) mat=np-12 c c initial values for the outward integration c 26 do 35 j=2,ndor k=j-1 a=fl+fk+k b=fl-fk+k ep=a*b+av(1)*av(1) f=(ec+ccl)*ap(k)+ap(j) g=ec*ag(k)+ag(j) do 31 i=1,k f=f-av(i+1)*ap(j-i) 31 g=g-av(i+1)*ag(j-i) ag(j)=(b*f+av(1)*g)/ep 35 ap(j)=(av(1)*f-a*g)/ep do 41 i=1,npi gg(i)=0.0d 00 gp(i)=0.0d 00 dg(i)=0.0d 00 dp(i)=0.0d 00 do 41 j=1,ndor a=fl+j-1 b=dr(i)**a a=a*b*c gg(i)=gg(i)+b*ag(j) gp(i)=gp(i)+b*ap(j) dg(i)=dg(i)+a*ag(j) 41 dp(i)=dp(i)+a*ap(j) i=npi k=1 ggmat=gg(mat) gpmat=gp(mat) c c integration of the inhomogenious system c 51 cmcc=cmc*c 55 continue a=gg(i)+dg(1)*cop(1) b=gp(i)+dp(1)*cop(1) i=i+k ep=gp(i) eg=gg(i) gg(i)=a-dg(1)*coc(1) gp(i)=b-dp(1)*coc(1) do 61 j=2,npi a=a+dg(j)*cop(j) b=b+dp(j)*cop(j) gg(i)=gg(i)+dg(j)*coc(j) gp(i)=gp(i)+dp(j)*coc(j) dg(j-1)=dg(j) 61 dp(j-1)=dp(j) f=(ec-dv(i))*dr(i) g=f+ccl*dr(i) gg(i)=gg(i)+cmcc*(g*b-fk*a+ep) gp(i)=gp(i)+cmcc*(fk*b-f*a-eg) dg(npi)=c*(g*gp(i)-fk*gg(i)+ep) dp(npi)=c*(fk*gp(i)-f*gg(i)-eg) if (i.ne.mat) go to 55 if (k.lt.0) go to 999 a=ggmat ggmat=gg(mat) gg(mat)=a a=gpmat gpmat=gp(mat) gp(mat)=a if (imm.ne.0) go to 81 c c initial values for inward integration c a=test1* abs(ggmat) if (ainf.gt.a) ainf=a max0=np+2 73 a=7.0d+02/cl 75 max0=max0-2 if ((max0+1).le.(mat+npi)) then numerr=138021 c c *the last tabulation point is too close to the matching point c return endif if (((dv(max0)-ec)*dr(max0)*dr(max0)).gt.a) go to 75 81 c=-c a=- sqrt(-ec*(ccl+ec)) if ((a*dr(max0)).lt.-1.7d+02) go to 73 b=a/(ccl+ec) f=ainf/ exp(a*dr(max0)) if (f.eq.0.0d 00) f=1.0d 00 do 91 i=1,npi j=max0+1-i gg(j)=f* exp(a*dr(j)) gp(j)=b*gg(j) dg(i)=a*dr(j)*gg(j)*c 91 dp(i)=b*dg(i) i=max0-npi+1 k=-1 go to 51 999 return end c subroutine lagdat (ia,iex) c c * non diagonal lagrange parameteres * c lagrange parameters involving orbital ia if ia is positive c all lagrange parameters are calculated if ia is negative or zero c contribution of the exchange terms is omitted if iex=0 c this program uses akeato(bkeato) fdrirk multrk c implicit double precision (a-h,o-z) common/itescf/testy,rap(2),teste,nz,norb,norbsc common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1 nq(30),kap(30),nmax(30) common/scrhf1/eps(435),nre(30),ipl i1= max(ia,1) idep=1 if (ia.gt.0) go to 15 11 idep=i1+1 15 ji1=2* abs(kap(i1))-1 do 201 i2=idep,norbsc if (i2.eq.i1.or.kap(i2).ne.kap(i1)) go to 201 if (nre(i1).lt.0.and.nre(i2).lt.0) go to 201 c c the following line was included to handle the case of single c electron in 2 s-shells c probably need to use schmidt orthogonalization in this case c if (xnel(i1).eq.xnel(i2)) go to 201 d=0.0d 00 do 101 l=1,norbsc k=0 jjl=2* abs(kap(l))-1 kma= min(ji1,jjl) 41 a=akeato(l,i1,k)/xnel(i1) b=a-akeato(l,i2,k)/xnel(i2) c=b if (a.ne.0.0d 00) c=c/a if ( abs(c).lt.1.0d-07) go to 51 d=d+b*fdrirk(l,l,i1,i2,k) 51 k=k+2 if (k.le.kma) go to 41 if (iex.eq.0) go to 101 kma=(ji1+jjl)/2 k= abs(jjl-kma) if ((kap(i1)*kap(l)).lt.0) k=k+1 61 a=bkeato(l,i2,k)/xnel(i2) b=a-bkeato(l,i1,k)/xnel(i1) c=b if (a.ne.0.0d 00) c=c/a if ( abs(c).lt.1.0d-07) go to 71 d=d+b*fdrirk(i1,l,i2,l,k) 71 k=k+2 if (k.le.kma) go to 61 101 continue i= min(i1,i2) j= max(i1,i2) eps(i+((j-1)*(j-2))/2)=d/(xnel(i2)-xnel(i1)) 201 continue if (ia.gt.0) go to 999 i1=i1+1 if (i1.lt.norbsc) go to 11 999 return end c subroutine messer c c prints error message on the output device c implicit double precision (a-h,o-z) common/messag/dlabpr,numerr character*8 dlabpr character*512 slog ilig=numerr/1000 ier=numerr-1000*ilig write(slog,'(a,i6,a,i6,a,a8)') 'error number ',ier, 1 ' detected on a line ',ilig,'in the program',dlabpr call wlog(slog,1) return end c subroutine muatco c c * angular coefficients * c sous programmes utilises cwig3j c implicit double precision (a-h,o-z) common/itescf/testy,rap(2),teste,nz,norb,norbsc common/mulabk/afgk dimension afgk(30,30,0:3) common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) do 511 i=1,30 do 511 j=1,30 do 511 k=0,3 511 afgk(i,j,k)=0.0d 00 do 701 i=1,norb li= abs(kap(i))*2-1 do 701 j=1,i lj= abs(kap(j))*2-1 kmax=(li+lj)/2 kmin= abs(li-lj)/2 if ((kap(i)*kap(j)).lt.0) kmin=kmin+1 c c calculate a_k(i,j) c m=0 if (j.eq.i) m=1 afgk(j,i,0)=afgk(j,i,0)+xnel(i)*(xnel(j)-m) c c calculate b_k(i,j) c b=afgk(j,i,0) if (j.eq.i) then a=li b=-b*(a+1.0d 00)/a kmin = kmin+2 endif do 675 k = kmin, kmax,2 afgk(i,j,k/2)=b*(cwig3j(li,k*2,lj,1,0,2)**2) 675 continue 701 continue return end c subroutine nucdev (a,epai,av,dr,dv,dz,hx,nuc,np,ndor,dr1) c c * construction of nuclear potential * c a atomic mass (negative or null for the point charge) c epai parameter of the fermi density distribution c (negative or null for uniform distribution), which is c cte / (1. + exp((r-rn)/epai) ) c with nuclear radius rn= 2.2677e-05 * (a**(1/3)) c av coefficients of the development at the origin of nuclear potential c dr tabulation points c dv nuclear potential c dz nuclear charge c hx exponential step c nuc index of the nuclear radius c np number of tabulation points c ndor number of the coefficients for development at the origin c the declared below arguments are saved, dr1 is the first c implicit double precision (a-h,o-z) dimension av(10),dr(251),dv(251),at(251) c c calculate radial mesh c if (a.le.1.0d-01) then nuc=1 else c dr(nuc)=nuclear radius c a=dz*(a**(1.D0/3.D0))*2.2677d-05 b=a/ exp(hx*(nuc-1)) if (b.le.dr1) then dr1=b else c c increase value of nuc c b=log(a/dr1)/hx nuc=3+2*int(b/2.0D0) if (nuc.ge.np) stop 'dr1 too small' c c index of atomic radius larger than dimension of dr c dr1=a*exp(-(nuc-1)*hx) endif endif dr(1)=dr1/dz do 181 l=2,np 181 dr(l)=dr(1)* exp(hx*(l-1)) if (ndor.lt.5) then c c * there should be at least 5 development coefficients c call wlog('stopped in programm nucdev, ndor should be > 4.',1) stop endif c c calculate nuclear potential on calculated radial mesh c do 11 i=1,ndor 11 av(i)=0.0d 00 if (epai.le.0.0D0) then do 15 i=1,np 15 dv(i)=-dz/dr(i) if (nuc.le.1) then av(1)=-dz else av(2)=-3.0d 00*dz/(dr(nuc)+dr(nuc)) av(4)=-av(2)/(3.0d 00*dr(nuc)*dr(nuc)) l=nuc-1 do 25 i=1,l 25 dv(i)=av(2)+av(4)*dr(i)*dr(i) endif else b= exp(-dr(nuc)/epai) b=1.0d 00/(1.0d 00+b) av(4)=b av(5)=epai*b*(b-1.0d 00) if (ndor.le.5) go to 45 at(1)=1.0d 00 at(2)=1.0d 00 nf=1 do 41 i=6,ndor n=i-4 nf=n*nf dv(1)=n*at(1) n1=n+1 dv(n1)=1.0d 00 do 35 j=2,n 35 dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j) do 37 j=1,n1 m=n+1-j l=1 if (mod(j,2).eq.0) l=-l av(i)=av(i)+l*dv(j)*(b**m) 37 at(j)=dv(j) 41 av(i)=b*av(i)*(epai**n)/nf 45 do 47 i=1,np b=1.0d 00+ exp((dr(i)-dr(nuc))/epai) if ((b*av(4)).gt.1.0d+15) go to 51 dv(i)=dr(i)*dr(i)*dr(i)/b 47 l=i 51 if (l.ge.(np-1)) l=np-2 k=l+1 do 55 i=k,np 55 dv(i)=0.0d 00 at(1)=0.0d 00 at(2)=0.0d 00 k=2 do 61 i=4,ndor k=k+1 do 58 j=1,2 58 at(j)=at(j)+av(i)*(dr(j)**k)/k av(i)=av(i)/(k*(k-1)) 61 av(2)=av(2)+av(i)*(dr(1)**k) a=hx/2.4d+01 b=a*1.3d+01 k=l+1 do 71 i=3,k 71 at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1)) dv(l)=at(l) do 75 i=k,np 75 dv(i)=dv(l) e= exp(hx) c=1.0d 00/(e*e) i=l-1 83 dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e) i=i-1 if (i-1) 85,85,83 85 dv(1)=dv(3)*c+hx*(at(1)+4.0d 00*at(2)/e+at(3)*c)/3.0d 00 av(2)=(av(2)+dv(1))/dr(1) a=-dz/dv(l) do 95 i=4,ndor 95 av(i)=-a*av(i) av(2)=a*av(2) do 97 i=1,np 97 dv(i)=a*dv(i)/dr(i) endif return end c subroutine ortdat (ia) c c * orthogonalization by the schmidt procedure* c the ia orbital is orthogonalized toa all orbitals of the same c symmetry if ia is positive, otherwise all orbitals of the same c symmetry are orthogonalized c this program uses dsordf c implicit double precision (a-h,o-z) common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) c dg,ag,dp,ap are used to exchange data only with dsordf common/itescf/testy,rap(2),teste,nz,norb,norbsc common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim m=norb l= max(ia,1) if (ia.gt.0) go to 11 5 m=l l=l+1 if (l.gt.norb) go to 999 11 do 15 i=1,idim dg(i)=0.0d 00 15 dp(i)=0.0d 00 maxl=nmax(l) do 21 i=1,maxl dg(i)=cg(i,l) 21 dp(i)=cp(i,l) do 25 i=1,ndor ag(i)=bg(i,l) 25 ap(i)=bp(i,l) do 51 j=1,m if (j.eq.l.or.kap(j).ne.kap(l)) go to 51 max0=nmax(j) a=dsordf (j,j,0,3,fl(l)) do 41 i=1,max0 dg(i)=dg(i)-a*cg(i,j) 41 dp(i)=dp(i)-a*cp(i,j) do 45 i=1,ndor ag(i)=ag(i)-a*bg(i,j) 45 ap(i)=ap(i)-a*bp(i,j) maxl= max(maxl,max0) 51 continue max0= maxl nmax(l)=max0 a=dsordf (l,max0,0,4,fl(l)) a= sqrt(a) do 71 i=1,max0 cg(i,l)=dg(i)/a 71 cp(i,l)=dp(i)/a do 75 i=1,ndor bg(i,l)=ag(i)/a 75 bp(i,l)=ap(i)/a if (ia.le.0) go to 5 999 return end c subroutine potrdf (ia) c c this programm uses akeato(bkeato),aprdev,multrk,yzkrdf c implicit double precision (a-h,o-z) common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10), 2 eg(251),ceg(10),ep(251),cep(10) c dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir dimension at(251),bt(251) common/itescf/testy,rap(2),teste,nz,norb,norbsc common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/scrhf1/eps(435),nre(30),ipl common/snoyau/dvn(251),anoy(10),nuc common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim dimension bgj(10),bpj(10) do 9 i=1,ndor cep(i)=0.0d 00 ceg(i)=0.0d 00 9 av(i)=anoy(i) do 11 i=1,idim at(i)=0.0d 00 bt(i)=0.0d 00 ep(i)=0.0d 00 eg(i)=0.0d 00 11 dv(i)=0.0d 00 c c coulomb terms c jia=2* abs(kap(ia))-1 k=0 21 do 25 i=1,idim 25 dg(i)=0.0d 00 do 31 i=1,ndor 31 ag(i)=0.0d 00 max0=0 do 51 j=1,norb do 33 i = 1,10 bgj(i) = bg(i,j) 33 bpj(i) = bp(i,j) m=2* abs(kap(j))-1 if (k.gt.m) go to 51 a=akeato(ia,j,k)/xnel(ia) if (a.eq.0.0d 00) go to 51 m=nmax(j) do 35 i=1,m 35 dg(i)=dg(i)+a*(cg(i,j)*cg(i,j)+cp(i,j)*cp(i,j)) n=2* abs(kap(j))-k l=ndor+2-n if (l.le.0) go to 51 do 41 i=1,l m=n-2+i 41 ag(m)=ag(m)+a*(aprdev(bgj,bgj,i)+ 1 aprdev(bpj,bpj,i)) 51 max0= max(max0,nmax(j)) call yzkrdf (0,max0,k) do 61 i=1,ndor l=k+i+3 if (l.gt.ndor) go to 61 av(l)=av(l)-ag(i) 61 continue do 81 i=1,idim 81 dv(i)=dv(i)+dg(i) k=k+2 if (k.le.ndor) av(k)=av(k)+ap(1) if (k.lt.jia) go to 21 c c exchange terms c if (method.eq.0) go to 411 do 201 j=1,norb if (j-ia) 105,201,105 105 max0=nmax(j) jj=2* abs(kap(j))-1 kma=(jj+jia)/2 k= abs(jj-kma) if ((kap(j)*kap(ia)).lt.0) k=k+1 111 a=bkeato(j,ia,k)/xnel(ia) if (a.eq.0.0d 00) go to 151 call yzkrdf (j,ia,k) do 121 i=1,max0 eg(i)=eg(i)+a*dg(i)*cg(i,j) 121 ep(i)=ep(i)+a*dg(i)*cp(i,j) n=k+1+ abs(kap(j))- abs(kap(ia)) if (n.gt.ndor) go to 141 do 135 i=n,ndor ceg(i)=ceg(i)+bg(i+1-n,j)*a*ap(1) 135 cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1) 141 i=2* abs(kap(j))+1 if (i.gt.ndor) go to 151 do 143 i = 1,10 bgj(i) = bg(i,j) 143 bpj(i) = bp(i,j) do 145 n=i,ndor ceg(n)=ceg(n)-a*aprdev(ag,bgj,n+1-i) 145 cep(n)=cep(n)-a*aprdev(ag,bpj,n+1-i) 151 k=k+2 if (k.le.kma) go to 111 201 continue 411 if (ipl.eq.0) go to 511 do 481 j=1,norbsc if (kap(j).ne.kap(ia).or.j.eq.ia) go to 481 if (nre(j).lt.0.and.nre(ia).lt.0) go to 481 m= max(j,ia) i= min(j,ia)+((m-1)*(m-2))/2 a=eps(i)*xnel(j) max0=nmax(j) do 461 i=1,max0 at(i)=at(i)+a*cg(i,j) 461 bt(i)=bt(i)+a*cp(i,j) do 471 i=1,ndor ceg(i)=ceg(i)+bg(i,j)*a 471 cep(i)=cep(i)+bp(i,j)*a 481 continue c c addition of nuclear potential and division of potentials and c their development limits by speed of light c 511 do 527 i=1,ndor av(i)=av(i)/cl cep(i)=cep(i)/cl 527 ceg(i)=ceg(i)/cl do 531 i=1,idim dv(i)=(dv(i)/dr(i)+dvn(i))/cl ep(i)=(ep(i)+bt(i)*dr(i))/cl 531 eg(i)=(eg(i)+at(i)*dr(i))/cl return end c subroutine potslw (dv,d,dr,dpas,np) c c coulomb potential uses a 4-point integration method c dv=potential; d=density; dp=bloc de travail; dr=radial mesh c dpas=exponential step; c np=number of points c ********************************************************************** c implicit double precision (a-h,o-z) save dimension dv(251), d(251), dp(251), dr(251) das=dpas/24.0D0 do 10 i=1,np 10 dv(i)=d(i)*dr(i) dlo=exp(dpas) dlo2=dlo*dlo dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0D0*(dlo-1.0D0)) dp(1)=dv(1)/3.0D0-dp(2)/dlo2 dp(2)=dv(2)/3.0D0-dp(2)*dlo2 j=np-1 do 20 i=3,j 20 dp(i)=dp(i-1)+das*(13.0D0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1))) dp(np)=dp(j) dv(j)=dp(j) dv(np)=dp(j) do 30 i=3,j k=np+1-i 30 dv(k)=dv(k+1)/dlo+das*(13.0D0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp 1 (k-1)*dlo)) dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0D0*dp(2)/dlo+dp(3)/dlo2)/3.0D0 do 40 i=1,np 40 dv(i)=dv(i)/dr(i) return end c subroutine soldir (en,fl,agi,api,ainf,nq,kap,max0,ifail) c c resolution of the dirac equation c p' - kap*p/r = - ( en/cl-v )*g - eg/r c g' + kap*g/r = ( 2*cl+en/cl-v )*p + ep/r c at the origin v approximately is -z/(r*cl) due to the point nucleus c en one-electron energy in atomic units and negative c fl power of the first term in development at the origin c agi (api) initial values of the first development coefficient c at the origin of the large(small)component c ainf initial value for the large component at the point dr(max0) c nq principal quantum number kap quantum number kappa c max0 the last point of tabulation of the wave function c this programm uses intdir c implicit double precision (a-h,o-z) save common/comdir/cl,dz,gg(251),ag(10),gp(251),ap(10),dv(251),av(10), 2eg(251),ceg(10),ep(251),cep(10) c c gg,gp -output, dv,eg,ep - input c dimension hg(251),agh(10), 1hp(251),aph(10),bg(251),bgh(10),bp(251),bph(10) c c cl speed of light (approximately 137.037 in atomic units) c dz nuclear charge c gg (gp) large (small) component c hg,hp,bg et bp working space c dv direct potential (v) eg and ep exchange potentials c ag,ap,agh,aph,bgh,bph,av,ceg and cep are respectively the c development coefficients for gg,gp,hg,hp,bg,bp,dv,eg et ep c common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim c c hx exponential step c dr radial mesh c test1 precision for the matching the small component if method=1 c test2 precision for the normalisation if method=2 c ndor number of terms for the developments at the origin c np maximum number of the tabulation points c nes maximum number of attempts to ajust the small component c method at the initial time distinguish the homoginious (method=0) c from inhomoginious system. at the end is the index of method used. c idim dimension of the block dr c common/subdir/ell,fk,ccl,imm,nd,node,mat c c ell fk*(fk+1)/ccl fk=kap ccl=cl+cl c imm a flag for the determination of matching point c nd number of nodes found node number of nodes to be found c mat index of the matching point c common/messag/dlabpr,numerr character*8 dprlab,dlabpr, drplab c c at the time of return numerr should be zero if integration is correct, c otherwise numerr contains the number of instruction, which c indicate the sourse and reason for abnornal return. c character*512 slog c data dprlab/' soldir'/,drplab/' intdir'/ dlabpr=dprlab enav=1.0d 00 ainf= abs(ainf) ccl=cl+cl iex=method if (method.le.0) method=1 c c notice that below iex=0,1 and method=1,2 only. c this was used to simplify block structure of program. ala 11/22/94 c fk=kap if (av(1).lt.0.0d 00.and.kap.gt.0) api=-agi*(fk+fl)/av(1) if (av(1).lt.0.0d 00.and.kap.lt.0) api=-agi*av(1)/(fk-fl) ell=fk*(fk+1.0d 00)/ccl node=nq- abs(kap) if (kap.lt.0) node=node+1 emin=0.0D0 do 91 i=1,np a=(ell/(dr(i)*dr(i))+dv(i))*cl if (a.lt.emin) emin=a 91 continue if (emin .ge. 0.0D0) then numerr=75011 c c *potential is apparently positive c return endif if (en.lt.emin) en=emin*0.9d 00 edep=en 101 numerr=0 test=test1 if (method.gt.1) test=test2 einf=1.0d 00 esup=emin en=edep ies=0 nd=0 105 jes=0 106 modmat=0 imm=0 if ( abs((enav-en)/en).lt.1.0d-01) imm=1 enav=en c c integration of the inhomogenious system c 107 do 111 i=1,idim gg(i)=eg(i) 111 gp(i)=ep(i) do 115 i=2,ndor ag(i)=ceg(i-1) 115 ap(i)=cep(i-1) call intdir (gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0) if (numerr.ne.0) then dlabpr=drplab return endif if (iex.ne.0) go to 141 c c match large component for the homogenios system(method=0) c a=ggmat/gg(mat) do 135 i=mat,max0 gg(i)=a*gg(i) 135 gp(i)=a*gp(i) j=mat go to 215 c c integration of the homogenios system c 141 do 151 i=1,idim hg(i)=0.0d 00 151 hp(i)=0.0d 00 do 155 i=1,ndor agh(i)=0.0d 00 155 aph(i)=0.0d 00 imm=1 if (method.eq.1) imm=-1 call intdir (hg,hp,agh,aph,hgmat,hpmat,en,fl,agi,api,ainf,max0) c c match the large component for inhomogenious system(method=1) c a=gg(mat)-ggmat if (method.lt.2) then b=-a/hg(mat) else b=gp(mat)-gpmat ah=hpmat*hg(mat)-hgmat*hp(mat) if (ah.eq.0.0d 00) go to 263 c=(b*hg(mat)-a*hp(mat))/ah b=(b*hgmat-a*hpmat)/ah do 165 i=1,ndor ag(i)=ag(i)+c*agh(i) 165 ap(i)=ap(i)+c*aph(i) j=mat-1 do 168 i=1,j gg(i)=gg(i)+c*hg(i) 168 gp(i)=gp(i)+c*hp(i) endif do 173 i=mat,max0 gg(i)=gg(i)+b*hg(i) 173 gp(i)=gp(i)+b*hp(i) if (method.ge.2) then c c integration of the system derived from disagreement in energy c do 175 i=2,ndor bgh(i)=ag(i-1)/cl 175 bph(i)=ap(i-1)/cl do 177 i=1,max0 bg(i)=gg(i)*dr(i)/cl 177 bp(i)=gp(i)*dr(i)/cl call intdir (bg,bp,bgh,bph,bgmat,bpmat,en,fl,agi,api,ainf,max0) c c match both components for inhomogenious system (method=2) c f=bg(mat)-bgmat g=bp(mat)-bpmat a=(g*hg(mat)-f*hp(mat))/ah g=(g*hgmat-f*hpmat)/ah do 181 i=1,j bg(i)=bg(i)+a*hg(i) 181 bp(i)=bp(i)+a*hp(i) do 182 i=1,ndor bgh(i)=bgh(i)+a*agh(i) 182 bph(i)=bph(i)+a*aph(i) do 183 i=mat,max0 bg(i)=bg(i)+g*hg(i) 183 bp(i)=bp(i)+g*hp(i) c c calculate the norm c call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, 1 gpmat,fl,max0,mat) c c correction to the energy (method=2) c do 186 i=1,max0 186 hg(i)=(gg(i)*bg(i)+gp(i)*bp(i))*dr(i) ah=0.0d 00 c=0.0d 00 do 187 i=2,max0,2 187 ah=ah+hg(i)+hg(i)+hg(i+1) ah=hx*(ah+ah+hg(1)-hg(max0))/3.0d 00+hg(1)/(fl+fl+1.0d 00) f=(1.0d 00-b)/(ah+ah) c=1.0d 00-b do 191 i=1,max0 gg(i)=gg(i)+f*bg(i) 191 gp(i)=gp(i)+f*bp(i) do 195 i=1,ndor ag(i)=ag(i)+f*bgh(i) 195 ap(i)=ap(i)+f*bph(i) endif c c search for the maximum of the modulus of large component c a=0.0d 00 bgh(1)=b bph(1)=ah do 211 i=1,max0 g=gg(i)*gg(i) if (g.le.a) go to 211 a=g j=i 211 continue if (j.gt.mat .and. modmat.eq.0) then modmat=1 mat=j if (mod(mat,2).eq.0) mat=mat+1 imm=1 if (mat.lt.(max0-10)) go to 107 mat=max0-12 j=mat if (mod(mat,2).eq.0) mat=mat+1 write(slog,'(a,i4,a,i4)') ' warning mat=',mat,' max0=',max0 call wlog(slog,1) endif c c this case can happen due to bad starting point in scf procedure. c ignore this warning unless you are getting it at final norb calls of c soldir. redirected by ala 11/21/94. c numerr=220021 c * impossible matching point c go to 899 c compute number of nodes c 215 nd=1 j= max(j,mat) do 231 i=2,j if (gg(i-1).eq.0.0d 00) go to 231 if ((gg(i)/gg(i-1)).le.0.0d 00) nd=nd+1 231 continue if (nd-node) 251,305,261 251 esup=en if (einf.lt.0.0d 00) go to 271 en=en*8.0d-01 if ( abs(en).gt.test1) go to 285 numerr=238031 c *zero energy go to 899 261 einf=en if (esup.gt.emin) go to 271 263 en=en*1.2d 00 if (en.gt.emin) go to 285 numerr=245041 c c *energy is lower than the minimum of apparent potential c go to 899 271 if ( abs(einf-esup).gt.test1) go to 281 numerr=249051 c c *the upper and lower limits of energy are identical c go to 899 281 en=(einf+esup)/2.0d 00 285 jes=jes+1 if (jes.le.nes) go to 106 c c *number of attempts to find good number of nodes is over the limit c this case can happen due to bad starting point in scf procedure. c ignore this warning unless you are getting it at final norb calls of c soldir c call wlog('warning jes>nes',1) ifail=1 c c *redirected by ala 11/21/94. c numerr=255061 c go to 899 c c calculation of the norm c 305 call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, 1 gpmat,fl,max0,mat) if (method.eq.1) then c c correction to the energy (method=1) c c=gpmat-gp(mat) f=gg(mat)*c*cl/b if (gpmat.ne.0.0d 00) c=c/gpmat endif en=en+f g= abs(f/(en-f)) 371 if ((en.ge.0 .or. g.gt.2.0d-01) .or. 1 (abs(c).gt.test .and. (en.lt.esup.or.en.gt.einf))) then c c try smaller step in enrgy under above conditions c f=f/2.0d 00 g=g/2.0d 00 en=en-f if (g.gt.test1) go to 371 numerr=29071 c c *zero energy c go to 899 endif if ( abs(c).gt.test) then ies=ies+1 if (ies.le.nes) go to 105 ifail=1 call wlog('warning: iteration stopped because ies=nes',1) c c everything is fine unless you are getting this message c on the latest stage selfconsistent process. c just stopped trying to match lower component c because number of trials exceeded limit. c lines below were commented out. ala 11/18/94 c endif c c numerr=298081 c *number of attempts to match the lower component is over the limit c go to 899 c c divide by a square root of the norm, and test the sign of w.f. c b= sqrt(b) c=b if ((ag(1)*agi).lt.0.0d 00.or.(ap(1)*api).lt.0.0d 00) c=-c do 711 i=1,ndor ag(i)=ag(i)/c 711 ap(i)=ap(i)/c if ((gg(1)*agi).lt.0.0d 00.or.(gp(1)*api).lt.0.0d 00) b=-b do 721 i=1,max0 gg(i)=gg(i)/b 721 gp(i)=gp(i)/b if (max0.ge.np) return j=max0+1 do 741 i=j,np gg(i)=0.0d 00 741 gp(i)=0.0d 00 c c if everything o'k , exit is here. c return c c abnormal exit is here, if method.ne.1 c 899 if (iex.eq.0 .or. method.eq.2) go to 999 method=method+1 go to 101 999 return end c subroutine norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor, 1 gpmat,fl,max0,mat) c c calculate norm b. this part of original code was used twice, c causing difficult block structure. so it was rearranged into c separate subroutine. ala c implicit double precision (a-h, o-z) dimension hp(251),dr(251),gg(251),gp(251),ag(10),ap(10) b=0.0d 00 do 311 i=1,max0 311 hp(i)=dr(i)*(gg(i)*gg(i)+gp(i)*gp(i)) if (method.ne.1) go to 315 hp(mat)=hp(mat)+dr(mat)*(gpmat**2-gp(mat)**2)/2.0d 00 315 do 321 i=2,max0,2 321 b=b+hp(i)+hp(i)+hp(i+1) b=hx*(b+b+hp(1)-hp(max0))/3.0d 00 do 325 i=1,ndor g=fl+fl+i g=(dr(1)**g)/g do 325 j=1,i 325 b=b+ag(j)*g*ag(i+1-j)+ap(j)*g*ap(i+1-j) return end C FUNCTION ISTRLN (STRING) Returns index of last non-blank C character. Returns zero if string is C null or all blank. FUNCTION ISTRLN (STRING) CHARACTER*(*) STRING CHARACTER BLANK, TAB PARAMETER (BLANK = ' ', TAB = ' ') C there is a tab character here ^ C -- If null string or blank string, return length zero. ISTRLN = 0 IF (STRING (1:1) .EQ. CHAR(0)) RETURN IF (STRING .EQ. ' ') RETURN C -- Find rightmost non-blank character. ILEN = LEN (STRING) DO 20 I = ILEN, 1, -1 IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB) GOTO 30 20 CONTINUE 30 ISTRLN = I RETURN END subroutine tabrat c c tabulation of the results c do identifications of orbitals c nmax number of tabulation points for wave function c this programm uses dsordf c implicit double precision (a-h,o-z) common/itescf/testy,rap(2),teste,nz,norb,norbsc common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common /charact/ ttl character*40 ttl character*2 titre(30) character*2 ttire(9) dimension at(8),mbi(8) parameter (zero=0) data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/ c do 110 i=1,norb if (kap(i) .gt. 0) then j=2*kap(i) else j=-2*kap(i)-1 endif titre(i)=ttire(j) 110 continue c c tabulation of number of points and of average values of c r**n (n=6,4,2,1,-1,-2,-3) c do 201 i=2,8 201 mbi(i)=8-i-i/3-i/4+i/8 lttl = istrln(ttl) write(16,11) ttl(1:lttl) 11 format (10x,a) write(16,*) 1'number of electrons nel and average values of r**n in a.u.' write(16,2061) (mbi(k),k=2,8) 2061 format (4x,'nel',' n=',7(i2,8x)) do 251 i=1,norb llq= abs(kap(i))-1 j=8 if (llq.le.0) j=7 do 241 k=2,j 241 at(k)=dsordf(i,i,mbi(k),1, zero) 251 write(16,2071) nq(i),titre(i),xnel(i),(at(k),k=2,j) 2071 format(i2,a2,f7.3,7(1pe10.3)) c c overlap integrals c if (norb.le.1) return write(16,11) ttl(1:lttl) write(16,321) 321 format(10x,'overlap integrals') do 351 i=1,norb-1 do 331 j=i+1,norb if (kap(j).ne.kap(i)) go to 331 at(1)=dsordf(i,j,0,1, zero) write(16,2091) nq(i),titre(i),nq(j),titre(j),at(1) 331 continue 351 continue 2091 format (4x,i3,a2,i3,a2,f14.7) return end c subroutine wfirdf (en,ch,nq,kap,nmax,ido,amass,beta) c c calculate initial orbiatls from integration of dirac equation c cg (cp) large (small) radial components c bg (bp) development coefficients at the origin of cg (cp) c en one-electron energies c fl power of the first term of development at the origin c ch ionicity (nuclear charge - number of electrons) c nq principal quantum number c kap quantum number "kappa" c nmax number of tabulation points for the orbitals c ibgp first dimension of the arrays bg and bp c this programmes utilises nucdev,dentfa,soldir et messer c implicit double precision (a-h,o-z) common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp dimension en(30),nq(30),kap(30),nmax(30) common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10), 1dv(251),av(10),eg(251),ceg(10),ep(251),cep(10) common/itescf/testy,rap(2),teste,nz,norb,norbsc common/inelma/nem common/messag/dlabpr,numerr character*8 dlabpr character*512 slog common/snoyau/dvn(251),anoy(10),nuc common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim c c speed of light in atomic units c cl=1.370373d+02 c c make r-mesh and calculate nuclear potential c hx exponential step c dr1 first tabulation point multiplied by nz c dr1=dr(1) call nucdev (amass, beta,anoy,dr,dvn,dz,hx,nuc,idim,ndor,dr1) c c notice that here nuc=1, c unless you specified nonzero nuclear mass in nucdev.f c a=(dz/cl)**2 if (nuc.gt.1) a=0.0d 00 do 11 j=1,norb b=kap(j)*kap(j)-a 11 fl(j)= sqrt(b) c c calculate potential from thomas-fermi model c do 21 i=1,idim 21 dv(i)=(dentfa(dr(i),dz,ch)+dvn(i))/cl if (numerr.ne.0) return do 51 i=1,idim eg(i)=0.0d 00 51 ep(i)=0.0d 00 do 61 i=1,ibgp ceg(i)=0.0d 00 cep(i)=0.0d 00 61 av(i)=anoy(i)/cl av(2)=av(2)+dentfa(dr(nuc),dz,ch)/cl test1=testy/rap(1) b=test1 c c resolution of the dirac equation to get initial orbitals c if (ido.ne.1) then call wlog('only option ido=1 left',1) ido = 1 endif c c here was a piece to read orbitals from cards c do 281 j=1,norb bg(1,j)=1.0d 00 i=nq(j)- abs(kap(j)) if (kap(j).lt.0) i=i-1 if (mod(i,2).eq.0) bg(1,j)=-bg(1,j) if (kap(j).lt.0) go to 201 bp(1,j)=bg(1,j)*cl*(kap(j)+fl(j))/dz if (nuc.gt.1) bg(1,j)=0.0d 00 go to 211 201 bp(1,j)=bg(1,j)*dz/(cl*(kap(j)-fl(j))) if (nuc.gt.1) bp(1,j)=0.0d 00 211 np=idim en(j)=-dz*dz/nq(j)*nq(j) method=0 call soldir 1 (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),0) if (numerr.eq.0) go to 251 call messer write(slog,'(a,2i3)') 1 'soldir failed in wfirdf for orbital nq,kappa ',nq(j),kap(j) call wlog(slog,1) go to 281 251 do 261 i=1,ibgp bg(i,j)=ag(i) 261 bp(i,j)=ap(i) do 271 i=1,np cg(i,j)=dg(i) 271 cp(i,j)=dp(i) 281 continue nem=0 return end c subroutine wlog (string,iprint) character*(*) string c c This output routine is used to replace the PRINT statement c for output that "goes to the terminal", or to the log file. c If you use a window based system, you can modify this routine c to handle the running output elegantly. c Handle carriage control in the string you pass to wlog. c c The log file is also written here, hard coded here. c c The log file is unit 11. The log file is opened in the c main program, program feff. c c make sure not to write trailing blanks c 10 format (a) il = istrln (string) if (il .eq. 0) then if(iprint.eq.1) print 10 write(11,10) else if(iprint.eq.1) print 10, string(1:il) write(11,10) string(1:il) endif return end c subroutine yzkrdf (i,j,k) c c * calculate function yk * c yk = r * integral of f(s)*uk(r,s) c uk(r,s) = rinf**k/rsup**(k+1) rinf=min(r,s) rsup=max(r,s) c f(s)=cg(s,i)*cg(s,j)+cp(s,i)*cp(s,j) if nem=0 c f(s)=cg(s,i)*cp(s,j) if nem is non zero c f(s) is constructed by the calling programm if i < or =0 c in the last case a function f (lies in the block dg) is supposedly c tabulated untill point dr(j), and its' devlopment coefficients c at the origin are in ag and the power in r of the first term is k+2 c the output functions yk and zk are in the blocks dp and dg. c at the origin yk = cte * r**(k+1) - developement limit, c cte lies in ap(1) and development coefficients in ag. c this programm uses aprdev and yzkteg c implicit double precision (a-h,o-z) common cg(251,30),cp(251,30),bg(10,30),bp(10,30),fl(30),ibgp common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783) dimension chg(10) common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30), 1nq(30),kap(30),nmax(30) common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim common/inelma/nem dimension bgi(10),bgj(10),bpi(10),bpj(10) c if (i.le.0) go to 51 c c construction of the function f c do 5 l= 1,ibgp bgi(l) = bg(l,i) bgj(l) = bg(l,j) bpi(l) = bp(l,i) 5 bpj(l) = bp(l,j) id= min(nmax(i),nmax(j)) ap(1)=fl(i)+fl(j) if (nem.ne.0) go to 31 do 11 l=1,id 11 dg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j) do 21 l=1,ndor 21 ag(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l) go to 55 31 do 35 l=1,id 35 dg(l)=cg(l,i)*cp(l,j) do 41 l=1,ndor 41 ag(l)=aprdev(bgi,bpj,l) go to 55 c 51 ap(1)=k+2 id=j 55 call yzkteg (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim) return end c subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim) c c calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to c infinity of f(u) * u**(-k-1) c zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k c at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1) c dr tabulation points h exponential step c np number of tabulation points for f c idim dimension of the blocks f,g and dr c at the origin yk=cte*r**(k+1)-developement limit c the constant for yk lies in ap c output functions yk and zk lie in f and g, and their c development coefficients at the origin in af and ag. c integration from point to point by a 4 points method. c integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24 c implicit double precision (a-h,o-z) dimension f(251),af(10),g(251),ag(10),dr(251) c c initialisation and development coefficients of yk c np= min(np,idim-2) b=ap ap=0.0d 00 g(1)=0.0d 00 g(2)=0.0d 00 do 15 i=1,nd b=b+1.0d 00 ag(i)=af(i)/(b+k) if (af(i).ne.0.0d 00) then c=dr(1)**b g(1)=g(1)+ag(i)*c g(2)=g(2)+ag(i)*(dr(2)**b) af(i)=(k+k+1)*ag(i)/(b-k-1) ap=ap+af(i)*c endif 15 continue do 21 i=1,np 21 f(i)=f(i)*dr(i) np1=np+1 f(np1)=0.0d 00 f(np1+1)=0.0d 00 c c calcualation of zk c eh= exp(h) e=eh**(-k) b=h/2.4d+01 c=1.3d+01*b ee=e*e*b b=b/e do 51 i=3,np1 51 g(i)=g(i-1)*e+(c*(f(i)+f(i-1)*e)-(f(i-2)*ee+f(i+1)*b)) c c calcualation of yk c f(np)=g(np) do 61 i=np1,idim 61 f(i)=f(i-1)*e i=k+k+1 b=i*b*eh ee=i*ee/(eh*eh) e=e/eh c=i*c do 71 i=np-1,2,-1 71 f(i)=f(i+1)*e+(c*(g(i)+g(i+1)*e)-(g(i+2)*ee+g(i-1)*b)) ee=e*e c=8.0d 00*c/1.3d+01 f(1)=f(3)*ee+c*(g(3)*ee+4.0d 00*e*g(2)+g(1)) ap=(ap+f(1))/(dr(1)**(k+1)) return end c subroutine llmesh c include 'msxas3.inc' c include 'msxasc3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $ n_=ltot_*ua_,rd_=440,sd_=ua_-1) c common /fcnr/kxe, h(d_),vcons(2),r(rd_,d_),v(rd_,sd_), $ ichg(10,d_),kplace(at_),kmax(at_) complex v,vcons c COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C COMMON /LLM/ ALPHA, BETA c character*8 name0 ,nsymbl !added 29/3/2013 c common /param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,xe,ev c logical do_r_in c c-------------------------------------------------------- c c write(69,*) ' in sub cont_sub nat = ', nat C C CONSTRUCT LINEAR-LOG MESH C DO_R_IN = .FALSE. C DO N = 1, NDAT C ZAT = FLOAT(NZ(N)) IF(ZAT.EQ.0.0) THEN X0 = 9.0 C X0 = 10.0 ELSE X0 = 9.0 + LOG(ZAT) C X0 = 10.0 + LOG(ZAT) ENDIF RKMX = R(KMAX(N),N) DPAS = 0.1/RKMX ! IF(DPAS.GT.0.03) DPAS = 0.03 IF(DPAS.GT.0.02) DPAS = 0.02 ALPHA = 0.5 BETA = 1.0 RHO_1 = -BETA*X0 R_SUB = RS(N) XMAX = ALPHA*R_SUB + BETA*LOG(R_SUB) KMX(N) = NINT ( (XMAX + X0 + DPAS) / DPAS ) IF(KMX(N).GT.RDX_) THEN WRITE(6,*) & 'INCREASE PARAMETER RDX_. IT SHOULD BE AT LEAST ', KMX(N) CALL EXIT ENDIF NR = KMX(N) KPLX(N) = KMX(N)-3 C C CHECK IN LLMESH c write(6,'(2i5,4e15.6)') n,kmx(n),rkmx,r_sub,xmax,rho_1 c flush(6) C CALL LINLOGMESH ( I_END, HX(N), X(1,N), RX(1,N), DO_R_IN, & KMX(N), KPLX(N), NR, RHO_1, R_SUB, R_IN, & ALPHA, BETA ) c c if(n.eq.ndat) then c if(n.eq.ndat) write(6,*) (x(i,n), rx(i,n), i=1,kmx(n)) c endif C c print *, ' inside llmesh loop ', kmx(n) c do i = 1, kmx(n) c write(69,*) x(i,n), rx(i,n) c print *, x(i,n), rx(i,n) c enddo c ENDDO c c---------------------------------------------------------- c return end c subroutine linlogmesh ( i_end, drho, rho, r_real, do_r_in, & kmax, kplace, nr, rho_1, r_sub, r_in, & alpha, beta ) ! ! Set up log + linear radial mesh. ! ! rho = alpha * r_real + beta * log ( r_real ) ! ! rho_i = rho_{i-1} + drho ! ! ! i_end : point at inscribed sphere, for outersphere not used always 0. ! drho : constant step in loglinear space ! rho : log + linear mesh with constant step. ! r_real : real radial mesh correponding to the step of loglinear mesh ! do_r_in : option for outer sphere ! kmax : three points after kplace ! kplace : point on the bounding sphere where the Wronskian is estimated. ! nr : number of radial mesh points ! rho_1 : the first point in loglinear space ! r_sub : radius of bounding sphere in loglinear space, r_sub => rho(kplace) ! r_in : ! alpha : parameter for linear part ! beta : parameter for log part c implicit double precision (a-h,o-z) !...input ! logical, intent ( in ) :: do_r_in ! integer, intent ( in ) :: nr, kmax, kplace ! real ( kind = double ), intent ( in ) :: rho_1, r_sub, r_in, alpha, beta !...output ! integer, intent ( out ) :: i_end ! real ( kind = double ), intent ( out ) :: drho ! real ( kind = double ), intent ( out ), dimension ( : ) :: rho, r_real !...local ! logical :: check ! integer :: i, k ! real ( kind = double ) :: rn, rhon, epsilon c dimension rho(kmax), r_real(kmax) c logical do_r_in, check myrank = 0 dzero = 0.0 check = .false. c check = .true. rho ( kplace ) = alpha * r_sub + beta * log ( r_sub ) rho ( 1 ) = rho_1 drho = ( rho ( kplace ) - rho ( 1 ) ) / real ( kmax - 4 ) rho ( kmax ) = rho ( kplace ) + 3.00 * drho ! ! write(6,*) rho(1), rho(kmax), drho ! write(6,*) ' ** ' ! if ( myrank .eq. 0 ) then ! write ( unit = 6, fmt = * ) " alpha =", alpha, " beta ", beta ! write ( unit = 6, fmt = * ) "rho_1 =", rho ( 1 ), & ! & " rho ( kplace ) =", rho ( kplace ), " rho ( kmax ) = ", rho ( kmax ) ! write ( unit = 6, fmt = * ) "drho =", drho, " nr =", nr ! end if ! do i = 2, nr rho ( i ) = rho ( i - 1 ) + drho end do ! !.....Solve non-linear equation by Newton method ! rhon = rho ( kplace ) r_real ( kplace ) = r_sub ! rn = ( rhon - beta * log ( rhon ) ) / alpha ! correction 2nd April 2013 rn = ( rhon - beta * log ( r_sub ) ) / alpha ! do i = kplace - 1, 1, - 1 k = 0 ! do ! ! MPI ! if ( check .and. myrank .eq. 0 ) then write ( unit = 98, fmt = * ) i, rn end if ! ! MPI ! if ( rn .eq. dzero ) then ! ! MPI ! if ( myrank .eq. 0 ) then write ( unit = 6, fmt = * ) "Error occurred at radialmesh!", & "rn = 0" end if ! ! MPI ! stop end if ! epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / & ( alpha * rn + beta ) ! ! MPI ! if ( check .and. myrank .eq. 0 ) then write ( unit = 98, fmt = * ) i, rn, epsilon end if ! ! MPI ! rn = rn * ( 1.00 - epsilon ) ! if ( rn .lt. 0.0 ) then rn = r_real ( i + 1 ) * 0.100 ** k k = k + 1 end if ! ! if ( abs ( epsilon ) .le. 1.0e-6 ) then exit end if ! end do ! r_real ( i ) = rn ! write(6,*) i, r_real ( i ) end do ! rhon = rho ( kplace ) ! rn = ( rhon - beta * log ( rhon ) ) / alpha ! correction 2nd April 2013 rn = ( rhon - beta * log ( r_sub ) ) / alpha ! do i = kmax - 2, nr k = 0 ! do ! ! MPI ! if ( check .and. myrank .eq. 0 ) then write ( unit = 98, fmt = * ) i, rn end if ! ! MPI ! epsilon = ( alpha * rn + beta * log ( rn ) - rho ( i ) ) / & ( alpha * rn + beta ) ! ! MPI ! if ( check .and. myrank .eq. 0 ) then write ( unit = 98, fmt = * ) i, rn, epsilon end if ! ! MPI ! rn = rn * ( 1.00 - epsilon ) ! if ( rn .lt. 0.0 ) then rn = r_real ( i - 1 ) * 10.00 ** k k = k + 1 end if ! if ( abs ( epsilon ) .le. 1.0e-6 ) then exit end if ! end do ! r_real ( i ) = rn end do ! ! MPI ! if ( check .and. myrank .eq. 0 ) then write ( unit = 99, fmt = * ) '# i rho r rho ( r )', & ' dr' i = 1 write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i, rho ( i ), & r_real ( i ), & alpha * r_real ( i ) + beta * log ( r_real ( i ) ) ! do i = 2, nr write ( unit = 99, fmt = "( i4, 4es20.10 )" ) i,rho ( i ), & r_real ( i ), & alpha * r_real ( i ) + beta * log ( r_real ( i ) ), & r_real ( i ) - r_real ( i - 1 ) end do ! end if ! ! MPI ! if ( .not. do_r_in ) then ! if ( do_r_in ) then i = 1 ! do ! if ( r_real ( i ) > r_in ) then exit end if ! i = i + 1 end do ! i_end = i else i_end = 0 end if ! ! if ( myrank .eq. 0 ) then ! write ( unit = 6, fmt = * ) ! write ( unit = 6, fmt = "( a7, i5, a20, f12.7 )" ) & ! & "kplace = ", kplace, ", r_real ( kplace ) = ", r_real ( kplace ) ! write ( unit = 6, fmt = "( a7, i5, a20, f12.7, a10, f12.7 )" ) & ! & "kmax = ", kmax, ", r_real ( kmax ) = ", r_real ( kmax ), & ! & ", r_sub = ", r_sub ! write ( unit = 6, fmt = * ) ! write ( unit = 6, fmt = * ) "**** r_in = r_real (",i_end,")= ", & ! & r_real ( i_end ) ! end if end subroutine linlogmesh C C SUBROUTINE VREL C include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c C COMMON /FCNR/KXE,H(D_),VCONS(2), 1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_) COMPLEX VCONS,V C COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C c common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,xe,ev character*8 nsymbl,name0 c COMPLEX ZTMP(0:RD_), ZX, DZX, D2ZX REAL*4 RTMP(0:RD_) C DATA FSC,FSCS4 /7.29735E-3,1.331283E-5/ C C INTERPOLATE POTENTIAL ON THE LOG-LINEAR MESH C AND ADD RELATIVISTIC CORRECTIONS, INCLUDING SPIN-ORBIT INTERACTION C C WRITE(7,*) ' I RX(I), VX(I), VXSR(I), VXSO(I), BX(I) ' C RTMP(0) = 0.0 C DO N = 1, NDAT C ZAT = FLOAT(NZ(N)) ZTMP(0) = CMPLX(2.0*ZAT,0.0) C DO I = 1, KMAX(N) RTMP(I) = R(I,N) ENDDO C NS = N DO IS=1,NSPINS DO I = 1, KMAX(N) ZTMP(I) = -V(I,NS) * RTMP(I) C WRITE(6,*) N, IS, I, RTMP(I), ZTMP(I) ENDDO C DO I=1,KMX(N) C C FIND NEAREST POINTS - INITIALIZE HUNTING PARAMETER (SUBROUTINE NEAREST) C JLO=1 CALL NEAREST1(RTMP(0), KMAX(N)+1, RX(I,N), & IP1, IP2, IP3, JLO) IP1 = IP1 - 1 IP2 = IP2 - 1 IP3 = IP3 - 1 C C INTERPOLATE ZR(I) AND RHOTOT(I) C CALL CINTERP_QUAD( RTMP(IP1),ZTMP(IP1), & RTMP(IP2),ZTMP(IP2), & RTMP(IP3),ZTMP(IP3), & RX(I,N),ZX,DZX,D2ZX ) VX(I,NS) = -ZX/RX(I,N) BX(I,NS) = FSCS4/(1.0 + FSCS4*(E - VX(I,NS))) DVX(I,NS) = -(DZX/RX(I,N) - ZX/RX(I,N)**2) VXR(I,NS) = VX(I,NS) - FSCS4*(E - VX(I,NS))**2 + & 0.5*BX(I,NS)*( -D2ZX/RX(I,N) + & 1.5*BX(I,NS)*(DVX(I,NS))**2 ) VXSO(I,NS) = BX(I,NS)*DVX(I,NS)/RX(I,N) C WRITE(15,1) I, RX(I,N), VX(I,NS), VXR(I,NS), C & VXSO(I,NS), BX(I,NS) 1 FORMAT(I5,9E15.6) ENDDO NS=NS+NDAT ENDDO C ENDDO C RETURN C END C C SUBROUTINE NEAREST1(XX,N,X,I_POINT_1,I_POINT_2,I_POINT_3, & JLO) C C FIND NEAREST THREE POINTS IN ARRAY XX(N), TO VALUE X C AND RETURN INDICES AS I_POINT_1,I_POINT_2 AND I_POINT_3 C This subroutine was taken from Numerical Recipes, C W. H. Press, B. F. Flanney, S. A. Teukolsky and W. T. C Vetterling, page 91. Originally called HUNT C IMPLICIT DOUBLE PRECISION (A-H,O-Z) C COMMON/MESH_PARAM/JLO C DIMENSION XX(*) LOGICAL ASCND ASCND=XX(N).GT.XX(1) C C EXTRAPOLATE BELOW LOWEST POINT C IF(X.LE.XX(1))THEN I_POINT_1=1 I_POINT_2=2 I_POINT_3=3 RETURN END IF C C EXTRAPOLATE BEYOND HIGHEST POINT C IF(X.GE.XX(N))THEN I_POINT_1=N-2 I_POINT_2=N-1 I_POINT_3=N RETURN END IF IF(JLO.LE.0.OR.JLO.GT.N)THEN JLO=0 JHI=N+1 GO TO 3 ENDIF INC=1 IF(X.GE.XX(JLO).EQV.ASCND)THEN 1 JHI=JLO+INC IF(JHI.GT.N)THEN JHI=N+1 ELSE IF(X.GE.XX(JHI).EQV.ASCND)THEN JLO=JHI INC=INC+INC GO TO 1 ENDIF ELSE JHI=JLO 2 JLO=JHI-INC IF(JLO.LT.1)THEN JLO=0 ELSE IF(X.LT.XX(JLO).EQV.ASCND)THEN JHI=JLO INC=INC+INC GO TO 2 ENDIF ENDIF 3 IF(JHI-JLO.EQ.1)THEN IF((JLO+1).EQ.N)THEN I_POINT_1=JLO-1 I_POINT_2=JLO I_POINT_3=JLO+1 ELSE I_POINT_1=JLO I_POINT_2=JLO+1 I_POINT_3=JLO+2 END IF RETURN END IF JM=(JHI+JLO)/2 IF(X.GT.XX(JM).EQV.ASCND)THEN JLO=JM ELSE JHI=JM ENDIF GO TO 3 END C C SUBROUTINE CINTERP_QUAD(X1,Y1,X2,Y2,X3,Y3,X4,Y4,DY4,D2Y4) C C INTERPOLATE BETWEEN POINTS Y1=F(X1) AND Y2=F(X2) C TOP FIND Y4=F(X4) GIVEN X1,Y1,X2,Y2,X3,Y3 AND X4 AS INPUT C PARAMETERS. THE FUNCTIONAL FORM USED IS Y = AX^2+BX+C C COMPLEX Y1, Y2, Y3, Y4, DY4, D2Y4 COMPLEX TOP, A, B, C C TOP = (Y2-Y1)*(X3*X3-X2*X2)- (Y3-Y2)*(X2*X2-X1*X1) BOTTOM = (X2-X1)*(X3*X3-X2*X2)- (X3-X2)*(X2*X2-X1*X1) B = TOP/BOTTOM A = ( (Y2-Y1)- B*(X2-X1) )/(X2*X2-X1*X1) C = Y3 - A*X3*X3 - B*X3 Y4 = A*X4*X4 + B*X4 + C DY4 = 2.0*A*X4 + B D2Y4 = 2.0*A C RETURN END C C subroutine smtxllm(ne,lmax_mode,relc,nks,px,px0,ppx,pax, & ramfnr,ramfsr,ramfsop,ramfsoa) c include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) C C COMMON/BESSEL/SBF(LTOT_),DSBF(LTOT_),SHF(LTOT_),DSHF(LTOT_) COMPLEX*16 SBF,DSBF,SHF,DSHF COMPLEX*16 SBFX(LTOT_),DSBFX(LTOT_),SHFX(LTOT_),DSHFX(LTOT_) C COMPLEX*16 Y0(0:LMAX_), Y1(0:LMAX_) DOUBLE PRECISION RX1, RX2, EXPR C COMMON /FCNR/KXE, H(D_),VCONS(2), 1 R(RD_,D_),V(RD_,SD_),ICHG(10,D_),KPLACE(AT_),KMAX(AT_) COMPLEX VCONS,V C COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C COMPLEX VXP(RDX_), VXA(RDX_), BD(RDX_) C COMPLEX PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), PAX(RDX_,F_) COMPLEX PSX(N_), DPSX(N_), STMAT, RAMFX(N_) COMPLEX PS0(N_), DPS0(N_), STMAT0, RAMF0(N_) COMPLEX PS1(N_), DPS1(N_), STMAT1, RAMF1(N_) COMPLEX PS2(N_), DPS2(N_), STMAT2, RAMF2(N_) COMPLEX RAMF00, RAMF01, RAMF02 C COMPLEX PKMX, PKMX1 C COMMON /LLM/ ALPHA, BETA c common /flag/ inmsh,inv,inrho,insym,iovrho,iosym, 1 imvhl,nedhlp c complex pss(6),dpss(6), & ramfnr(n_), ramfsr(n_), ramfsop(n_), ramfsoa(n_) c character*8 name0 ,nsymbl !added 29/3/2013 common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,ev,xe c common /seculrx/ atmnr(n_), atmsr(n_), atmsop(n_), atmsoa(n_) complex atmnr, atmsr, atmsop, atmsoa c common /state/ natom(n_),ln(n_),nleq(at_), 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) c common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), & ramfsr2(npss,nef_),ramfsr3(npss,nef_), & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg real*4 einc,esct,scangl,qt,lambda c common/auger/calctype,expmode,edge1,edge2 character*3 calctype, expmode character*2 edge1,edge2 c complex csqrt,arg,arg1 COMPLEX ONEC c character*2 relc c data zero,one,two/0.0,1.0,2.0/ data pi/3.14159265358979/,srt2/1.414213562/ c data fsc,fscs4 /7.29735e-3,1.331283e-5/ c c.....Define bd for non relativistic calculation c do i = 1, rdx_ bd(i) = cmplx(fscs4,0.0) enddo C onec = (1.0,0.0) if(e.eq.0.0) e = 1.0e-8 ns=(nns-1)*ndat C do 5 j=1,ndim atmnr(j)=(0.00,0.00) atmsr(j)=(0.00,0.00) atmsop(j)=(0.00,0.00) 5 atmsoa(j)=(0.00,0.00) c c write(70,*) ' non relativistic stmat and phase shifts ' c write(80,*) ' scalar relativistic stmat and phase shifts ' c write(90,*) ' spin-orbit stmat and phase shifts ' c c calculate t-matrix elements: c stmat: inverse t-m elements (atomic spheres) c ramf: for normalization of ps(k) functions c c write(19,18) e, xe write(81,*) ' e, vcon, xe, relc =', e, real(vcon), & real(xe), relc c write(84,*) ' e, vcon, xe =', e, vcon, xe c 18 FORMAT(' E =', F10.5,5X,' XE =',2F10.5,' GAMMA =',F10.5) c do 60 na=1,nuatom write(35,77) na write(70,77) na write(80,77) na write(90,77) na ns=ns+1 25 nt0a=n0(na) ntxa=nt0a+nterms(na)-1 if (na.eq.nas) then nstart=nt0a nlast=ntxa endif l=-1 nlat=-1 arg=xe*rs(na) ml=lmaxn(na)+1 if (ml.lt.3) ml = 3 call csbf(arg,xe,ml,sbf,dsbf) call cshf2(arg,xe,ml,shf,dshf) npabs = 0 C 43 do 45 nn=nt0a,ntxa l=ln(nn) nlat=nlat+1 npabs=npabs+1 if(na.ne.nas.or.npabs.gt.npss-1) npabs=npss if(lmax_mode.eq.2.and.l.gt.lmxne(na,ne)) goto 45 np=npabs C c if(relc.eq.'nr') then c rx1 = dble(rx(1,na)) rx2 = dble(rx(2,na)) y0(l) = dcmplx(rx1**(l+1),0.d0) y1(l) = dcmplx(rx2**(l+1),0.d0) c call pgenll1m(l, e, hx(na), rx(1,na), vx(1,ns), bd, & kmx(na), kplx(na), rs(na), px(1,np), psx(nn), & dpsx(nn), ramf00, stmat, y0(l),y1(l)) c atmnr(nn)=stmat ramfx(nn)=ramf00 ramfnr(nn) = ramf00 write(70,1000) xe/0.52917715, stmat if(relc.eq.'nr') write(35,1000) xe/0.52917715, stmat c definition of stmat as exp(-i*delta)*sin(delta) phase=sign(-1.,real(stmat))* 1 asin(sqrt(abs(aimag(stmat)))) if(phase.lt.0.0) phase=phase+3.1415926 write(71,1001)e,xe,na,nlat,stmat,phase 1001 format(2x,f10.5,2x,2f10.5,2x,i3,2x,i3, & 2x,2e12.6,f10.5,2x,2e12.6,f10.5) 1000 format(3x,f9.4,1x,f9.4,5x,e12.6,5x,e12.6,5x,e12.6,5x,e12.6) c 1000 format(3x,f9.4,1x,f9.4,5x,f12.9,5x,f12.9,5x,f12.9,5x,f12.9) c c elseif(relc.eq.'sr') then c rx1 = dble(rx(1,na)) rx2 = dble(rx(2,na)) expr = 0.5d0 + sqrt( dfloat(l*(l+1)) +1 - dble(fsc*z(na))**2 ) y0(l) = dcmplx(rx1**expr,0.d0) y1(l) = dcmplx(rx2**expr,0.d0) call pgenll1m(l, e, hx(na), rx(1,na), vxr(1,ns), bx(1,ns), & kmx(na), kplx(na), rs(na), px0(1,np), ps0(nn), & dps0(nn), ramf00, stmat0, y0(l),y1(l)) c if(calctype.eq.'els'.or.calctype.eq.'e2e') then do k = 1, kmx(na) if(nks.eq.1) p1(k,l+1,na) = px0(k,np) !npabs = np if(nks.eq.2) p2(k,l+1,na) = px0(k,np) if(nks.eq.3) p3(k,l+1,na) = px0(k,np) enddo if(nks.eq.1) ramfsr1(l+1,na) = ramf00 if(nks.eq.2) ramfsr2(l+1,na) = ramf00 if(nks.eq.3) ramfsr3(l+1,na) = ramf00 endif c atmsr(nn)=stmat0 ramfsr(nn)=ramf00 write(80,1000) xe/0.52917715, stmat0 if(relc.eq.'sr') write(35,1000) xe/0.52917715, stmat0 C c definition of stmat as exp(-i*delta)*sin(delta) C phase=sign(-1.,real(stmat0))* 1 asin(sqrt(abs(aimag(stmat0)))) if(phase.lt.0.0) phase=phase+3.1415926 write(81,1001)e,xe,na,nlat,stmat,phase c c elseif(relc.eq.'so') then c ilm = 2 if(l.eq.0) ilm = 1 do il = 1, ilm c if(il.eq.1) then do i = 1, kmx(na) vxp(i) = vxr(i,ns) + float(l)*vxso(i,ns) enddo rx1 = dble(rx(1,na)) rx2 = dble(rx(2,na)) expr = 0.5d0 + sqrt( dfloat(l+1)**2 -dble(fsc*z(na))**2 ) y0(l) = dcmplx(rx1**expr,0.d0) y1(l) = dcmplx(rx2**expr,0.d0) call pgenll1m(l, e, hx(na), rx(1,na), vxp, bx(1,ns), & kmx(na), kplx(na), rs(na), ppx(1,np), & ps1(nn), dps1(nn), ramf01, stmat1, & y0(l),y1(l)) if(na.eq.nas) & write(81,1) 'rp', na, l, real(stmat1), 1.0/stmat1, & real(ramf01), e else do i = 1, kmx(na) vxa(i) = vxr(i,ns) - float(l+1)*vxso(i,ns) enddo rx1 = dble(rx(1,na)) rx2 = dble(rx(2,na)) expr = 0.5d0 + sqrt( dfloat(l)**2 - dble(fsc*z(na))**2 ) if(l.eq.0) expr = 0.5d0 +sqrt( 1.0d0 -dble(fsc*z(na))**2) y0(l) = dcmplx(rx1**expr,0.d0) y1(l) = dcmplx(rx2**expr,0.d0) call pgenll1m(l, e, hx(na), rx(1,na), vxa, bx(1,ns), & kmx(na), kplx(na), rs(na), pax(1,np), & ps2(nn), dps2(nn), ramf02, stmat2, & y0(l),y1(l)) c endif c enddo c c atmsop(nn)=stmat1 ramfsop(nn)=ramf01 atmsoa(nn)=stmat2 ramfsoa(nn)=ramf02 write(90,1000) xe/0.52917715, stmat1, stmat2 if(relc.eq.'so') write(35,1000) xe/0.52917715, stmat1, stmat2 C c definition of stmat as exp(-i*delta)*sin(delta) C phase1=sign(-1.,real(stmat1))* 1 asin(sqrt(abs(aimag(stmat1)))) phase2=sign(-1.,real(stmat2))* 1 asin(sqrt(abs(aimag(stmat2)))) if(phase.lt.0.0) phase=phase+3.1415926 write(91,1001)e,xe,na,nlat,stmat1,phase1,stmat2,phase2 c c endif 1 format(a3,2i5,10e13.5) 30 format(5i3,8e13.5) c c 45 continue 60 continue c 77 FORMAT('-------------------------- ATOM ',I3, 1 ' -----------------------') c c c calculate singular solution inside muffin tin sphere for the absorbing c atom, matching to shf in interstitial region c if(calctype.eq.'els'.and.nks.eq.3) & write(6,*)' store irregular solution' 90 nl=0 lmsing=5 mout=4 nst=n0(nas) nlst=n0(nas)+nterms(nas)-1 c if(nks.eq.3) write(6,*)' nst =',nst,' nlst =',nlst l=-1 ml=lmaxn(nas)+1 if (ml.lt.3) ml = 3 kpp = kmx(nas) -2 arg=xe*rx(kpp,nas) call cshf2(arg,xe,ml,sbfx,dsbfx) arg1=xe*rx(kpp-1,nas) call cshf2(arg1,xe,ml,shfx,dshfx) c do n=nst,nlst l=ln(n) if(l.gt.lmsing) cycle nl=nl+1 np=npss+nl np1=nl c pkmx = cmplx(sbfx(l+1))*arg/pi pkmx1 = cmplx(shfx(l+1))*arg1/pi c call pgenll2( l, e, hx(nas), rx(1,nas), vx(1,nas), bd, & kpp, px(1,np), pkmx, pkmx1 ) call pgenll2( l, e, hx(nas), rx(1,nas), vxr(1,nas), & bx(1,nas), kpp, px0(1,np), pkmx, pkmx1 ) ilm = 2 if(l.eq.0) ilm = 1 c do i = 1, kmx(nas) vxp(i) = vxr(i,nas) + float(l)*vxso(i,nas) vxa(i) = vxr(i,nas) - float(l+1)*vxso(i,nas) enddo c do il = 1, ilm if(il.eq.1) & call pgenll2( l, e, hx(nas), rx(1,nas), vxp, & bx(1,nas), kpp, ppx(1,np), pkmx, pkmx1 ) if(il.eq.2) & call pgenll2( l, e, hx(nas), rx(1,nas), vxa, & bx(1,nas), kpp, pax(1,np), pkmx, pkmx1 ) enddo c if(calctype.eq.'els') then if(nks.eq.2) then do k = 1, kmx(nas) p2irreg(k,l+1) = px0(k,np) c write(6,*) l, rx(k,nas), px0(k,np) enddo elseif(nks.eq.3) then do k = 1, kmx(nas) p3irreg(k,l+1) = px0(k,np) c write(6,*) l, rx(k,nas), px0(k,np) enddo endif endif c enddo c c return c end c c subroutine pgenll1m(l, en, h, rx, v, b, kmax, kplx, rs, & p, ps, dps, ramf, stmat, y0, y1 ) c c include 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) c common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) complex*16 sbf,dsbf,shf,dshf c common/param/eftr,gamma,vcon,xe,ev,e,iout complex vcon,xe,ev c common /llm/ alpha, beta c complex v(kmax), p(kmax), b(kmax), ps, dps, ramff, ramf, stmat, x complex*16 y0, y1, pd(kmax) c dimension rx(kmax) c double precision dfl, a, hd, hsq12, rxi, den, arb2, & alphad, betad, rlv, amv complex*16 dvi c complex*16 um(0:kmax), vm(0:kmax), & am(0:kmax), bm(0:kmax) c c data pi/3.141592653589793d0/, fsc/7.29735E-3/ c c calculate coefficients um(m) and vm(m). c inv = .true. : y0 first starting point; y1 last starting point c inv = .false. : y0, y1 first two starting points at rx(1) and rx(2) c In this particular case um=/0. c vm(1) = (0.d0,0.d0) um(1) = (1.d0,0.d0) am(0) = (0.d0,0.d0) bm(0) = (0.d0,0.d0) c alphad = dble(alpha) betad = dble(beta) den = dble(en) dfl = dble(float(l)) a = (dfl + 1)*dfl hd = dble(h) hsq12 = hd*hd/12.d0 c do i = 1, kmax rxi = dble(rx(i)) arb2 = (alphad*rxi + betad)**2 dvi = dcmplx(v(i)) am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a - & betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) enddo do i = 2, kmax-1 vm(i) = am(i+1) / ( bm(i) - am(i-1)*vm(i-1) ) enddo do i = 2, kmax um(i) = um(i-1)*am(i-1) / ( bm(i) - am(i-1)*vm(i-1) ) enddo c pd(1) = y0 * sqrt( alphad + betad/dble(rx(1)) ) pd(2) = y1 * sqrt( alphad + betad/dble(rx(2)) ) do i = 2, kmax - 1 pd(i+1) = (pd(i) - um(i)*pd(1))/vm(i) enddo c do i = 1, kmax pd(i) = pd(i)*sqrt(dble(rx(i))/(alphad*dble(rx(i))+betad) ) * & dble(fsc)/2.0D0 /sqrt(dcmplx(b(i)))/ dble(rx(i)) p(i) = cmplx(pd(i)) enddo c kplx3 = kplx - 3 call interp(rx(kplx3),p(kplx3),7,rs,ps,dps,.true.) c x=dps/ps ramff=cmplx(sbf(l+1))*x-cmplx(dsbf(l+1)) c stmat=(shf(l+1)*x-dshf(l+1))/ramff stmat=ramff/(cmplx(shf(l+1))*x-cmplx(dshf(l+1))) ramf=ramff*ps*rs*rs*pi ramf=ramf*xe/pi c c return end c c subroutine pgenll2( l, en, h, rx, v, b, kmax, p, pkmx, pkmx1 ) c c This subroutine for inward integration toward the origin c common /llm/ alpha, beta c complex v(kmax), p(kmax), b(kmax), pkmx, pkmx1 dimension rx(kmax) c double precision dfl, a, hd, hsq12, rxi, den, arb2, & alphad, betad c complex*16 um(0:kmax), vm(0:kmax), am(0:kmax), bm(0:kmax) complex*16 dvi, dnm c data pi/3.14159265/, fsc/7.29735E-3/ c c calculate coefficients um(m) and vm(m). c vm(kmax) = (0.d0,0.d0) um(kmax) = dcmplx(pkmx*sqrt( alpha + beta/rx(kmax) )) alphad = dble(alpha) betad = dble(beta) den = dble(en) dfl = dble(float(l)) a = (dfl + 1)*dfl hd = dble(h) hsq12 = hd*hd/12.d0 c do i = 1, kmax rxi = dble(rx(i)) arb2 = (alphad*rxi + betad)**2 dvi = dcmplx(v(i)) am(i) = 1.d0 + 1.d0/arb2 * ( rxi**2 * (den-dvi) - a - & betad*(alphad*rxi + betad/4.d0)/arb2 )*hsq12 bm(i) = 2.d0*(6.d0 - 5.d0*am(i)) enddo do i = kmax-1, 2, -1 dnm = ( bm(i) - am(i+1)*vm(i+1) ) vm(i) = am(i-1) / dnm um(i) = am(i+1) * um(i+1) / dnm c write(6,*) vm(i), um(i) enddo p(kmax) = pkmx * sqrt( alpha + beta/rx(kmax) ) p(kmax-1) = pkmx1 * sqrt( alpha + beta/rx(kmax-1) ) do i = kmax-1, 2, -1 p(i-1) = ( p(i) - cmplx(um(i))) / cmplx(vm(i)) enddo do i = 1, kmax p(i) = p(i) * sqrt( rx(i)/(alpha*rx(i) + beta) ) * & fsc/2.0 /sqrt(b(i))/ rx(i) enddo return end c C subroutine get_edge_gap(iz,ihole,i_radial,xion,eatom) c c implicit real*8(a-h,o-z) c c parameter ( mp = 251, ms = 30 ) c character*40 title c common dgc(mp,ms),dpc(mp,ms),bidon(630),idummy c dimension dum1(mp), dum2(mp) dimension vcoul(mp), rho0(mp), enp(ms) c title = ' ' c ifr=1 iprint=0 C amass=0.0d0 beta=0.0d0 c call scfdat (title, ifr, iz, ihole, xion, amass, beta, iprint, 1 vcoul, rho0, dum1, dum2, enp, eatom) c return end C C subroutine calc_edge(cip) implicit real*8 (a-h,o-z) real*4 cip c include 'msxas3.inc' include 'msxasc3.inc' c dimension etot(2) c c.....Find out ionization potential for chosen edge c xion=0.0d0 !corrected 23 June 2017 iz = nz(1) ihole1 = 0 c if(edge.eq.'k ') ihole2 = 1 if(edge.eq.'l1') ihole2 = 2 if(edge.eq.'l2') ihole2 = 3 if(edge.eq.'l3') ihole2 = 4 if(edge.eq.'m1') ihole2 = 5 if(edge.eq.'m2') ihole2 = 6 if(edge.eq.'m3') ihole2 = 7 if(edge.eq.'m4') ihole2 = 8 if(edge.eq.'m5') ihole2 = 9 if(edge.eq.'n2') ihole2 = 11 if(edge.eq.'n3') ihole2 = 12 if(edge.eq.'n4') ihole2 = 13 if(edge.eq.'n5') ihole2 = 14 if(edge.eq.'n6') ihole2 = 15 if(edge.eq.'n7') ihole2 = 16 c write(6,*) ' ---' do i = 1, 2 c ityhole = ihole1 c if(i.eq.2) ityhole = ihole2 ----- corrected 23th June 2017 if(i.eq.2) then ityhole = ihole2 xion = 1.0d0 endif c if(i.eq.1) write(6,*) ' total energy for atom in ground state ' if(i.eq.2) write(6,*) ' total energy for atom with a hole in ', & edge, ' edge' c call get_edge_gap(iz,ityhole,ityhole,xion,etot(i)) c enddo c cip = real(etot(2) - etot(1))*2.0 cip = sign(cip,1.0) write(6,*) ' calculated ionization energy for edge ', edge, & ' = ', cip*13.6, ' eV' c c.....Find out energy distance between edges and construct two edge c dipole cross section c xion=1.0d0 c if(edge.eq.'k '.or.edge.eq.'l1'.or.edge.eq.'m1'.or.edge.eq.'n1') & go to 15 if(edge.eq.'l2'.or.edge.eq.'l3') then ihole1 = 3 ihole2 = 4 else if(edge.eq.'m2'.or.edge.eq.'m3') then ihole1 = 6 ihole2 = 7 else if(edge.eq.'m4'.or.edge.eq.'m5') then ihole1 = 8 ihole2 = 9 else if(edge.eq.'n2'.or.edge.eq.'n3') then ihole1 = 11 ihole2 = 12 else if(edge.eq.'n4'.or.edge.eq.'n5') then ihole1 = 13 ihole2 = 14 else if(edge.eq.'n6'.or.edge.eq.'n7') then ihole1 = 15 ihole2 = 16 endif c do i = 1, 2 ityhole = ihole1 if(i.eq.2) ityhole = ihole2 c call get_edge_gap(iz,ityhole,ityhole,xion,etot(i)) c enddo c detot = (etot(1) - etot(2))*2.0d0 detot = sign(detot,1.0d0) if(edge.eq.'l2'.or.edge.eq.'l3') then write(6,*) ' energy distance between edges l2 and l3 = ', & real( etot(1) - etot(2) )* 27.2, 'eV' elseif(edge.eq.'m2'.or.edge.eq.'m3') then write(6,*) ' energy distance between edges m2 and m3 = ', & real( etot(1) - etot(2) )* 27.2, 'eV' elseif(edge.eq.'m4'.or.edge.eq.'m5') then write(6,*) ' energy distance between edges m4 and m5 = ', & real( etot(1) - etot(2) )* 27.2, 'eV' endif c 15 continue c write(6,*) ' ---' c end C C SUBROUTINE RADIALX(NE,RELC,EIKAPPR) INCLUDE 'msxas3.inc' integer at_,d_,rd_,ltot_,sd_ parameter ( at_=nat_-1,d_=ua_-1,ltot_=lmax_+1, $n_=ltot_*ua_,rd_=440,sd_=ua_-1) C c.....this subroutine calculates the radial matrix elements d(i) c.....(i=1,2) for lfin=l0i-1 (i=1) and lfin=l0i+1 (i=2) both for c.....the regular (dmxx) and irregular solution (dmxx1) using a c.....linear-log mesh c common/mtxele/ nstart,nlast c common/mtxelex/ dmxx(2),dmxx1(2),dmxxa(2),dmxxa1(2), & qmxx(3),qmxx1(3),qmxxa(3),qmxxa1(3), & dxxdir,dxxexc complex dmxx,dmxx1,dmxxa,dmxxa1,qmxx,qmxx1,qmxxa,qmxxa1, & dxxdir,dxxexc c common/param/eftr,gamma,vcon,xe,ev,e,iout,nat,ndat,nspins, 1 nas,rs(at_),xv(at_),yv(at_),zv(at_),exfact(at_),z(at_), 3 lmaxx(at_),nz(at_),nsymbl(at_), 4 neq(at_),name0,cip,emax,emin,de complex vcon,ev,xe character*8 nsymbl,name0 c common/bessel/sbf(ltot_),dsbf(ltot_),shf(ltot_),dshf(ltot_) complex*16 sbf,dsbf,shf,dshf C COMMON /LLM/ ALPHA, BETA C COMMON /FCNRLM/X(RDX_,D_), RX(RDX_,D_), HX(D_), VX(RDX_,SD_), & VXR(RDX_,SD_), DVX(RDX_,SD_), BX(RDX_,SD_), & VXSO(RDX_,SD_), KMX(AT_), KPLX(AT_) COMPLEX VX, VXR, DVX, BX, VXSO C C COMMON /PDQX/ PX(RDX_,F_),DPX(RDX_,F_),PSX(F_),DPSX(F_),RAMFX(N_) C COMPLEX PX,DPX,PSX,DPSX,RAMFX c COMMON /PDQX/PX(RDX_,F_), PX0(RDX_,F_), PPX(RDX_,F_), & PAX(RDX_,F_), RAMFNR(N_), RAMFSR(N_), RAMFSOP(N_), & RAMFSOA(N_) COMPLEX PX, PX0, PPX, PAX, RAMFNR, RAMFSR, RAMFSOP, RAMFSOA c C COMMON/PDQIX/RPIX(RDX_), FNISX COMPLEX RPIX C common /state/ natom(n_),ln(n_),nleq(at_), 1 nns,nuatom,ndg,nls(at_),n0l(at_),n0(at_), 2 nterms(at_),lmaxn(at_),ndim,lmxne(at_,nep_) C c ######### common pottype modified to consider also the Auger calcu c common/pot_type/i_absorber,i_absorber_hole,i_absorber_hole1, * i_absorber_hole2,i_norman,i_alpha, 1 i_outer_sphere,i_exc_pot,i_mode c common/auger/calctype,expmode,edge1,edge2 c common/eels/einc,esct,scangl,qt,lambda,eelsme(npss,npss,npss), & p1(rdx_,npss,nef_),p2(rdx_,npss,nef_), & p3(rdx_,npss,nef_),ramfsr1(npss,nef_), & ramfsr2(npss,nef_),ramfsr3(npss,nef_), & lmxels(3,ua_),p3irreg(rdx_,7),p2irreg(rdx_,7) complex eelsme,p1,p2,p3,ramfsr1,ramfsr2,ramfsr3,p3irreg,p2irreg real*4 einc,esct,scangl,qt,lambda complex qtc, arg, ydf, scprod c character*3 calctype, expmode, eikappr character*2 edge1,edge2 C common /lparam/lmax2(nat_),l0i c DIMENSION RID(RDX_),CRI(RDX_),CRI1(RDX_) COMPLEX RID,CRI,CRI1,DX,DX1,SMX0,SMX1 C CHARACTER*2 RELC C C c*************************************************************************** c note that here rpix(k) = r**3*pi(k). c wf rpix(k) is already normalized c (see subroutine corewf) c*************************************************************************** c pi = 3.1415926 c id = 1 nq = nas kx = kmx(nq) - 3 dh = hx(nq) c write(6,*)' check orthogonality between core and continuum', & ' state' np = l0i + 1 do k = 1, kx if(relc.eq.'nr') & rid(k)=rpix(k)*px(k,np+1)/(alpha*rx(k,nq) + beta) if(relc.eq.'sr') & rid(k)=rpix(k)*px0(k,np+1)/(alpha*rx(k,nq) + beta) enddo call defint1(rid,dh,kx,scprod,id) write(6,*)' scalar product between core and continuum', & ' state =', scprod/ramfsr(nstart+np) !*sqrt(xe/pi) write(6,*) ' sqrt(xe/pi) =', sqrt(xe/pi) c if((calctype.eq.'els'.or.calctype.eq.'e2e') & .and.eikappr.eq.'yes') then ydf=(0.0,0.0) qtc = cmplx(qt,0.0) ml=lmxne(nq,ne)+1 if (ml.lt.3) ml = 3 do np = 0, ml-1 do k = 1, kx arg=qtc*rx(k,nq) call csbf(arg,ydf,ml,sbf,dsbf) if(relc.eq.'nr') & rid(k)=rpix(k)*px(k,np+1)*cmplx(sbf(np+1))/ 1 (alpha*rx(k,nq) + beta) if(relc.eq.'sr') & rid(k)=rpix(k)*px0(k,np+1)*cmplx(sbf(np+1))/ 1 (alpha*rx(k,nq) + beta) enddo c call defint1(rid,dh,kx,eelsme(np+1),id) c eelsme(np+1) = (eelsme(np+1)/ramfsr(nstart+np))**2*xe/pi c write(6,*) 'l =',np,'eelsme =', eelsme(np+1) c write(6,*) 'l =',np,'sqrt(eelsme) =', sqrt(eelsme(np+1)) enddo c endif c c 21 if(calctype.eq.'xpd'.or.eikappr.eq.' no') then 21 if (calctype.eq.'xpd'.or.calctype.eq.'xas'.or. & calctype.eq.'rex'.or.eikappr.eq.' no') then c do 100 i=1,2 dmxx(i)=(0.,0.) dmxx1(i)=(0.,0.) if((l0i.eq.0).and.(i.eq.1))goto 100 np = l0i + (-1)**i C if(relc.eq.'nr') then c DO 116 K=1,KX 116 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI,ID) DMXX(I) = (CRI(KX)/RAMFNR(NSTART+NP))**2*(L0I-1+I) c dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i) DO 117 K=1,KX 117 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 118 K=1,KX 118 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,SMX0,ID) DO 119 K=1,KX 119 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,SMX1,ID) DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFNR(NSTART+NP) c dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np) c else if(relc.eq.'sr') then DO K=1,KX RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) ENDDO CALL INTEGRCM(RID,DH,KX,CRI,ID) DMXX(I) = (CRI(KX)/RAMFSR(NSTART+NP))**2*(L0I-1+I) DO 120 K=1,KX 120 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 121 K=1,KX 121 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,SMX0,ID) DO 122 K=1,KX 122 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,SMX1,ID) DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSR(NSTART+NP) c else if(relc.eq.'so') then DO K=1,KX RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) ENDDO CALL INTEGRCM(RID,DH,KX,CRI,ID) DMXX(I) = (CRI(KX)/RAMFSOP(NSTART+NP))**2*(L0I-1+I) DO 123 K=1,KX 123 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 124 K=1,KX 124 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,SMX0,ID) DO 125 K=1,KX 125 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,SMX1,ID) DMXX1(I) = (SMX0 + SMX1)*(L0I-1+I)/RAMFSOP(NSTART+NP) C DO K=1,KX RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) ENDDO CALL INTEGRCM(RID,DH,KX,CRI,ID) DMXXA(I) = (CRI(KX)/RAMFSOA(NSTART+NP))**2*(L0I-1+I) DO 126 K=1,KX 126 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 127 K=1,KX 127 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,DX,ID) DO 128 K=1,KX 128 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,DX1,ID) DMXXA1(I) = (DX + DX1)*(L0I-1+I)/RAMFSOA(NSTART+NP) c endif 100 continue C c write(6,*) ' radialx matrix elements from shell li = ', l0i c write(6,*) (real(dmxx(l)),aimag(dmxx(l)),l=1,2) c write(6,*) (real(dmxx1(l)),aimag(dmxx1(l)),l=1,2) C C.....CALCULATE RADIAL QUADRUPOLAR TRANSITION MATRIX ELEMENT C DO K = 1, KX RPIX(K) = RPIX(K) * RX(K,NQ) ENDDO C M = 0 DO 200 I=-2,2,2 M = M + 1 QMXX(M)=(0.,0.) QMXX1(M)=(0.,0.) LF = L0I + I IF(LF.LE.0) GO TO 200 NP = L0I + I C if(relc.eq.'nr') then c DO 216 K=1,KX 216 RID(K)=RPIX(K)*PX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI,ID) QMXX(M) = (CRI(KX)/RAMFNR(NSTART+NP))**2 c dmx(i) = (cri(kx)/ramf(nstart+np))**2*(l0i-1+i) DO 217 K=1,KX 217 RID(K)=RPIX(K)*PX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 218 K=1,KX 218 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,SMX0,ID) DO 219 K=1,KX 219 RID(K)=RPIX(K)*PX(K,NP+1)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,SMX1,ID) QMXX1(M) = (SMX0 + SMX1)/RAMFNR(NSTART+NP) c dmx1(i) = (dx+dx1)*(l0i-1+i)/ramf(nstart+np) c else if(relc.eq.'sr') then DO K=1,KX RID(K)=RPIX(K)*PX0(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) ENDDO CALL INTEGRCM(RID,DH,KX,CRI,ID) QMXX(M) = (CRI(KX)/RAMFSR(NSTART+NP))**2 DO 220 K=1,KX 220 RID(K)=RPIX(K)*PX0(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 221 K=1,KX 221 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,SMX0,ID) DO 222 K=1,KX 222 RID(K)=RPIX(K)*PX0(K,NP+1)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,SMX1,ID) QMXX1(M) = (SMX0 + SMX1)/RAMFSR(NSTART+NP) c else if(relc.eq.'so') then DO K=1,KX RID(K)=RPIX(K)*PPX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) ENDDO CALL INTEGRCM(RID,DH,KX,CRI,ID) QMXX(M) = (CRI(KX)/RAMFSOP(NSTART+NP))**2 DO 223 K=1,KX 223 RID(K)=RPIX(K)*PPX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 224 K=1,KX 224 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,SMX0,ID) DO 225 K=1,KX 225 RID(K)=RPIX(K)*PPX(K,NP)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,SMX1,ID) QMXX1(M) = (SMX0 + SMX1)/RAMFSOP(NSTART+NP) C DO K=1,KX RID(K)=RPIX(K)*PAX(K,NP+1)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) ENDDO CALL INTEGRCM(RID,DH,KX,CRI,ID) QMXXA(M) = (CRI(KX)/RAMFSOA(NSTART+NP))**2 DO 226 K=1,KX 226 RID(K)=RPIX(K)*PAX(K,NP+1+NPSS)*RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL INTEGRCM(RID,DH,KX,CRI1,ID) DO 227 K=1,KX 227 RID(K)=RID(K)*CRI(K) CALL DEFINT1(RID,DH,KX,DX,ID) DO 228 K=1,KX 228 RID(K)=RPIX(K)*PAX(K,NP+1)*(CRI1(KX) - CRI1(K))* & RX(K,NQ)/(ALPHA*RX(K,NQ) + BETA) CALL DEFINT1(RID,DH,KX,DX1,ID) QMXXA1(M) = (DX + DX1)/RAMFSOA(NSTART+NP) c endif C 200 CONTINUE C C.....RESET RPI(K) TO INITIAL VALUE C DO K = 1, KX RPIX(K) = RPIX(K) / RX(K,NQ) ENDDO C else !PUT AUGER PART HERE C endif C RETURN END C C SUBROUTINE OSBF(X,Y,MAX,SBF,DSBF) C REAL*8 SBFK,SBF1,SBF2,XF1,PSUM IMPLICIT DOUBLE PRECISION (A-H,O-Z) C C GENERATES SPHERICAL BESSEL FUNCTIONS OF ORDER 0 - MAX-1 AND THEIR C FIRST DERIVATIVES WITH RESPECT TO R. X=ARGUMENT= Y*R. C IF Y=0, NO DERIVATIVES ARE CALCULATED. MAX MUST BE AT LEAST 3. C OSBF GENERATES ORDINARY SPHERICAL BESSEL FUNCTIONS. MSBF - MODI- C FIED SPHERICAL BESSEL FUNCTIONS; OSNF - ORD. SPH. NEUMANN FCNS; C MSNF - MOD. SPH. NEUMANN FCNS; MSHF - MOD. SPH HANKEL FCNS C DIMENSION SBF(MAX), DSBF(MAX) LOGICAL ORD ORD=.TRUE. GO TO 1 ENTRY MSBF(X,Y,MAX,SBF,DSBF) ORD=.FALSE. 1 IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 IF( ABS(X).LT.0.50D0 ) GO TO 18 C C BESSEL FUNCTIONS BY DOWNWARD RECURSION C SBF2=0.0D0 SBF1=1.0D-25 IF( ABS(X).LT.2.0D0) SBF1=1.0D-38 JMIN=10+X KMAX=MAX+JMIN-1 K=MAX XF1=2*KMAX+1 IF (ORD) GO TO 11 DO 10 J=1,KMAX SBFK=XF1*SBF1/X+SBF2 SBF2=SBF1 SBF1=SBFK IF (J.LT.JMIN) GO TO 10 SBF(K)=SBFK K=K-1 10 XF1=XF1-2.0D0 RAT=SINH(X)/(X*SBF(1)) DSBF1=SBF2*RAT GO TO 16 11 CONTINUE DO 12 J=1,KMAX SBFK=XF1*SBF1/X-SBF2 SBF2=SBF1 SBF1=SBFK XF1=XF1-2.0D0 IF (J.LT.JMIN) GO TO 12 SBF(K)=SBFK K=K-1 12 CONTINUE 15 RAT=SIN(X)/(X*SBF(1)) DSBF1=-SBF2*RAT 16 DO 17 K=1,MAX 17 SBF(K)=RAT*SBF(K) GO TO 26 C C SMALL ARGUMENTS C 18 Z=X*X*0.50D0 IF(ORD) Z=-Z A=1.0D0 MMX=MAX IF (MAX.EQ.1.AND.Y.NE.0.0D0) MMX=2 DO 30 J=1,MMX SBFJ=A B=A DO 31 I=1,20 B=B*Z/(I*(2*(J+1)-1)) SBFJ=SBFJ+B IF ( ABS(B).LE.1.0D-07* ABS(SBFJ )) GO TO 29 31 CONTINUE 29 IF (J.EQ.2) DSBF1=SBFJ IF (J.LE.MAX) SBF(J)=SBFJ 30 A=A*X/ DFLOAT(2*J+1) IF (ORD) DSBF1=-DSBF1 GO TO 26 ENTRY OSNF(X,Y,MAX,SBF,DSBF) ORD=.TRUE. SBF2=-COS(X)/X IF (MAX.EQ.1 .AND. Y.EQ.0.0D0) GO TO 2 SBF1=(SBF2-SIN(X))/X DSBF1=-SBF1 GO TO 2 ENTRY MSNF(X,Y,MAX,SBF,DSBF) ORD=.FALSE. SBF2=COSH(X)/X IF (MAX.EQ.1 .AND. Y.EQ.0.0D0) GO TO 2 SBF1=(SINH(X)-SBF2)/X DSBF1= SBF1 GO TO 2 ENTRY MSHF(X,Y,MAX,SBF,DSBF) ORD=.FALSE. SBF2=EXP(-X)/X SBF1=-SBF2/X-SBF2 DSBF1= SBF1 2 SBF(1)=SBF2 IF (MAX.LT.1.OR.MAX.GT.2000) GO TO 99 IF (MAX.EQ.1) GO TO 26 SBF(2)=SBF1 IF (MAX.EQ.2) GO TO 26 XF1=3.0D0 IF (ORD) GO TO 21 DO 8 I=3,MAX SBFK=SBF2-XF1*SBF1/X SBF(I)=SBFK SBF2=SBF1 SBF1=SBFK 8 XF1=XF1+2.0D0 GO TO 26 21 DO 22 I=3,MAX SBFK=XF1*SBF1/X-SBF2 SBF(I)=SBFK SBF2=SBF1 SBF1=SBFK 22 XF1=XF1+2.0D0 26 IF (Y.EQ.0.0D0) RETURN DSBF(1)=Y*DSBF1 IF (MAX.EQ.1) RETURN DO 9 I=2,MAX 9 DSBF(I)=Y*(SBF(I-1)- DFLOAT(I)*SBF(I)/X) RETURN 99 WRITE(6,100) MAX 100 FORMAT (' SPHERICAL BESSEL FUNCTION ROUTINE - MAX=',I8) STOP 2013 C END C