./src/0000775004704100470410000000000011202701473011623 5ustar natalienatalie./src/aeatom.f900000644004704100470410000011012711202701404013403 0ustar natalienatalieMODULE AEatom USE GlobalMath USE excor USE radialsch USE radialsr USE calcpotential USE anderson_realmix USE atomdata IMPLICIT NONE REAL(8), PARAMETER, PRIVATE ::small0=1.d-15,rimix=0.5d0,worst=1.d-5 REAL(8), PARAMETER, PRIVATE ::linrange=50.d0,linh=0.0025d0,mxgridlin=20001 REAL(8), PARAMETER, PRIVATE ::logrange=80.d0,logh=0.020d0,mxgridlog=2001 INTEGER, PARAMETER, PRIVATE :: niter=1000,mxloop=500 REAL(8), PARAMETER, PRIVATE :: conv1=4.d13,conv2=3.d13,conv3=2.d13,conv4=1.d13 INTEGER, PRIVATE :: nps,npp,npd,npf,npg,norbit,nz,n REAL(8), PRIVATE :: h, electrons CONTAINS SUBROUTINE iSCFatom(AEGrid,AEPot,AEOrbit,AESCF,ifinput) TYPE (GridInfo), INTENT(INOUT) :: AEGrid TYPE (PotentialInfo), INTENT(INOUT) :: AEPot TYPE (OrbitInfo), INTENT(INOUT) :: AEOrbit TYPE (SCFInfo), INTENT(INOUT) :: AESCF INTEGER, INTENT(IN),OPTIONAL :: ifinput ! program to calculate the self-consistent density functional ! atom ground state for atom with atomic number nz ! for self-consistent potential rv REAL(8) :: xocc,qf,small,range,zeff,hval,gridmatch,gridrange REAL(8) :: qcal, rescale INTEGER :: icount,i,j,k,it,start,np,ierr,gridpoints INTEGER :: is,ip,id,jf,ig,io,l,nfix,ir,nzeff INTEGER :: ilin,ilog,inrl,iscl,ipnt,ifin,iend INTEGER, ALLOCATABLE :: nl(:,:) CHARACTER(128) :: exchangecorrelationandgridline,gridkey,relkey CHARACTER(132) :: inputline,inputword scalarrelativistic=.false.; finitenucleus=.false. WRITE(6,*) 'enter atomic symbol and atomic number' If (present(ifinput)) then READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) AEPot%sym,nz else READ(5,*) AEPot%sym,nz endif AEPot%nz=nz WRITE(6,*) 'exchange-correlation type -- LDA-PW(default) or GGA-PBE ' WRITE(6,*) 'further optionally (space) "nonrelativistic/scalarrelativistic" keyword' WRITE(6,*) 'further optionally (space) "point-nucleus/finite-nucleus" keyword' WRITE(6,*) 'optionally (space) "loggrid/lineargrid" keyword if appropriate' WRITE(6,*) ' further optionally n (number of grid points)' WRITE(6,*) ' r_max (max. grid radius)' WRITE(6,*) ' r_match (exact value of r(n))' READ(5,'(a)') exchangecorrelationandgridline if(present(ifinput)) WRITE(ifinput,'(a)')& TRIM(exchangecorrelationandgridline) call Uppercase(exchangecorrelationandgridline) exchangecorrelationandgridline=trim(exchangecorrelationandgridline) READ(unit=exchangecorrelationandgridline,fmt=*) exctype ilin=INDEX(exchangecorrelationandgridline,'LINEARGRID') ilog=INDEX(exchangecorrelationandgridline,'LOGGRID') inrl=INDEX(exchangecorrelationandgridline,'NONRELATIVISTIC') iscl=INDEX(exchangecorrelationandgridline,'SCALARRELATIVISTIC') ipnt=INDEX(exchangecorrelationandgridline,'POINT-NUCLEUS') ifin=INDEX(exchangecorrelationandgridline,'FINITE-NUCLEUS') if (iscl>0.and.inrl==0) scalarrelativistic=.true. if (ifin>0.and.ipnt==0) finitenucleus=.true. gridkey='LINEAR';gridpoints=mxgridlin;gridrange=linrange;gridmatch=linrange if (ilog>0.and.ilin==0) then gridkey='LOGGRID';gridpoints=mxgridlog;gridrange=logrange;gridmatch=logrange endif i=max(ilin,ilog);j=max(inrl,iscl);k=max(ipnt,ifin) if (i>0) then iend=128 if (j>i) iend=j-1 if (k>i.and.k0.and.iend>i+7) inputline=trim(exchangecorrelationandgridline(i+7:iend)) if (ilin>0.and.iend>i+10)inputline=trim(exchangecorrelationandgridline(i+10:iend)) if (inputline/="") then call extractword(1,inputline,inputword);inputword=trim(inputword) if (inputword/="") then read(inputword,*) gridpoints call extractword(2,inputline,inputword);inputword=trim(inputword) if (inputword/="") then read(inputword,*) gridrange gridmatch=gridrange call extractword(3,inputline,inputword);inputword=trim(inputword) if (inputword/="") read(inputword,*) gridmatch endif endif endif endif WRITE(6,*) 'Calculation for atomic number = ',nz WRITE(6,*) 'enter maximum principal quantum numbers for s,p,d,f,g' if(present(ifinput)) then READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) nps,npp,npd,npf,npg else READ(5,*) nps,npp,npd,npf,npg endif IF(nps<0)nps=0 IF(npp<0)npp=0 IF(npd<0)npd=0 IF(npf<0)npf=0 IF(npg<0)npg=0 WRITE(6,'(5i4)') nps,npp,npd,npf,npg i=MAX(nps,npp,npd,npf,npg) j=nps+npp+npd+npf+npg ALLOCATE(nl(i,j),AEOrbit%np(j),AEOrbit%l(j),& AEOrbit%eig(j),AEOrbit%occ(j),stat=k) IF (k/=0) THEN WRITE(6,*) 'Error in allocation of nl,np...',k STOP ENDIF nl=0;AEOrbit%np=0;AEOrbit%l=0;AEOrbit%eig=0;AEOrbit%occ=0 icount=0 IF (nps.GT.0) THEN DO is=1,nps icount=icount+1 nl(is,1)=icount AEOrbit%occ(icount)=2.d0 AEOrbit%np(icount)=is AEOrbit%l(icount)=0 ENDDO ENDIF IF (npp.GT.1) THEN DO ip=2,npp icount=icount+1 nl(ip,2)=icount AEOrbit%occ(icount)=6.d0 AEOrbit%np(icount)=ip AEOrbit%l(icount)=1 ENDDO ENDIF IF (npd.GT.2) THEN DO id=3,npd icount=icount+1 nl(id,3)=icount AEOrbit%occ(icount)=10.d0 AEOrbit%np(icount)=id AEOrbit%l(icount)=2 ENDDO ENDIF IF (npf.GT.3) THEN DO jf=4,npf icount=icount+1 nl(jf,4)=icount AEOrbit%occ(icount)=14.d0 AEOrbit%np(icount)=jf AEOrbit%l(icount)=3 ENDDO ENDIF IF(npg.GT.4) THEN DO ig=5,npg icount=icount+1 nl(ig,5)=icount AEOrbit%occ(icount)=18.d0 AEOrbit%np(icount)=ig AEOrbit%l(icount)=4 ENDDO ENDIF norbit=icount AEOrbit%nps=nps AEOrbit%npp=npp AEOrbit%npd=npd AEOrbit%npf=npf AEOrbit%npg=npg AEOrbit%norbit=norbit WRITE(6,*) norbit, ' orbitals will be calculated' ! WRITE(6,*)' Below are listed the default occupations ' WRITE(6,"(' n l occupancy')") DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1pe15.7)') & AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) ENDDO ! WRITE(6,*)' enter np l occ for all occupations for all revisions' WRITE(6,*)' enter 0 0 0. to end' DO if(present(ifinput)) then READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) ip,l,xocc else READ(5,*) ip,l,xocc endif IF (ip.LE.0) EXIT nfix=nl(ip,l+1) IF (nfix.LE.0.OR.nfix.GT.norbit) THEN WRITE(6,*) 'error in occupations -- ip,l,xocc', & ip,l,xocc,nfix,norbit STOP ENDIF AEOrbit%occ(nfix)=xocc ENDDO ! WRITE(6,*) ' Corrected occupations are: ' WRITE(6,"(' n l occupancy')") electrons=0.d0 DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1pe15.7)')& AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) electrons=electrons+AEOrbit%occ(io) ENDDO AEPot%q=electrons qf=nz-electrons WRITE(6,*) WRITE(6,*) 'nuclear charge = ' , nz WRITE(6,*) 'electronic charge = ', electrons WRITE(6,*) 'net charge = ', qf ! if (trim(gridkey)=='LOGGRID') then hval=logh;call findh(nz,gridmatch,gridpoints,hval) Call initgrid(AEGrid,hval,gridrange,hval/nz) else hval=gridmatch/dble(gridpoints-1) Call initgrid(AEGrid,hval,gridrange) endif call InitPotential(AEGrid,AEPot) if (scalarrelativistic) Call Allocate_Scalar_Relativistic(AEGrid) n=AEGrid%n ALLOCATE(AEOrbit%wfn(n,j),stat=k) IF (k/=0) THEN WRITE(6,*) 'Error in allocation of wfn,...',k STOP ENDIF ! ! calculate initial charge density from hydrogen-like functions ! also initial energies ! AEPot%den(1:n)=0.d0 zeff=nz DO io=1,norbit np=AEOrbit%np(io) l=AEOrbit%l(io) xocc=AEOrbit%occ(io) zeff=zeff-0.5d0*xocc zeff=MAX(zeff,1.d0) nzeff=zeff+0.1d0 ! no longer used AEOrbit%eig(io)=-(zeff/(np))**2 WRITE(6,*) io,np,l,xocc,AEOrbit%eig(io) DO ir=1,n AEOrbit%wfn(ir,io)=hwfn(zeff,np,l,AEGrid%r(ir)) AEPot%den(ir)=AEPot%den(ir)+xocc*(AEOrbit%wfn(ir,io)**2) ENDDO zeff=zeff-0.5d0*xocc ENDDO ! ! check charge ! qcal=integrator(AEGrid,AEPOT%den) qf=qcal WRITE(6,*) 'qcal electrons = ',qcal, electrons ! rescale density rescale=electrons/qcal AEPot%den(1:n)=AEPot%den(1:n)*rescale ! ! choose form of exchange-correlation potential CALL initexch ! DEALLOCATE(nl) CALL SCFloop(AEGrid,AEPot,AEOrbit,AESCF) END SUBROUTINE iSCFatom SUBROUTINE SCFloop(AEGrid,AEPot,AEOrbit,AESCF) TYPE (GridInfo), INTENT(INOUT) :: AEGrid TYPE (PotentialInfo), INTENT(INOUT) :: AEPot TYPE (OrbitInfo), INTENT(INOUT) :: AEOrbit TYPE (SCFInfo), INTENT(INOUT) :: AESCF ! program to perform self-consistency loop TYPE (Anderson_Context) , POINTER :: AErho REAL(8) :: rmix,xocc,qf,small,range,zeff,delta,v1,v2,v3,v4,x,y REAL(8) :: qcal, rescale,cnvrg,emin,ecoul,eexc,etxc,eone,etot,ekin INTEGER :: icount,i,j,k,it,start,np,ierr,nroot INTEGER :: is,ip,id,jf,ig,io,l,nfix,ir,nzeff,loop,jierr REAL(8), ALLOCATABLE :: denout(:) INTEGER :: fcount=0 v1=conv1;v2=conv2;v3=conv3;v4=conv4 n=AEGrid%n; h=AEGrid%h rmix=rimix cnvrg=worst IF (small.LT.0.d0.OR.small.GT.1.d0) small=small0 WRITE(6,*) 'Density convergence parameter set to at least',cnvrg ! ALLOCATE(denout(n),STAT=k) IF (k /= 0) THEN WRITE(6,*) 'Error in denout allocation ', n,k STOP ENDIF ! start iteration loop ! DO loop=1,mxloop ! calculate potential * r == rv for given density ! CALL potential(AEGrid,AEPot,ecoul,etxc,eexc) denout=0 denout(2:n)=-2*nz*AEPot%den(2:n)/AEGrid%r(2:n) AESCF%estatic=integrator(AEGrid,denout)+ecoul ! ! solve for bound states of Schroedinger equation ! icount=0 qf=nz-electrons jierr=0 it=0 ! s states : IF (nps.GT.0) THEN it=it+1 emin=-nz*nz l=0 nroot=nps start=1 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! p states : IF (npp.GT.1) THEN it=it+1 emin=-nz*nz/4.d0 l=1 nroot=npp-1 start=start+nps if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! d states : IF (npd.GT.2) THEN it=it+1 emin=-nz*nz/9.d0 l=2 nroot=npd-2 start=start+npp-1 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! f states : IF (npf.GT.3) THEN it=it+1 emin=-nz*nz/16.d0 l=3 nroot=npf-3 start=start+npd-2 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! g states : IF (npg.GT.4) THEN it=it+1 emin=-nz*nz/25.d0 l=4 nroot=npg-4 start=start+npf-3 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! ! calculate new density ! denout(1:n)=0.d0 WRITE(6,*) ' results for loop = ',loop WRITE(6,*) ' n l occupancy energy' DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) IF (AEOrbit%occ(io).GT.small) THEN DO i=1,n denout(i)=denout(i)+AEOrbit%occ(io)*(AEOrbit%wfn(i,io)**2) ENDDO ENDIF ENDDO qcal=integrator(AEGrid,denout) WRITE(6,*) 'qcal electrons = ',qcal, electrons ! rescale density rescale=electrons/qcal denout(1:n)=denout(1:n)*rescale !fcount=fcount+1 !do i=1,n ! write(fcount+100,'(1p2e15.7)') AEGrid%r(i),denout(i) !enddo ! denout=denout-AEPot%den delta=SUM(ABS(denout)) CALL shift4(v1,v2,v3,v4,delta) WRITE(6,*) 'density iter',loop,delta IF (loop.EQ.1) CALL InitAnderson(AErho,6,5,n,rmix,1.d5) CALL Anderson_Mix(AErho,AEPot%den(1:n),denout(1:n)) ! correct and recale density DO i=1,n IF (AEPot%den(i).LT.0.d0) AEPot%den(i)=0.d0 ENDDO qcal=integrator(AEGrid,AEPot%den) WRITE(6,*) 'qcal electrons = ',qcal, electrons ! rescale density rescale=electrons/qcal AEPot%den(1:n)=AEPot%den(1:n)*rescale ! WRITE(6,*) ' results for loop ,delta = ',loop,delta WRITE(6,*) ' n l occupancy energy' eone=0.d0 DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) eone=eone+AEOrbit%occ(io)*AEOrbit%eig(io) ENDDO WRITE(6,*) WRITE(6,*) ' Total energies' WRITE(6,*) ' One-electron contribution: ',eone WRITE(6,*) ' Coulomb contribution : ',ecoul WRITE(6,*) ' Exch-correl contribution : ',eexc etot=eone-ecoul+etxc WRITE(6,*) ' Total : ',etot ! IF (loop>=4) THEN IF (.NOT.(v4.LE.v3.AND.v3.LE.v2 & .AND.v2.LE.v1).AND.v4.LE.cnvrg) THEN ! ! converged result ! WRITE(6,*) ' dfatom converged in',loop,' iterations' AESCF%iter=loop WRITE(6,*) ' for nz = ',nz WRITE(6,*) ' delta(density) = ', delta AESCF%delta=delta WRITE(6,*) ' results for loop = ',loop WRITE(6,*) ' n l occupancy energy' eone=0.d0 ekin=0.0 DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) eone=eone+AEOrbit%occ(io)*AEOrbit%eig(io) !CALL kinetic(AEGrid,AEOrbit%l(io),& ! AEOrbit%wfn(:,io),x) !CALL altkinetic(AEGrid,AEOrbit%wfn(:,io),AEOrbit%eig(io)& ! ,AEPot%rv,y) !WRITE(6,*) 'Kinetic compare',io,x,y CALL altkinetic(AEGrid,AEOrbit%wfn(:,io),AEOrbit%eig(io)& ,AEPot%rv,x) ekin=ekin+AEOrbit%occ(io)*x ENDDO WRITE(6,*) WRITE(6,*) ' Total energies' WRITE(6,*) ' One-electron contribution: ',eone AESCF%eone=eone WRITE(6,*) ' Kinetic energy contribution:',ekin AESCF%ekin=ekin WRITE(6,*) ' Coulomb contribution : ',ecoul AESCF%ecoul=ecoul WRITE(6,*) ' Electrostatic contribution: ',AESCF%estatic WRITE(6,*) ' Exch-correl contribution : ',eexc AESCF%eexc=eexc etot=eone-ecoul+etxc AESCF%etot=etot WRITE(6,*) ' Total : ',etot WRITE(6,*) ' Total (alt form) : ',& AESCF%ekin+AESCF%estatic+AESCF%eexc CALL FreeAnderson(AErho) DEALLOCATE(denout) RETURN ENDIF ENDIF ENDDO ! mxloop WRITE(6,*)'calculation terminating without density convergence' WRITE(6,*) 'delta, cnvrg =', delta,cnvrg WRITE(6,*) 'loop,mxloop = ',loop,mxloop CALL FreeAnderson(AErho) DEALLOCATE(denout) STOP END SUBROUTINE SCFloop SUBROUTINE cSCFatom(AEGrid,AEPot,AEOrbit,AESCF) TYPE (GridInfo), INTENT(INOUT) :: AEGrid TYPE (PotentialInfo), INTENT(INOUT) :: AEPot TYPE (OrbitInfo), INTENT(INOUT) :: AEOrbit TYPE (SCFInfo), INTENT(INOUT) :: AESCF ! program to calculate the self-consistent density functional ! atom ground state for atom with atomic number nz ! for self-consistent potential rv ! version for changing configuration after initial ! SCF run REAL(8) :: xocc,qf,small,range,zeff REAL(8) :: qcal, rescale INTEGER :: icount,i,j,k,it,start,np,ierr INTEGER :: is,ip,id,jf,ig,io,l,nfix,ir,nzeff INTEGER, ALLOCATABLE :: nl(:,:) WRITE(6,*) norbit, ' orbitals will be calculated' ! WRITE(6,*)' Below are listed the current occupations ' WRITE(6,"(' n l occupancy')") DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1pe15.7)') & AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) ENDDO ! WRITE(6,*)' enter np l occ for all occupations for all revisions' WRITE(6,*)' enter 0 0 0. to end' DO READ(5,*) ip,l,xocc IF (ip.LE.0) EXIT nfix=-100 DO io=1,norbit IF (ip==AEOrbit%np(io).AND.l==AEOrbit%l(io)) THEN nfix=io EXIT ENDIF ENDDO IF (nfix.LE.0.OR.nfix.GT.norbit) THEN WRITE(6,*) 'error in occupations -- ip,l,xocc', & ip,l,xocc,nfix,norbit STOP ENDIF AEOrbit%occ(nfix)=xocc ENDDO ! WRITE(6,*) ' Corrected occupations are: ' WRITE(6,"(' n l occupancy')") electrons=0.d0 DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1pe15.7)')& AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) electrons=electrons+AEOrbit%occ(io) ENDDO AEPot%q=electrons qf=nz-electrons WRITE(6,*) WRITE(6,*) 'nuclear charge = ' , nz WRITE(6,*) 'electronic charge = ', electrons WRITE(6,*) 'net charge = ', qf ! ! ! calculate initial charge density from stored wavefunctions ! also initial energies ! AEPot%den(1:n)=0.d0 DO io=1,norbit xocc=AEOrbit%occ(io) DO ir=1,n AEPot%den(ir)=AEPot%den(ir)+xocc*(AEOrbit%wfn(ir,io)**2) ENDDO ENDDO ! ! check charge ! qcal=integrator(AEGrid,AEPOT%den) qf=qcal WRITE(6,*) 'qcal electrons = ',qcal, electrons ! rescale density rescale=electrons/qcal AEPot%den(1:n)=AEPot%den(1:n)*rescale ! CALL SCFloop(AEGrid,AEPot,AEOrbit,AESCF) END SUBROUTINE cSCFatom SUBROUTINE ChooseValence(Grid,Orbit,FC,ifinput) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Orbitinfo), INTENT(IN) :: Orbit TYPE(FCinfo), INTENT(INOUT) :: FC INTEGER, INTENT(IN), OPTIONAL :: ifinput CHARACTER(1) :: answer INTEGER :: io,n,ok,norbit CHARACTER(132) :: inputline norbit=Orbit%norbit n=Grid%n ALLOCATE(FC%iscore(norbit),FC%coreden(n),FC%valeden(n),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in FC%coreden allocation',n STOP ENDIF FC%norbit=norbit WRITE(6,*) 'for each state enter c for core or v for valence' FC%zcore=0; FC%zvale=0 FC%coreden=0; FC%valeden=0 DO io=1,FC%norbit WRITE(6,'(3i5,1p2e15.7)') io,Orbit%np(io),Orbit%l(io),& Orbit%occ(io),Orbit%eig(io) DO if (present(ifinput)) then READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) answer else READ(5,*) answer endif IF (answer.NE.'c'.AND.answer.NE.'C'.AND.answer.NE.'v'& .AND.answer.NE.'V') THEN WRITE(6,*) 'Please input c or v' ELSE EXIT ENDIF ENDDO IF (answer.EQ.'c'.OR.answer.EQ.'C') FC%iscore(io)=.true. IF (answer.EQ.'v'.OR.answer.EQ.'V') FC%iscore(io)=.false. IF (FC%iscore(io)) then FC%zcore=FC%zcore+Orbit%occ(io) FC%coreden=FC%coreden+Orbit%occ(io)*(Orbit%wfn(:,io))**2 ENDIF IF (.NOT.FC%iscore(io)) then FC%zvale=FC%zvale+Orbit%occ(io) FC%valeden=FC%valeden+Orbit%occ(io)*(Orbit%wfn(:,io))**2 ENDIF ENDDO END SUBROUTINE ChooseValence !*********************************************************************** ! Subroutine FCenergy -- ! Calculates valence energy of atom given fixed FC%coreden ! reference: U. von Barth and C. D. Gelatt, Phys. Rev. B 21, 2222(1980) !*********************************************************************** SUBROUTINE FCenergy(Grid,Pot,Orbit,SCF,FC) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Potentialinfo), INTENT(IN) :: Pot TYPE(Orbitinfo), INTENT(IN) :: Orbit TYPE(SCFInfo), INTENT(INOUT) :: SCF TYPE(FCinfo), INTENT(INOUT) :: FC INTEGER :: n,nz,i,io,ok REAL(8) :: h REAL(8) :: qtot,qchk,qcore,qvale,y REAL(8) :: etotal,ec,ev,ecv,tc,tv,ekin,cext,vext,tmp REAL(8) :: ccoul,vcoul,cvcoul,chkcvcoul1,chkcvcoul2 REAL(8) :: cexc,vexc,texc REAL(8), ALLOCATABLE :: den(:),dum1(:),dum2(:),dum3(:) n=Grid%n h=Grid%h nz=Pot%nz ALLOCATE(den(n),dum1(n),dum2(n),dum3(n), stat=ok) IF(ok/=0) THEN WRITE(6,*) ' Error in FCenergy allocation ' , n STOP ENDIF FC%valeden(1:n)=0.d0 DO io=1,FC%norbit IF (.NOT.FC%iscore(io)) THEN DO i=1,n FC%valeden(i)=FC%valeden(i)+Orbit%occ(io)*(Orbit%wfn(i,io)**2) ENDDO ENDIF ENDDO DO i=1,n den(i)=FC%coreden(i)+FC%valeden(i) ENDDO ! etotal=0 ec=0 ev=0 ecv=0 ! kinetic energy tc=0 tv=0 DO io=1,FC%norbit IF (FC%iscore(io)) THEN !CALL kinetic(Grid,Orbit%l(io),Orbit%wfn(:,io),ekin) !CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io)& ! ,Pot%rv,y) ! WRITE(6,*) 'Kinetic compare',io,ekin,y CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io)& ,Pot%rv,ekin) tc=tc+Orbit%occ(io)*ekin ELSE IF (.NOT.FC%iscore(io)) THEN !CALL kinetic(Grid,Orbit%l(io),Orbit%wfn(:,io),ekin) !CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io)& ! ,Pot%rv,y) ! WRITE(6,*) 'Kinetic compare',io,ekin,y CALL altkinetic(Grid,Orbit%wfn(:,io),Orbit%eig(io)& ,Pot%rv,ekin) tv=tv+Orbit%occ(io)*ekin ELSE WRITE(6,*) 'Error in Kinetic energy loop of FCenergy',io STOP ENDIF ENDDO WRITE(6,*) 'core and valence kinetic energies', tc,tv FC%corekin=tc ! external potential interaction dum1=0;dum2=0 DO i=2,n dum1(i)=FC%coreden(i)/Grid%r(i) dum2(i)=FC%valeden(i)/Grid%r(i) ENDDO cext=-2*nz*integrator(Grid,dum1) vext=-2*nz*integrator(Grid,dum2) WRITE(6,*) 'core and valence external potential energies',cext,vext ! qcore=integrator(Grid,FC%coreden) qvale=integrator(Grid,FC%valeden) qtot=qcore+qvale qchk=integrator(Grid,den) WRITE(6,*) 'qcore,qvale,qtot,qchk=', qcore,qvale,qtot,qchk WRITE(6,*) 'zcore,zvale = ', FC%zcore,FC%zvale CALL poisson(Grid,qcore,FC%coreden,dum3,ccoul) chkcvcoul1=overlap(Grid,dum3,dum2) CALL poisson(Grid,qvale,FC%valeden,dum3,vcoul) chkcvcoul2=overlap(Grid,dum3,dum1) CALL poisson(Grid,qtot,den,dum3,cvcoul) CALL exch(Grid,FC%coreden,dum3,tmp,cexc) CALL exch(Grid,FC%valeden,dum3,tmp,vexc) CALL exch(Grid,den,dum3,tmp,texc) cvcoul=cvcoul-vcoul-ccoul WRITE(6,*) 'core , valence and interaction coulomb energies' WRITE(6,*) ccoul,vcoul,cvcoul,chkcvcoul1,chkcvcoul2 WRITE(6,*) 'core , valence and interaction exc energies' WRITE(6,*) cexc,vexc,texc ec=tc+ccoul+cext+cexc ev=tv+vcoul+vext+vexc ecv=cvcoul+texc-cexc-vexc etotal=ec+ev+ecv SCF%etot=etotal !FC%evale=tv+vcoul+vext+cvcoul+texc-cexc FC%evale=tv+vcoul+vext+cvcoul+texc WRITE(6,*) 'ec = ',ec WRITE(6,*) 'ev = ',ev WRITE(6,*) 'ecv = ', ecv WRITE(6,*) 'etotal = ',etotal WRITE(6,*) 'evale = ',FC%evale DEALLOCATE(den,dum1,dum2,dum3) END SUBROUTINE FCenergy SUBROUTINE FCselfenergy(Grid,Orbit,FC,selfenergy) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Orbitinfo), INTENT(IN) :: Orbit TYPE(FCinfo), INTENT(IN) :: FC REAL(8), INTENT(OUT) :: selfenergy INTEGER :: n,i,io,norbit REAL(8) :: h,x,y REAL(8), allocatable :: dum1(:),dum2(:) n=Grid%n h=Grid%h ALLOCATE(dum1(n),dum2(n),stat=i) if(i/=0) then write(6,*) 'Allocation error in FCselfenergy', i,n stop endif selfenergy=0 DO io=1,FC%norbit IF (.NOT.FC%iscore(io).and.Orbit%occ(io)>1.d-6) THEN dum1=0 DO i=1,n dum1(i)=dum1(i)+(Orbit%wfn(i,io)**2) ENDDO x=integrator(Grid,dum1) dum1=dum1/x x=1.d0 call poisson(Grid,x,dum1,dum2,y) write(6,*) 'Self energy contribution ', io,Orbit%occ(io),y selfenergy=selfenergy+Orbit%occ(io)*y ENDIF ENDDO write(6,*) 'Total valence self energy contribution ', selfenergy deallocate(dum1,dum2) END SUBROUTINE FCselfenergy SUBROUTINE FCSCFatom(AEGrid,AEPot,AEOrbit,FCOrbit,AESCF,FC) TYPE (GridInfo), INTENT(INOUT) :: AEGrid TYPE (PotentialInfo), INTENT(INOUT) :: AEPot TYPE (OrbitInfo), INTENT(INOUT) :: AEOrbit TYPE (OrbitInfo), INTENT(INOUT) :: FCOrbit TYPE (SCFInfo), INTENT(INOUT) :: AESCF TYPE (FCinfo), INTENT(INOUT) :: FC ! program to calculate the self-consistent density functional ! atom ground state for atom with atomic number nz ! for self-consistent potential rv ! version for changing configuration after initial ! SCF run and for fixing "frozen" core REAL(8) :: xocc,qf,small,range,zeff REAL(8) :: qcal, rescale INTEGER :: icount,i,j,k,it,start,np,ierr,n INTEGER :: is,ip,id,jf,ig,io,l,nfix,ir,nzeff INTEGER, save :: init=0 if (init==0) then call ChooseValence(AEGrid,AEOrbit,FC) init=1 endif write(6,*) 'completed ChooseValence -- norbit = ', FC%norbit,AEOrbit%norbit norbit=AEOrbit%norbit ; n=AEGrid%n WRITE(6,*) 'Frozen core calculation ' ! setup FCOrbit data structure FCOrbit%norbit=AEOrbit%norbit FCOrbit%nps=AEOrbit%nps FCOrbit%npp=AEOrbit%npp FCOrbit%npd=AEOrbit%npd FCOrbit%npf=AEOrbit%npf FCOrbit%npg=AEOrbit%npg Allocate(FCOrbit%np(norbit),FCOrbit%l(norbit),FCOrbit%eig(norbit),& FCOrbit%occ(norbit),FCOrbit%wfn(n,norbit),stat=i) if (i /= 0) then write(6,*) ' Allocation error in FCSCFatom ',i,norbit,n stop endif FCOrbit%np(1:norbit)=AEOrbit%np(1:norbit) FCOrbit%l(1:norbit)=AEOrbit%l(1:norbit) FCOrbit%eig(1:norbit)=AEOrbit%eig(1:norbit) FCOrbit%occ(1:norbit)=AEOrbit%occ(1:norbit) FCOrbit%wfn(:,1:norbit)=AEOrbit%wfn(:,1:norbit) ! WRITE(6,*)' Below are listed the core states' WRITE(6,"(' n l occupancy')") DO io=1,norbit if (FC%iscore(io)) WRITE(6,'(i2,1x,i2,4x,1pe15.7)') & AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) ENDDO WRITE(6,*)' Below are listed the current valence occupations ' WRITE(6,"(' n l occupancy')") DO io=1,norbit if (.NOT.FC%iscore(io)) WRITE(6,'(i2,1x,i2,4x,1pe15.7)') & AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) ENDDO ! WRITE(6,*)' enter np l occ for all occupations for all revisions' WRITE(6,*)' enter 0 0 0. to end' DO READ(5,*) ip,l,xocc IF (ip.LE.0) EXIT nfix=-100 DO io=1,norbit IF (ip==AEOrbit%np(io).AND.l==AEOrbit%l(io)& .AND.(.NOT.FC%iscore(io))) THEN nfix=io EXIT ENDIF ENDDO IF (nfix.LE.0.OR.nfix.GT.norbit) THEN WRITE(6,*) 'error in occupations -- ip,l,xocc', & ip,l,xocc,nfix,norbit STOP ENDIF AEOrbit%occ(nfix)=xocc; FCOrbit%occ(nfix)=xocc ENDDO ! WRITE(6,*) ' Corrected occupations are: ' WRITE(6,"(' n l occupancy')") electrons=0.d0 DO io=1,norbit if (.NOT.FC%iscore(io))then WRITE(6,'(i2,1x,i2,4x,1pe15.7)')& AEOrbit%np(io),AEOrbit%l(io),AEOrbit%occ(io) electrons=electrons+AEOrbit%occ(io) endif ENDDO AEPot%q=electrons+FC%zcore FC%zvale=electrons qf=nz-electrons-FC%zcore WRITE(6,*) WRITE(6,*) 'nuclear charge = ' , nz WRITE(6,*) 'core charge = ' , FC%zcore WRITE(6,*) 'electronic charge = ', electrons WRITE(6,*) 'net charge = ', qf ! small=small0 ! ! calculate initial charge density from stored wavefunctions ! also initial energies ! FC%valeden=0 DO io=1,norbit if (.NOT.FC%iscore(io)) then xocc=AEOrbit%occ(io) DO ir=1,n FC%valeden(ir)=FC%valeden(ir)+xocc*(AEOrbit%wfn(ir,io)**2) ENDDO endif ENDDO ! ! check charge ! qcal=integrator(AEGrid,FC%valeden) qf=qcal WRITE(6,*) 'qcal electrons = ',qcal, electrons ! rescale density rescale=electrons/qcal FC%valeden(1:n)=FC%valeden(1:n)*rescale ! CALL FCSCFloop(AEGrid,AEPot,AEOrbit,AESCF,FC) ! reset FCOrbit datastructure Do io=1,norbit if (.NOT.FC%iscore(io)) then FCOrbit%occ(io)=AEOrbit%occ(io) FCOrbit%eig(io)=AEOrbit%eig(io) FCOrbit%wfn(:,io)=AEOrbit%wfn(:,io) endif ENDDO CALL FCenergy(AEGrid,AEPot,FCOrbit,AESCF,FC) END SUBROUTINE FCSCFatom SUBROUTINE FCSCFloop(AEGrid,AEPot,AEOrbit,AESCF,FC) TYPE (GridInfo), INTENT(INOUT) :: AEGrid TYPE (PotentialInfo), INTENT(INOUT) :: AEPot TYPE (OrbitInfo), INTENT(INOUT) :: AEOrbit TYPE (SCFInfo), INTENT(INOUT) :: AESCF TYPE (FCinfo), INTENT(INOUT) :: FC ! program to perform self-consistency loop -- frozencore case TYPE (Anderson_Context) , POINTER :: FCrho REAL(8) :: rmix,xocc,qf,small,range,zeff,delta,v1,v2,v3,v4 REAL(8) :: qcal, rescale,cnvrg,emin,ecoul,eexc,etxc,eone,etot INTEGER :: icount,i,j,k,it,start,np,ierr,nroot INTEGER :: is,ip,id,jf,ig,io,l,nfix,ir,nzeff,loop,jierr REAL(8), ALLOCATABLE :: denout(:) v1=conv1;v2=conv2;v3=conv3;v4=conv4 n=AEGrid%n; h=AEGrid%h rmix=rimix cnvrg=worst IF (small.LT.0.d0.OR.small.GT.1.d0) small=small0 WRITE(6,*) 'Density convergence parameter set to at least',cnvrg ! ALLOCATE(denout(n),STAT=k) IF (k /= 0) THEN WRITE(6,*) 'Error in denout allocation ', n,k STOP ENDIF ! start iteration loop ! DO loop=1,mxloop ! calculate potential * r == rv for given density ! AEPot%den=FC%coreden+FC%valeden AEPot%q=FC%zcore+FC%zvale CALL potential(AEGrid,AEPot,ecoul,etxc,eexc) ! ! solve for bound states of Schroedinger equation ! all states are actually calculated, but only ! valence states are used ! icount=0 jierr=0 it=0 ! s states : IF (nps.GT.0) THEN it=it+1 emin=-nz*nz l=0 nroot=nps start=1 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! p states : IF (npp.GT.1) THEN it=it+1 emin=-nz*nz/4.d0 l=1 nroot=npp-1 start=start+nps if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! d states : IF (npd.GT.2) THEN it=it+1 emin=-nz*nz/9.d0 l=2 nroot=npd-2 start=start+npp-1 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! f states : IF (npf.GT.3) THEN it=it+1 emin=-nz*nz/16.d0 l=3 nroot=npf-3 start=start+npd-2 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! g states : IF (npg.GT.4) THEN it=it+1 emin=-nz*nz/25.d0 l=4 nroot=npg-4 start=start+npf-3 if (scalarrelativistic) then CALL boundsr(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) else CALL boundsch(AEGrid,AEPot,AEOrbit,l,start,nroot,emin,ierr) endif ENDIF ! ! calculate new density ! denout(1:n)=0.d0 WRITE(6,*) ' results for loop = ',loop WRITE(6,*) ' n l occupancy energy' DO io=1,norbit if (.NOT.FC%iscore(io)) then WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) IF (AEOrbit%occ(io).GT.small) THEN DO i=1,n denout(i)=denout(i)+AEOrbit%occ(io)*(AEOrbit%wfn(i,io)**2) ENDDO ENDIF endif ENDDO qcal=integrator(AEGrid,denout) WRITE(6,*) 'qcal valence electrons = ',qcal, FC%zvale ! rescale density rescale=FC%zvale/qcal denout(1:n)=denout(1:n)*rescale ! denout=denout-FC%valeden delta=SUM(ABS(denout)) CALL shift4(v1,v2,v3,v4,delta) WRITE(6,*) 'density iter',loop,delta IF (loop.EQ.1) CALL InitAnderson(FCrho,6,5,n,rmix,1.d5) CALL Anderson_Mix(FCrho,FC%valeden(1:n),denout(1:n)) ! correct and recale density DO i=1,n IF (FC%valeden(i).LT.0.d0) FC%valeden(i)=0.d0 ENDDO qcal=integrator(AEGrid,FC%valeden) WRITE(6,*) 'qcal valence electrons = ',qcal, FC%zvale ! rescale density rescale=FC%zvale/qcal FC%valeden(1:n)=FC%valeden(1:n)*rescale ! WRITE(6,*) ' results for loop ,delta = ',loop,delta WRITE(6,*) ' n l occupancy energy' DO io=1,norbit if (.NOT.FC%iscore(io)) WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) ENDDO ! IF (loop>=4) THEN IF (.NOT.(v4.LE.v3.AND.v3.LE.v2 & .AND.v2.LE.v1).AND.v4.LE.cnvrg) THEN ! ! converged result ! WRITE(6,*) ' FCSCFatom converged in',loop,' iterations' AESCF%iter=loop WRITE(6,*) ' for nz = ',nz WRITE(6,*) ' delta(density) = ', delta AESCF%delta=delta WRITE(6,*) ' results for loop = ',loop WRITE(6,*) ' n l occupancy energy' DO io=1,norbit if(.NOT.FC%iscore(io)) WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) ENDDO CALL FreeAnderson(FCrho) DEALLOCATE(denout) RETURN ENDIF ENDIF ENDDO ! mxloop WRITE(6,*)'calculation terminating without density convergence' WRITE(6,*) 'delta, cnvrg =', delta,cnvrg WRITE(6,*) 'loop,mxloop = ',loop,mxloop CALL FreeAnderson(FCrho) DEALLOCATE(denout) STOP END SUBROUTINE FCSCFloop END MODULE AEatom ./src/anderson_realmix.f900000644004704100470410000002056411202701404015474 0ustar natalienatalie!****************************************************************************** ! ! File : anderson_realmix.f90 -- (modified version of anderson_mixing.f90) ! by : Alan Tackett ! on : 07/19/99 ! for : density mixing (originally written for pwpaw code) ! ! This module contains routines to implement the extended Anderson ! mixing method as outlined in V. Eyert, J. Comp. Phys. 124, 271(1996). ! ! The method is defined by eq's: 2.1, 8.2, 7.7 ! !****************************************************************************** MODULE anderson_realmix IMPLICIT NONE!!!!!! SAVE TYPE Anderson_Context !** Anderson Mixing context REAL(8) :: NewMix !** Amount of new vectors to mix, ie beta in paper. INTEGER :: Nmax !** Max number of vectors to keep INTEGER :: N !** Current number of vectors in list INTEGER :: Slot !** New fill Slot INTEGER :: VecSize !** Size of each vector INTEGER :: Err_Unit !** Error unit REAL(8), POINTER :: Matrix(:,:) REAL(8), POINTER :: Gamma(:) !** Gamma as defined in 7.6 REAL(8), POINTER :: DF(:,:) !** Delta F REAL(8), POINTER :: Fprev(:) REAL(8), POINTER :: DX(:,:) REAL(8), POINTER :: Xprev(:) ! temporary constants and arrays needed for each call to Anderson_Mix INTEGER, POINTER :: IPIV(:) REAL(8), POINTER :: S(:) REAL(8), POINTER :: RWork(:) REAL(8), POINTER :: U(:,:) REAL(8), POINTER :: VT(:,:) REAL(8), POINTER :: Work(:) REAL(8), POINTER :: DupMatrix(:,:) INTEGER :: Lwork INTEGER :: LRwork REAL(8) :: ConditionNo REAL(8) :: MachAccur END TYPE Anderson_Context !****************************************************************************** CONTAINS !****************************************************************************** !****************************************************************************** ! ! Anderson_Mix - Performs the actual mixing of the input vector with the ! history and retuns the result. ! ! AC - Anderson context ! X - Current vector on input and new guess on output ! F - F(X) - X. Nonlinear mixing of input vector ! ! Modified to call SVD routines !****************************************************************************** SUBROUTINE Anderson_Mix(AC, X, F) SAVE TYPE (Anderson_Context), INTENT(INOUT) :: AC REAL(8), INTENT(INOUT) :: X(:) REAL(8), INTENT(IN) :: F(:) INTEGER :: i, slot, currentdim , n ,j REAL(8) :: term REAL(8) :: tmp !** First determine where to store the new correction vectors *** AC%slot = AC%slot + 1 IF (AC%Slot>AC%Nmax) AC%Slot = 1 IF ((AC%N < 0) .OR. (AC%Nmax == 0)) THEN !** Simple mixing for 1st time *** AC%Xprev = X X = X + AC%NewMix*F ELSE slot = AC%Slot AC%DF(:,slot) = F - AC%Fprev !** Make new DF vector AC%DX(:,slot) = X - AC%Xprev !** Make new DX vector currentdim=MIN(AC%N+1,AC%Nmax) DO i=1, currentdim !*** Add row/col to matrix term = DOT_PRODUCT(AC%DF(:,i), AC%DF(:,slot)) AC%Matrix(i,slot) = term IF (i /= slot) AC%Matrix(slot,i) = (term) AC%Gamma(i) = DOT_PRODUCT(AC%DF(:,i), F) END DO AC%DupMatrix = AC%Matrix ! not needed (SVD) AC%DupMatrix(slot,slot) = (1+AC%w0) * AC%DupMatrix(slot,slot) ! Call ZHESV('L', Slot, 1, AC%DupMatrix(1,1), AC%Nmax, & ! AC%IPIV(1), AC%Gamma(1), AC%Nmax, AC%Work(1), AC%LWork, i) ! Call ZGESV(Slot, 1, AC%DupMatrix(1,1), AC%Nmax, AC%IPIV(1), & ! AC%Gamma(1), AC%Nmax, i) ! Call ZGESV(currentdim, 1, AC%DupMatrix(1,1), AC%Nmax, AC%IPIV(1), & ! AC%Gamma(1), AC%Nmax, i) n = AC%Nmax; j= currentdim CALL DGESDD('A',j,j,AC%DupMatrix(1,1),n,AC%S(1), & AC%U(1,1),n,AC%VT(1,1),n,AC%Work(1),AC%Lwork, AC%IPIV(1),i) IF (i /= 0) THEN WRITE(AC%Err_Unit,*) 'Anderson_Mix: Error in DGESDD. Error=',i tmp = 0 tmp = 1.d0/tmp STOP END IF WRITE(AC%Err_Unit,*) 'in Anderson_Mix -- completed SVD with values' WRITE(AC%Err_Unit,'(1p5e15.7)') (AC%S(i),i=1,j) AC%Work(1:j) = AC%Gamma(1:j) AC%Gamma = 0 tmp=MAX(ABS(AC%S(1))/AC%ConditionNo,AC%Machaccur) DO i=1,j IF (ABS(AC%S(i)).GT.tmp) THEN AC%Gamma(1:j)=AC%Gamma(1:j)+& (AC%VT(i,1:j))*DOT_PRODUCT(AC%U(1:j,i),AC%Work(1:j))/AC%S(i) ENDIF ENDDO AC%Xprev = X !*** Now calculate the new vector *** X = X + AC%NewMix*F !Do i=1, Min(AC%N+1,AC%Nmax) !*** Add row/col to matrix DO i=1, currentdim ! updated vector X = X - AC%Gamma(i)*(AC%DX(:,i) + AC%NewMix*AC%DF(:,i)) END DO END IF AC%Fprev = F AC%N = AC%N + 1 IF (AC%N > AC%Nmax) AC%N = AC%Nmax RETURN END SUBROUTINE Anderson_Mix !****************************************************************************** ! ! Anderson_ResetMix - Resets the mixing history to None ! ! AC - Anderson context to reset ! !****************************************************************************** SUBROUTINE Anderson_ResetMix(AC) TYPE (Anderson_Context), INTENT(INOUT) :: AC AC%N = -1 AC%Slot = -1 RETURN END SUBROUTINE Anderson_ResetMix !****************************************************************************** ! ! FreeAnderson - Frees all the data associated with the AC data structure ! ! AC -Pointer to the Anderson context to free ! !****************************************************************************** SUBROUTINE FreeAnderson(AC) TYPE (Anderson_Context), POINTER :: AC DEALLOCATE(AC%Xprev, AC%Fprev , AC%DX, AC%DF, AC%Matrix, AC%Gamma) DEALLOCATE(AC%DupMatrix, AC%U, AC%VT, AC%Work, AC%RWork, AC%IPIV, AC%S) DEALLOCATE(AC) RETURN END SUBROUTINE FreeAnderson !****************************************************************************** ! ! InitAnderson - Initializes and Anderson_Context data structure for use ! ! AC - Anderson context created and returned ! Err_Unit - Output error unit ! Nmax - Max number of vectors to keep ! VecSize - Size of each vector ! NewMix - Mixing factor ! !****************************************************************************** SUBROUTINE InitAnderson(AC, Err_Unit, Nmax, VecSize, NewMix, CondNo) TYPE (Anderson_Context), POINTER :: AC INTEGER, INTENT(IN) :: Err_Unit INTEGER, INTENT(IN) :: Nmax INTEGER, INTENT(IN) :: VecSize REAL(8), INTENT(IN) :: NewMix REAL(8), INTENT(IN) :: CondNo INTEGER :: i REAL(8) :: tmp , a1,a2,a3 ALLOCATE(AC) !** Allocate the pointer AC%Nmax = Nmax !*** Store the contants AC%VecSize = VecSize AC%NewMix = NewMix AC%Err_Unit = Err_Unit AC%N = -1 !** Init the rest of the structure AC%Slot = -1 ! AC%Lwork = 2*Nmax ! Allocate(AC%Gamma(Nmax), AC%Work(AC%Lwork), AC%Fprev(VecSize), & ! AC%DF(VecSize, Nmax), AC%Matrix(Nmax, Nmax), AC%IPIV(Nmax), & ! AC%DX(VecSize, Nmax), AC%Xprev(VecSize), & ! AC%DupMatrix(Nmax, Nmax), STAT=i) ALLOCATE(AC%Xprev(VecSize), AC%Fprev(VecSize) , AC%DX(VecSize,Nmax), & AC%DF(VecSize,Nmax), AC%Matrix(Nmax,Nmax) , AC%Gamma(Nmax), & Stat=i) IF (i /= 0) THEN WRITE(Err_Unit,*) 'InitAnderson: Allocate Error! Error=',i WRITE(Err_Unit, *) 'InitAnderson: Nmax=',Nmax, ' * VecSize=',VecSize tmp = 0 tmp = 1.d0/tmp STOP END IF AC%Lwork=5*Nmax*Nmax+10*Nmax AC%LRwork= 5*Nmax*Nmax+7*Nmax AC%ConditionNo= CondNo ! Calculate machine accuracy AC%Machaccur = 0 a1 = 4.d0/3.d0 DO WHILE (AC%Machaccur == 0.d0) a2 = a1 - 1.d0 a3 = a2 + a2 + a2 AC%Machaccur = ABS(a3 - 1.d0) ENDDO WRITE(Err_Unit,*) 'Machaccur = ', AC%Machaccur ALLOCATE(AC%DupMatrix(Nmax,Nmax), AC%U(Nmax, Nmax), AC%VT(Nmax,Nmax), & AC%Work(AC%Lwork), AC%RWork(AC%LRWork), AC%IPIV(8*Nmax), & AC%S(Nmax), STAT=i) AC%Matrix = 0 RETURN END SUBROUTINE InitAnderson END MODULE anderson_realmix ./src/atomdata.f900000644004704100470410000000114711202701404013730 0ustar natalienatalieMODULE atomdata TYPE OrbitInfo INTEGER :: nps, npp, npd ,npf, npg, norbit INTEGER, POINTER :: np(:),l(:) REAL(8), POINTER :: eig(:),occ(:),wfn(:,:) END TYPE OrbitInfo TYPE SCFInfo INTEGER :: iter REAL(8) :: delta,eone,ekin,estatic,ecoul,eexc,etot END TYPE SCFInfo TYPE FCinfo REAL(8), POINTER :: coreden(:),valeden(:) REAL(8) :: evale,zvale,zcore,corekin INTEGER :: norbit LOGICAL, POINTER :: iscore(:) END TYPE FCinfo Logical :: scalarrelativistic Logical :: finitenucleus Logical :: gaussianshapefunction,besselshapefunction END MODULE atomdata ./src/atompaw.f900000644004704100470410000013741611202701404013617 0ustar natalienataliePROGRAM atompaw !*************************************************************** ! 08-13-07 New options for the grid definition (r_max, r_match) ! Printing of pseudo valence density in atomicdata file ! 12-21-06 Set version to be 2.0 ! 11-30-06 Many new options implemented by Marc Torrent -- see ! user guide ! 9-26-06 Upgraded scalarrelativistic option by (1) using solver ! cfdsol obtained from David Vanderbilt's USPS code and ! adapted by Marc Torrent and Francois Jollet (2) introducing ! finite-nucleus option which can replace -2*Z/r potential ! with -2*Z*erf(r/RR)/r, where RR is a nuclear size parameter. ! 7-07-06 added option to use Gaussian shape for hat density ! also simplified other options for projector generation ! keywords Bloechl for Peter Bloechl's scheme (VNCT) ! Vanderbilt for David Vanderbilt' scheme (VNCTV) ! To specify Gaussian shape functions use ! Bloechl Gaussian 1.d-4 or ! Vanderbilt Gaussian 1.d-4 ! where Gaussian = exp(-(r/d)^2) and d=rc*ln(1/1.d-4) ! To specify Sinc^2 shape function, line should be blank ! after projector keyword ! Bloechl (or VNCT) or ! Vandervilt (or VNCTV) ! 6-14-06 corrected xml portion to be consistent with FSATOM ! standard on website ! http://dcwww.camp.dtu.dk/campos//pawxml/pawxml.xhtml ! 6-10-06 worked with Marc Torrent to validate Atompaw2abinit interface ! 5-15-06 added option to use logarithmic grid for radial functions ! 1-21-06 added ionic local potential output needed by ! abinit code to [atom].atomicdata file -- function not ! added to xml output; not currently clear that xml output ! is correctly implemented for current "standard" described in ! http://dcwww.camp.dtu.dk/campos//atomic_setup/atomic_setup.xhtml ! 12-20-05 implemented option to construct projector and basis ! functions similar to David Vanderbilt's ultra-soft ! pseudopotentials (PRB 41, 7892 (1990) ! 1-03-05 implemented PAW-XML output in conformance with ! http://www.fysik.dtu.dk/campos/atomic_setup/paw_setup.html ! 12-31-04 introduced CoreTail density ! 4-30-04 minor changes to simplify options ! 2-29-04 major changes to code structure -- adding possibility ! of adjusting Vloc to norm conserving pseudopotential at given ! l ! 4-19-00 pgm written by N. A. W. Holzwarth ! Calculates projector and basis functions needed by pwpaw pgm ! for electronic structure calculations using the PAW method ! of Blochl ! Modified verion of original genproj pgm !*************************************************************** USE GlobalMath USE atomdata USE aeatom USE gridmod USE pseudo USE basis IMPLICIT NONE CHARACTER (len=4) :: flnm CHARACTER (len=20) :: nm CHARACTER (len=2) :: sym CHARACTER (len=1) :: syml REAL(8), POINTER :: r(:),den(:),rv(:),wfn(:,:) INTEGER, POINTER :: n,norbit,nps,npp,npd,npf,npg REAL(8), POINTER :: h !INTEGER, PARAMETER :: VNCT=1,VNCK=2,VSHAPE=3,VNCTV=4 INTEGER, PARAMETER :: BLOECHL=1, VANDERBILT=2, CUSTOM=3 INTEGER, PARAMETER :: BLOECHLPS=0, POLYNOM=1, POLYNOM2=2, RRKJ=3 INTEGER, PARAMETER :: VANDERBILTORTHO=0, GRAMSCHMIDTORTHO=1 INTEGER, PARAMETER :: MTROULLIER=1, ULTRASOFT=2, BESSEL=3 CHARACTER(50) :: Projectortype,inputfilename CHARACTER(80) :: inputfileline CHARACTER(3) :: gridtype INTEGER :: Projectorindex,PSindex,Orthoindex,Vlocalindex INTEGER :: i,j,io,many,l,istart,irc,ishft,ivion,OK,nbase,ib,ic,icount INTEGER :: llmin, llmax, ll,lcount,jcount,id,ie,iop,lp,pdeg REAL(8) :: rc1,rc2,rc3,rc4,rc,x,rr,e,eself,cc,q00,qcut,evale,storeself,qcore,Etotal REAL(8) :: tildekin,tildepot,onehat,onehartree,ctexc,ctexc1,cexc1,texc,vexc1 REAL(8) :: vtexc,vtexc1,oneenergy,ekin,vlocal,tq,fac,stuff,term,sqr4pi REAL(8) :: ctctse,cthatse,selfenergy REAL(8), ALLOCATABLE :: ttphi(:),soij(:),stij(:),svij(:) REAL(8), ALLOCATABLE :: shij(:),snij(:),dum(:),dum1(:),rh(:),rth(:) REAL(8), ALLOCATABLE :: shartree(:),sshartree(:,:,:),wf(:),twf(:) !REAL(8), ALLOCATABLE :: scself1(:),scself2(:,:,:) REAL(8), ALLOCATABLE :: bm(:),cm(:),dm(:,:) INTEGER, PARAMETER :: ifen=11,ifatompaw=12,ifout=13,ifxml=14,ifinput=15 !INTEGER, PARAMETER :: ifself=16 INTEGER :: lcao_points,lcao_i,iskip,coretailpoints REAL(8) :: tphirange,hlcao,gaussparam REAL(8), PARAMETER :: coretailtol=1.d-7, gausstol=1.d-4 LOGICAL :: even,fileexists,multi_rc CHARACTER(132) :: inputline,inputword TYPE (GridInfo), TARGET :: AEGrid TYPE (PotentialInfo), TARGET :: AEPot TYPE (OrbitInfo), TARGET :: AEOrbit TYPE (OrbitInfo), TARGET :: PSOrbit TYPE (SCFInfo), TARGET :: AESCF TYPE (FCInfo), TARGET :: FC TYPE (PseudoInfo), TARGET :: PAW OPEN(ifinput,file='dummy',form='formatted') CALL Init_GlobalConstants CALL iSCFatom(AEGrid,AEPot,AEOrbit,AESCF,ifinput) CALL ChooseValence(AEGrid,AEOrbit,FC,ifinput) CALL FCenergy(AEGrid,AEPot,AEOrbit,AESCF,FC) CALL FCselfenergy(AEGrid,AEOrbit,FC,selfenergy) OPEN(ifen,file=TRIM(AEPot%sym),form='formatted') WRITE(ifen,'("Atom = ",a2," Z = ",i4)') AEPot%sym, AEPot%nz SELECT CASE(TRIM(exctype)) CASE default WRITE(6,*) 'Perdew-Wang correlation' WRITE(ifen,*) 'Perdew-Wang correlation' CASE('LDA-PW') WRITE(6,*) 'Perdew-Wang correlation' WRITE(ifen,*) 'Perdew-Wang correlation' CASE('GGA-PBE') WRITE(6,*) 'Perdew - Burke - Ernzerhof GGA' WRITE(ifen,*) 'Perdew - Burke - Ernzerhof GGA' END SELECT n=>AEGrid%n h=>AEGrid%h r=>AEGrid%r rv=>AEPot%rv if (usingloggrid(AEGrid)) then gridtype="log" WRITE(ifen,'("Log grid -- n,r0,rmax = ",i5,1p2e15.7)') & AEGrid%n,AEGrid%drdu(1),AEGrid%r(n) ishft=5 else gridtype="lin" WRITE(ifen,'("Linear grid -- n,rmax = ",i5,1p2e15.7)') & AEGrid%n,AEGrid%r(n) ishft=25 endif if (scalarrelativistic) then if(.not.finitenucleus) then WRITE(ifen,*) 'Scalar relativistic calculation -- point nucleus' else WRITE(ifen,*) & 'Scalar relativistic calculation -- finite (Gaussian) nucleus' endif else WRITE(ifen,*) 'Non-relativistic calculation' endif WRITE(ifen,*) ' all-electron results ' WRITE(ifen,*) ' core states (zcore) = ',FC%zcore DO io=1,FC%norbit IF (FC%iscore(io))THEN WRITE(ifen,'(3i5,1p2e15.7)') io,AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) ENDIF ENDDO WRITE(ifen,*) ' valence states (zvale) = ',FC%zvale DO io=1,FC%norbit IF (.NOT.FC%iscore(io)) THEN WRITE(ifen,'(3i5,1p2e15.7)') io,AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) ENDIF ENDDO WRITE(ifen,*) 'evale = ', FC%evale WRITE(ifen,*) 'selfenergy contribution = ', selfenergy WRITE(6,*) 'Enter maximum L for basis and projector functions' READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) PAW%lmax PAW%rc=0;multi_rc=.false. PAW%rc_shap=0;PAW%rc_vloc=0;PAW%rc_core=0 WRITE(6,*) 'enter rc [and eventually: rc_shape, rc_vloc, rc_core]' READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) CALL extractword(1,inputline,inputword);inputword=trim(inputword) IF (inputword/="") READ(inputword,*) rc1 rc2=rc1;rc3=rc1;rc4=rc1 CALL extractword(2,inputline,inputword);inputword=trim(inputword) IF (inputword/="") THEN multi_rc=.true. READ(inputword,*) rc2 CALL extractword(3,inputline,inputword);inputword=trim(inputword) IF (inputword/="") THEN READ(inputword,*) rc3 CALL extractword(4,inputline,inputword);inputword=trim(inputword) IF (inputword/="") THEN READ(inputword,*) rc4 ELSE WRITE(6,*) 'error -- rc(core) is missing ' STOP ENDIF ELSE WRITE(6,*) 'error -- rc(Vloc) is missing ' STOP ENDIF ENDIF IF (multi_rc) THEN IF (rc1.LE.0.d0.or.rc2.LE.0.d0.or.rc3.LE.0.d0.or.rc4.LE.0.d0) THEN WRITE(6,*) 'error -- one rc is too small !' STOP ENDIF IF (rc2.GT.rc1.or.rc3.GT.rc1.or.rc4.GT.rc1) THEN WRITE(6,*) 'error -- rc_shape, rc_vloc and rc_core must be n-ishft) stop 'error -- rc is too big !' WRITE(6,*) ' adjusted rc ',rc, r(irc) WRITE(6,*) ' irc,rc = ',irc,rc if (multi_rc) then WRITE(6,*) ' adjusted rc_shape ',PAW%rc_shap WRITE(6,*) ' adjusted rc_vloc ',PAW%rc_vloc WRITE(6,*) ' adjusted rc_core ',PAW%rc_core endif WRITE(ifen,*) ' paw parameters: ' WRITE(ifen,*) ' lmax = ',PAW%lmax WRITE(ifen,*) ' rc = ',rc WRITE(ifen,*) ' irc = ',irc if (multi_rc) then WRITE(ifen,*) ' rc_shape = ',PAW%rc_shap WRITE(ifen,*) ' rc_vloc = ',PAW%rc_vloc WRITE(ifen,*) ' rc_core = ',PAW%rc_core endif ! CALL setbasis(AEGrid,AEPot,AEOrbit,FC,PAW,ifinput) ALLOCATE(ttphi(n),dum(n),dum1(n),stat=OK) IF(OK /= 0) THEN WRITE(6,*) 'Error in allocating arrays', n STOP ENDIF CALL initpseudopot(AEGrid,PAW) CALL setcoretail(AEGrid,FC%coreden,PAW) ! Find coretailpoints coretailpoints=irc+ishft do i=irc+ishft,n if(ABS(FC%zcore-integrator(AEGrid,FC%coreden,1,i))0) then PSindex=BLOECHLPS;Orthoindex=GRAMSCHMIDTORTHO else i=INDEX(inputfileline,'POLYNOM2') if (i>0) then PSindex=POLYNOM2 read(unit=inputfileline(i+8:80),fmt=*,err=111,end=111,iostat=i) pdeg,qcut 111 continue else i=INDEX(inputfileline,'POLYNOM') if (i>0) then PSindex=POLYNOM else i=INDEX(inputfileline,'RRKJ') if (i>0) PSindex=RRKJ endif endif i=INDEX(inputfileline,'GRAMSCHMIDTORTHO') if (i>0) Orthoindex=GRAMSCHMIDTORTHO i=INDEX(inputfileline,'VANDERBILTORTHO') if (i>0) Orthoindex=VANDERBILTORTHO endif endif write(PAW%Proj_description,'("Projector method:")') if (PSindex==BLOECHLPS) then if (Orthoindex==VANDERBILTORTHO) stop & & 'Vanderbilt orthogonalization not compatible with Bloechl s projector scheme !' write(PAW%Proj_description,'(a," Bloechl")') trim(PAW%Proj_description) else if (Orthoindex==VANDERBILTORTHO) & & write(PAW%Proj_description,'(a," Vanderbilt (")') trim(PAW%Proj_description) if (PSindex==POLYNOM) then write(PAW%Proj_description,'(a,"polynomial pseudization")') trim(PAW%Proj_description) else if (PSindex==POLYNOM2) then write(PAW%Proj_description,'(a,"improved polynomial pseudization")') trim(PAW%Proj_description) else if (PSindex==RRKJ) then write(PAW%Proj_description,'(a,"RRKJ pseudization")') trim(PAW%Proj_description) endif if (Orthoindex==VANDERBILTORTHO) then write(PAW%Proj_description,'(a,")")') trim(PAW%Proj_description) else write(PAW%Proj_description,'(a," + Gram-Schmidt ortho.")') trim(PAW%Proj_description) endif endif gaussianshapefunction=.false.;besselshapefunction=.false. i=0;i=INDEX(inputfileline,'GAUSSIAN') if (i>0) then gaussianshapefunction=.true. gaussparam=gausstol read(unit=inputfileline(i+8:80),fmt=*) x if (x>0) gaussparam=x CALL sethat(AEGrid,PAW,gaussparam=gaussparam) ! Gaussian shape function write(PAW%Comp_description,& '("Gaussian compensation charge shape with gausstol = ",1pe12.4)')& gaussparam else i=0;i=INDEX(inputfileline,'BESSELSHAPE') if (i>0) then besselshapefunction=.true. CALL sethat(AEGrid,PAW,besselopt=i) ! Bessel shape function if (PAW%irc_shap/=PAW%irc) then write(PAW%Comp_description,& '("Bessel compensation charge shape zeroed at ",1pe12.4)') PAW%rc_shap else write(PAW%Comp_description,& '("Bessel compensation charge shape zeroed at rc")') endif else CALL sethat(AEGrid,PAW) ! sinc^2 shape function if (PAW%irc_shap/=PAW%irc) then write(PAW%Comp_description,& '("Sinc^2 compensation charge shape zeroed at ",1pe12.4)') PAW%rc_shap else write(PAW%Comp_description,& '("Sinc^2 compensation charge shape zeroed at rc")') endif endif endif WRITE(6,*) 'To generate the local pseudopotential, this code can use:' WRITE(6,*) ' 1- a Troullier-Martins scheme for specified l value and energy' WRITE(6,*) ' 2- a non norm-conserving pseudopotential scheme for specified l value and energy' WRITE(6,*) ' 3- a simple pseudization scheme using a single spherical Bessel function' WRITE(6,*) 'For choice 1, enter (high) l value and energy e' WRITE(6,*) 'For choice 2, enter (high) l value, energy e and "ultrasoft"' WRITE(6,*) 'For choice 3, enter "bessel"' READ(5,'(a)') inputfileline WRITE(ifinput,'(a)') TRIM(inputfileline) call Uppercase(inputfileline) Vlocalindex=MTROULLIER i=0;i=INDEX(inputfileline,'BESSEL') if (i>0) then Vlocalindex=BESSEL WRITE(PAW%Vloc_description,'("Vloc: truncated form - Vps(r)=A.sin(qr)/r for r10) stop 'Error while reading Vloc parameters' i=0;i=INDEX(inputfileline,'ULTRASOFT') if (i>0) then Vlocalindex=ULTRASOFT WRITE(PAW%Vloc_description,& & '("Vloc: Non norm-conserving form with l= ",i1,";e= ",1pe12.4)')l,e else Vlocalindex=MTROULLIER WRITE(PAW%Vloc_description,& & '("Vloc: Norm-conserving Troullier-Martins form; l= ",i1,";e= ",1pe12.4)')l,e endif endif WRITE(6,*) PAW%Vloc_description IF (Vlocalindex==MTROULLIER) CALL troullier(AEGrid,AEPot,PAW,l,e) IF (Vlocalindex==ULTRASOFT) CALL nonncps(AEGrid,AEPot,PAW,l,e) IF (Vlocalindex==BESSEL) CALL besselps(AEGrid,AEPot,PAW) IF (Projectorindex==BLOECHL) THEN CALL makebasis_bloechl(AEGrid,AEPot,PAW,ifinput,0) ELSE IF (Projectorindex==CUSTOM.AND.PSindex==BLOECHLPS) THEN CALL makebasis_bloechl(AEGrid,AEPot,PAW,ifinput,1) ELSE IF (Projectorindex==VANDERBILT.OR.Projectorindex==CUSTOM) THEN CALL makebasis_custom(AEGrid,AEPot,PAW,ifinput,PSindex,Orthoindex,pdeg,qcut) ENDIF CALL FindVlocfromVeff(AEGrid,FC,AEPot%nz,PAW) !IF (vlocalindex==VNCK) THEN ! CALL kerker(AEGrid,AEPot,PAW) ! CALL makebasis(AEGrid,PAW) ! CALL FindVlocfromVeff(AEGrid,FC,AEPot%nz,PAW) ! PAW%Vloc_description=& ! 'Bloechl projectors with '//PAW%Vloc_description(1:250) !ENDIF ! ! IF (vlocalindex==VSHAPE) THEN ! CALL SCbasis(AEGrid,FC,AEPot%nz,PAW) ! PAW%Vloc_description=& ! 'Bloechl projectors with '//PAW%Vloc_description(1:250) ! ENDIF WRITE(ifen,*) TRIM(PAW%Vloc_description) WRITE(ifen,*) TRIM(PAW%Proj_description) WRITE(ifen,*) TRIM(PAW%Comp_description) CALL checkghosts(AEGrid,AEOrbit,FC,PAW) OPEN(ifout,file='density', form='formatted') DO i=1,n IF (FC%coreden(i)")') !WRITE(ifxml,'("")') WRITE(ifxml,'("")') !note energy units are Hartrees i=qcore+0.2 flnm=stripchar('"'//AEPot%sym//'"') !WRITE(ifxml,'("")')& ! TRIM(flnm),AEpot%nz,i,AEpot%nz-i WRITE(ifxml,'("")')i,AEpot%nz-i if (TRIM(exctype)=='LDA-PW') WRITE(ifxml,& '("")') if (TRIM(exctype)=='GGA-PBE') WRITE(ifxml,& '("")') if (scalarrelativistic) then WRITE(ifxml,'("")') else WRITE(ifxml,'("")') endif WRITE(ifxml,'(")")') WRITE(ifxml,'("")') ! WRITE(ifxml,'("")') & AESCF%estatic/2,AESCF%etot/2 WRITE(ifxml,'("")') FC%corekin/2 ! WRITE(ifxml,'("")') do ib=1,nbase call mkname(ib,flnm) nm=stripchar('"'//AEPot%sym//flnm//'"') i=min(ABS(PAW%np(ib)),20) !WRITE(ifxml,& ! '(" ")')& ! i,PAW%l(ib),PAW%occ(ib),PAW%rc,PAW%eig(ib)/2,TRIM(nm) WRITE(ifxml,'(" ")')& PAW%rc,PAW%eig(ib)/2,TRIM(nm) enddo WRITE(ifxml,'("")') if (usingloggrid(AEGrid)) then !WRITE(ifxml,'("")')& ! AEGrid%drdu(1),AEGrid%h,coretailpoints-1 WRITE(ifxml,'("")') ivion=log(10.d0/AEGrid%drdu(1)+1)/AEGrid%h + 0.1 +1 !WRITE(ifxml,'("")')& ! AEGrid%drdu(1),AEGrid%h,ivion-1 WRITE(ifxml,'("")') else !WRITE(ifxml,'("")')& ! AEGrid%h,coretailpoints-1 WRITE(ifxml,'("")')& coretailpoints-1 ivion=10.d0/AEGrid%h + 0.1 +1 !WRITE(ifxml,'("")')& ! AEGrid%h,ivion-1 WRITE(ifxml,'("")')& ivion-1 endif ! dum=0 ! dum(1:irc)=PAW%hatshape(1:irc) ! WRITE(ifxml,'("")') gridtype,1 if (gaussianshapefunction) then WRITE(ifxml,'("")')& PAW%rc_shap/SQRT(LOG(1.d0/gaussparam)) else if (besselshapefunction) then WRITE(ifxml,'("")') PAW%rc_shap else WRITE(ifxml,'("")') PAW%rc_shap endif ! WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) ! WRITE(ifxml,'("")') dum=0 dum(2:coretailpoints)=sqr4pi*FC%coreden(2:coretailpoints)& /(4*pi*(AEGrid%r(2:coretailpoints))**2) call extrapolate(AEGrid,dum) WRITE(ifxml,'("")') gridtype,1 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) WRITE(ifxml,'("")') dum=0 dum(2:coretailpoints)=sqr4pi*PAW%tcore(2:coretailpoints)& /(4*pi*(AEGrid%r(2:coretailpoints))**2) call extrapolate(AEGrid,dum) WRITE(ifxml,'("")') gridtype,1 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) WRITE(ifxml,'("")') dum=0 dum(2:ivion)=sqr4pi*PAW%tden(2:ivion)& /(4*pi*(AEGrid%r(2:ivion))**2) call extrapolate(AEGrid,dum) WRITE(ifxml,'("")') gridtype,2 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,ivion) WRITE(ifxml,'("")') dum=0 dum(1:irc)=sqr4pi*PAW%vloc(1:irc)/2 WRITE(ifxml,'("")') gridtype,1 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) WRITE(ifxml,'("")') dum=0 dum(1:ivion)=sqr4pi*PAW%abinitvloc(1:ivion)/2 WRITE(ifxml,'("")')& gridtype,2 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,ivion) WRITE(ifxml,'("")') Do ib=1,nbase call mkname(ib,flnm) nm=stripchar('"'//AEPot%sym//flnm//'"') dum=0 dum(2:coretailpoints)=& PAW%ophi(2:coretailpoints,ib)/AEGrid%r(2:coretailpoints) call extrapolate(AEGrid,dum) WRITE(ifxml,'("")')& TRIM(nm),gridtype,1 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) WRITE(ifxml,'("")') dum=0 dum(2:coretailpoints)=& PAW%otphi(2:coretailpoints,ib)/AEGrid%r(2:coretailpoints) call extrapolate(AEGrid,dum) WRITE(ifxml,'("")')& TRIM(nm),gridtype,1 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) WRITE(ifxml,'("")') dum=0 dum(2:coretailpoints)=& PAW%otp(2:coretailpoints,ib)/AEGrid%r(2:coretailpoints) call extrapolate(AEGrid,dum) WRITE(ifxml,'("")') & TRIM(nm),gridtype,1 WRITE(ifxml,'(1p3e25.17)') (dum(i),i=1,coretailpoints) WRITE(ifxml,'("")') Enddo ! new version of LCAO -- assume range of 10 bohr sufficient !!!tphirange=10.d0 ! tphirange=8.d0 !!!lcao_points=800 ! lcao_points=600 !!!lcao_i=tphirange/AEGrid%h !!!iskip=MAX(1,lcao_i/lcao_points) !!!lcao_i=iskip*(lcao_i/iskip)+iskip !!!hlcao=AEGrid%h*iskip !!!lcao_points=lcao_i/iskip + 1 ! ! Find index for AEGrid%r(i)>10 j=gridindex(AEGrid,10.d0) lcao_points=j hlcao=AEGrid%h WRITE(ifatompaw,'(" LCAO_SIZE ",i10)') lcao_points WRITE(ifatompaw,'(" LCAO_STEP ",1pe20.13)') hlcao WRITE(ifatompaw,'(" CORE_DENSITY ")') WRITE(ifatompaw,'(1p3e25.17)') (FC%coreden(i),i=1,PAW%irc+ishft) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" CORETAIL_DENSITY ")') WRITE(ifatompaw,'(1p3e25.17)') (PAW%tcore(i),i=1,coretailpoints) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" PSEUDO_VALENCE_DENSITY ",3x,i8)') j WRITE(ifatompaw,'(1p3e25.17)') (PAW%tden(i),i=1,j) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" SHAPE_FUNC ")') WRITE(ifatompaw,'(1p3e25.17)') (PAW%hatshape(i),i=1,PAW%irc+ishft) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" VLOCFUN ")') WRITE(ifatompaw,'(1p3e25.17)') (PAW%vloc(i),i=1,PAW%irc+ishft) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,& '(" VLOCION ",3x,i8," #ionic vloc for abinit in Ryd units")') j WRITE(ifatompaw,'(1p3e25.17)') (PAW%abinitvloc(i),i=1,j) WRITE(ifatompaw,'(" END ")') DO ib=1,nbase WRITE(ifatompaw,'(" TPROJECTOR",i4," #p(r), for p(r)/r*Ylm)")') ib WRITE(ifatompaw,'(1p3e25.17)') (PAW%otp(i,ib),i=1,PAW%irc+ishft) WRITE(ifatompaw,'(" END ")') ENDDO DO ib=1,nbase WRITE(ifatompaw,'(" PHI",i5," #phi(r), for phi(r)/r*Ylm)")') ib WRITE(ifatompaw,'(1p3e25.17)') (PAW%ophi(i,ib),i=1,PAW%irc+ishft) WRITE(ifatompaw,'(" END ")') ENDDO DO ib=1,nbase WRITE(ifatompaw,'(" TPHI",i5," #tphi(r), for tphi(r)/r*Ylm)")') ib WRITE(ifatompaw,'(1p3e25.17)') (PAW%otphi(i,ib),i=1,PAW%irc+ishft) WRITE(ifatompaw,'(" END ")') ENDDO DO ib=1,nbase ttphi=PAW%tphi(:,ib) CALL trunk(AEGrid,ttphi(1:n),6.d0,10.d0) WRITE(ifatompaw,'(" TPHI_LCAO",i4," #tphi0(r) for tphi0(r)/r*Ylm)")') ib WRITE(ifatompaw,'(1p3e25.17)') (ttphi(j),j=1,lcao_points) WRITE(ifatompaw,'(" END ")') ENDDO ! spherical matrix elements icount=(nbase*(nbase+1))/2 ALLOCATE(soij(icount),stij(icount),svij(icount),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in allocating dia matrix elements',icount,ok STOP ENDIF ! allocate PAW data set storage for spherical matrix elements ALLOCATE(PAW%tvij(nbase,nbase),PAW%vhatij(nbase,nbase),& PAW%v0ij(nbase,nbase),PAW%oij(nbase,nbase),PAW%dij(nbase,nbase),& PAW%kin(nbase,nbase),PAW%vhijkl(nbase,nbase,nbase,nbase),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in allocating storage for matrix elements',nbase,ok STOP ENDIF PAW%tvij=0; PAW%vhatij=0; PAW%v0ij=0; PAW%vhijkl=0; PAW%kin=0; PAW%oij=0 icount=0 DO ib=1,nbase DO ic=ib,nbase IF (PAW%l(ib)==PAW%l(ic)) THEN l=PAW%l(ib) icount=icount+1 CALL dqij(AEGrid,PAW,ib,ic,soij(icount)) !CALL dtij(AEGrid,PAW,ib,ic,stij(icount)) !CALL altdtij(AEGrid,AEPot,PAW,ib,ic,x) ! write(6,*) 'altdtij --', ib,ic,stij(icount),x CALL altdtij(AEGrid,PAW,ib,ic,stij(icount)) CALL dvij(AEGrid,PAW,FC,AEPot%nz,ib,ic,svij(icount)) PAW%tvij(ib,ic)=stij(icount)+svij(icount) PAW%tvij(ic,ib)=stij(icount)+svij(icount) PAW%kin(ib,ic)=stij(icount) PAW%kin(ic,ib)=stij(icount) PAW%oij(ib,ic)=soij(icount) PAW%oij(ic,ib)=soij(icount) ENDIF ENDDO ENDDO WRITE(ifatompaw,'(" OVERLAP_SIZE ",i10)') icount WRITE(ifatompaw,'(" OVERLAP_MATRIX ")') WRITE(ifatompaw,'(1p3e25.17)') (soij(ic),ic=1,icount) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" KINETIC_ENERGY_MATRIX ")') WRITE(ifatompaw,'(1p3e25.17)') (stij(ic),ic=1,icount) WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" V_ION_MATRIX ")') WRITE(ifatompaw,'(1p3e25.17)') (svij(ic),ic=1,icount) WRITE(ifatompaw,'(" END ")') WRITE(ifxml,'("")') WRITE(ifxml,'(1p3e25.17)') ((PAW%kin(ib,ic)/2,ic=1,nbase),ib=1,nbase) WRITE(ifxml,'("")') WRITE(ifxml,'("")') ! ! angularly dependent matrix elements ! icount=(nbase*(nbase+1))*(PAW%lmax+1) ALLOCATE(shij(icount),snij(icount),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in allocating L matrix elements',icount,ok STOP ENDIF icount=0 DO ib=1,nbase DO ic=ib,nbase llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 icount=icount+1 ! write(6,*) 'ib,ic,ll',ib,ic,ll,icount DO i=1,irc rr=AEGrid%r(i) dum(i)=(rr**ll)*(PAW%ophi(i,ib)*PAW%ophi(i,ic) & -PAW%otphi(i,ib)*PAW%otphi(i,ic)) ENDDO snij(icount)=integrator(AEGrid,dum,1,irc) if (ll==0) then PAW%v0ij(ib,ic)=snij(icount) PAW%v0ij(ic,ib)=snij(icount) endif CALL hatpotL(AEGrid,PAW,ll,dum) DO i=1,irc dum(i)=dum(i)*PAW%otphi(i,ib)*PAW%otphi(i,ic) ENDDO shij(icount)=integrator(AEGrid,dum,1,irc) if (ll==0) then PAW%vhatij(ib,ic)=shij(icount) PAW%vhatij(ic,ib)=shij(icount) endif ENDDO ENDDO ENDDO WRITE(ifatompaw,'(" DENVHAT_SIZE ",i10)') icount WRITE(ifatompaw,'(" DENSITY ")') icount=0 DO ib=1,nbase DO ic=ib,nbase llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 icount=icount+1 WRITE(ifatompaw,'(3i10,1pe25.17)') ib,ic,ll,snij(icount) ENDDO ENDDO ENDDO WRITE(ifatompaw,'(" END ")') WRITE(ifatompaw,'(" V_HAT ")') icount=0 DO ib=1,nbase DO ic=ib,nbase llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 icount=icount+1 WRITE(ifatompaw,'(3i10,1pe25.17)') ib,ic,ll,shij(icount) ENDDO ENDDO ENDDO WRITE(ifatompaw,'(" END ")') ! icount=(nbase*(nbase+1))/2 lcount=(icount**2)*((PAW%lmax+1)*2) !ALLOCATE(shartree(lcount),sshartree(icount,icount,2*PAW%lmax+2),& ! scself1(lcount),scself2(icount,icount,2*PAW%lmax+2),& ! wf(n),twf(n),rh(n),rth(n),stat=ok) ALLOCATE(shartree(lcount),sshartree(icount,icount,2*PAW%lmax+2),& wf(n),twf(n),rh(n),rth(n),stat=ok) IF (ok/=0) THEN WRITE(6,*) 'Error in hartree allocation', icount,lcount,irc,ok STOP ENDIF ! ! Hartree matrix elements ! !! Due to precision error in apoisson solver, some equivalent Hartree !! matrix elements are not equal with an error of e-5; take average !! these elements in order to remove assymmetry errors !! Thanks to Francois Jollet for pointing out this problem sshartree=0 shartree=0 !scself1=0; scself2=0 icount=0 lcount=0 DO ib=1,nbase DO ic=ib,nbase icount=icount+1 DO i=1,irc wf(i)=PAW%ophi(i,ib)*PAW%ophi(i,ic) twf(i)=PAW%otphi(i,ib)*PAW%otphi(i,ic) ENDDO llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 CALL apoisson(AEGrid,ll,irc,wf,rh) CALL apoisson(AEGrid,ll,irc,twf,rth) jcount=0 DO id=1,nbase DO ie=id,nbase jcount=jcount+1 lp=llmax+PAW%l(id)+PAW%l(ie) even=.false. if (2*(lp/2)==lp) even=.true. IF (ll.GE.ABS(PAW%l(id)-PAW%l(ie)).AND. & ll.LE.PAW%l(id)+PAW%l(ie).AND.even) THEN lcount=lcount+1 !WRITE(6,*) 'ib,ic,ll',ib,ic,id,ie,ll,lcount,icount,jcount dum=0;dum1=0 DO i=2,irc rr=AEGrid%r(i) dum(i)=PAW%ophi(i,id)*PAW%ophi(i,ie)*rh(i)/rr & -PAW%otphi(i,id)*PAW%otphi(i,ie)*rth(i)/rr dum1(i)=PAW%ophi(i,id)*PAW%ophi(i,ie)*rh(i)/rr ENDDO shartree(lcount)=integrator(AEGrid,dum(1:irc),1,irc) sshartree(icount,jcount,ll+1)=shartree(lcount) !scself1(lcount)=integrator(AEGrid,dum1(1:irc),1,irc) !scself2(icount,jcount,ll+1)=scself1(lcount) ENDIF ENDDO ENDDO ENDDO ENDDO ENDDO icount=0 lcount=0 DO ib=1,nbase DO ic=ib,nbase icount=icount+1 llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 jcount=0 DO id=1,nbase DO ie=id,nbase jcount=jcount+1 lp=llmax+PAW%l(id)+PAW%l(ie) even=.false. if (2*(lp/2)==lp) even=.true. IF (ll.GE.ABS(PAW%l(id)-PAW%l(ie)).AND. & ll.LE.PAW%l(id)+PAW%l(ie).AND.even) THEN lcount=lcount+1 shartree(lcount)= & 0.5d0*(sshartree(icount,jcount,ll+1) + & sshartree(jcount,icount,ll+1)) !scself1(lcount)= & ! 0.5d0*(scself2(icount,jcount,ll+1) + & ! scself2(jcount,icount,ll+1)) ENDIF ENDDO ENDDO ENDDO ENDDO ENDDO WRITE(6,*) lcount,' ; # Hartree matrix elements' WRITE(ifatompaw,'(" HARTREE_SIZE ",i10)') lcount WRITE(ifatompaw,'(" V_HARTREE ")') !WRITE(ifself,'(" V_SCSELF ",a2,i10)') AEPot%sym,lcount lcount=0 DO ib=1,nbase DO ic=ib,nbase llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 DO id=1,nbase DO ie=id,nbase lp=llmax+PAW%l(id)+PAW%l(ie) even=.false. if (2*(lp/2)==lp) even=.true. IF (ll.GE.ABS(PAW%l(id)-PAW%l(ie)).AND. & ll.LE.PAW%l(id)+PAW%l(ie).AND.even) THEN lcount=lcount+1 WRITE(ifatompaw,'(5i5,1pe25.17)')ib,ic,id,ie,ll,shartree(lcount) !WRITE(ifself,'(5i5,1pe25.17)')ib,ic,id,ie,ll,scself1(lcount) IF (ll==0) THEN PAW%vhijkl(ib,ic,id,ie)=shartree(lcount) PAW%vhijkl(ic,ib,id,ie)=shartree(lcount) PAW%vhijkl(ib,ic,ie,id)=shartree(lcount) PAW%vhijkl(ic,ib,ie,id)=shartree(lcount) PAW%vhijkl(id,ie,ib,ic)=shartree(lcount) PAW%vhijkl(id,ie,ic,ib)=shartree(lcount) PAW%vhijkl(ie,id,ib,ic)=shartree(lcount) PAW%vhijkl(ie,id,ic,ib)=shartree(lcount) ENDIF ENDIF ENDDO ENDDO ENDDO ENDDO ENDDO WRITE(ifatompaw,'(" END ")') !WRITE(ifself,'(" END ")') WRITE(ifatompaw,'(" HAT_SELF-ENERGY ",i10)') 2*PAW%lmax DO ll=0,2*PAW%lmax CALL selfhatpot(AEGrid,PAW,ll,eself) WRITE(ifatompaw,'(i10,1pe25.17)') ll,eself IF (ll==0) storeself=eself ENDDO WRITE(ifatompaw,'(" END ")') lcount=(nbase*(nbase+1))/2 ALLOCATE(bm(nbase),cm(nbase),dm(lcount,lcount),stat=ok) IF (ok/=0) THEN WRITE(6,*) 'Error in allocation before evale', nbase,ok STOP ENDIF ! ! using matrix elements to re-evaluate evale -- ! ! tildekin=0.d0 PAW%den=0; PAW%tden=0 DO ib=1,nbase l=PAW%l(ib) CALL kinetic(AEGrid,PAW%l(ib),PAW%tphi(:,ib),ekin) tildekin=tildekin+PAW%occ(ib)*ekin PAW%den=PAW%den+PAW%occ(ib)*(PAW%phi(:,ib))**2 PAW%tden=PAW%tden+PAW%occ(ib)*(PAW%tphi(:,ib))**2 ENDDO DO i=1,irc dum(i)=PAW%den(i)+FC%coreden(i)-PAW%tden(i)-PAW%tcore(i) ENDDO q00=-AEPot%nz+integrator(AEGrid,dum,1,irc) WRITE(6,*) 'q00 = ',q00 DO i=1,n dum(i)=(PAW%tcore(i)+q00*PAW%hatden(i)) ENDDO tq=integrator(AEGrid,dum) WRITE(6,*) 'tqcore = ',tq CALL poisson(AEGrid,tq,dum,ttphi,x) do i=2,n ttphi(i)=ttphi(i)/r(i)+PAW%vloc(i) enddo call extrapolate(AEGrid,ttphi) tildepot=overlap(AEGrid,ttphi,PAW%tden) tq=integrator(AEGrid,PAW%tden) WRITE(6,*) 'tq = ',tq CALL poisson(AEGrid,tq,PAW%tden,ttphi,x) tildepot=tildepot+x oneenergy=0.d0 DO io=1,nbase l=PAW%l(io) bm=0.d0 DO ib=1,nbase IF (PAW%l(ib).EQ.l) THEN bm(ib)=overlap(AEGrid,PAW%otp(:,ib),PAW%tphi(:,io),1,irc) !IF (io==ib) THEN ! IF (ABS(bm(ib)-1).GT.1.d-11)& ! WRITE(6,*) 'Warning in pdot',io,ib,bm(ib) !ELSE ! IF (ABS(bm(ib)).GT.1.d-11)& ! WRITE(6,*) 'Warning in pdot',io,ib,bm(ib) !ENDIF ENDIF ENDDO lcount=0 DO ib=1,nbase DO ic=ib,nbase IF (PAW%l(ib).EQ.PAW%l(ic)) THEN lcount=lcount+1 fac=PAW%occ(io) IF(ic.GT.ib) fac=2*fac oneenergy=oneenergy+ & fac*bm(ib)*bm(ic)*(stij(lcount)+svij(lcount)) ENDIF ENDDO ENDDO ENDDO onehat=0.d0 DO io=1,nbase l=PAW%l(io) bm=0.d0 DO ib=1,nbase IF (PAW%l(ib).EQ.l) & bm(ib)=overlap(AEGrid,PAW%otp(:,ib),PAW%tphi(:,io),1,irc) ENDDO lcount=0 DO ib=1,nbase DO ic=ib,nbase llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) fac=PAW%occ(io) IF (ic.GT.ib) fac=2*fac DO ll=llmin,llmax,2 lcount=lcount+1 IF (ll.EQ.0) THEN onehat=onehat+q00*fac*bm(ib)*bm(ic)*shij(lcount) ENDIF ENDDO ENDDO ENDDO ENDDO !onehat=onehat + storeself*(q00**2) -- self term excluded here onehartree=0.d0 ! load array dm lcount=0 icount=0 DO ib=1,nbase DO ic=ib,nbase icount=icount+1 llmin=ABS(PAW%l(ib)-PAW%l(ic)) llmax=PAW%l(ib)+PAW%l(ic) DO ll=llmin,llmax,2 jcount=0 DO id=1,nbase DO ie=id,nbase lp=llmax+PAW%l(id)+PAW%l(ie) even=.false. if (2*(lp/2)==lp) even=.true. jcount=jcount+1 IF (ll.GE.ABS(PAW%l(id)-PAW%l(ie)).AND. & ll.LE.PAW%l(id)+PAW%l(ie).AND.even) THEN lcount=lcount+1 IF (ll.EQ.0) dm(icount,jcount)=shartree(lcount) ENDIF ENDDO !ie ENDDO !id ENDDO !ll ENDDO ! ic ENDDO ! ib DO io=1,nbase l=PAW%l(io) bm=0.d0 DO ib=1,nbase IF (PAW%l(ib).EQ.l) & bm(ib)=overlap(AEGrid,PAW%otp(:,ib),PAW%tphi(:,io),1,irc) ENDDO icount=0 DO ib=1,nbase DO ic=ib,nbase icount=icount+1 stuff=PAW%occ(io)*bm(ic)*bm(ib) IF (ic.GT.ib) stuff=2*stuff term=0.d0 DO iop=1,nbase lp=PAW%l(iop) cm=0.d0 DO id=1,nbase IF (PAW%l(id).EQ.lp) & cm(id)=overlap(AEGrid,PAW%otp(:,id),PAW%tphi(:,iop),1,irc) ENDDO jcount=0 DO id=1,nbase DO ie=id,nbase jcount=jcount+1 fac=PAW%occ(iop)*cm(id)*cm(ie) IF (ie.GT.id) fac=2*fac term=term+fac*dm(icount,jcount) ENDDO !ie ENDDO !id ENDDO !iop onehartree=onehartree+stuff*term ENDDO ! ic ENDDO ! ib ENDDO !io ! exchange-correlation energy ! CALL exch(AEGrid,PAW%tden,dum,stuff,vtexc) CALL exch(AEGrid,PAW%tden,dum,stuff,vtexc1,irc) CALL exch(AEGrid,FC%coreden,dum,stuff,cc) CALL exch(AEGrid,FC%coreden,dum,stuff,cexc1,irc) cc=cc-cexc1 DO i=1,irc ttphi(i)=FC%coreden(i)+PAW%den(i) ENDDO CALL exch(AEGrid,ttphi,wf,stuff,vexc1,irc) texc=vtexc+vexc1-vtexc1-cexc1 WRITE(6,*) ' exchange-correlation energy', texc WRITE(6,*) ' core tail exchange error ', cc ttphi=PAW%tcore+PAW%tden CALL exch(AEGrid,ttphi,dum,stuff,vtexc) CALL exch(AEGrid,ttphi,twf,stuff,vtexc1,irc) ttphi=FC%coreden+PAW%den call exch(AEGrid,ttphi,wf,stuff,vexc1,irc) texc=vtexc+vexc1-vtexc1 write(6,*) ' New form of exchange-correlation energy', texc ! ! local potential contribution -- already in matrix element -- not added ! vlocal=overlap(AEGrid,PAW%vloc(1:irc),PAW%tden(1:irc),1,irc) WRITE(6,*) 'vlocal contribution ', vlocal evale=tildekin+tildepot+oneenergy-onehat & +0.5d0*onehartree+texc WRITE (6,*) ' evale from matrix elements ', evale WRITE(6,*) ' evale from AE calculation ',FC%evale WRITE(6,*) ' difference in evale results ', evale-FC%evale WRITE(6,*) 'tildekin ', tildekin WRITE(6,*) 'tildepot ' , tildepot WRITE(6,*) 'oneenergy ', oneenergy WRITE(6,*) 'onehat ', onehat WRITE(6,*) 'onehartree ', onehartree WRITE(6,*) 'texc ',texc WRITE(6,*) 'vlocal contribution ', vlocal ! call coretailselfenergy(AEGrid,PAW,ctctse,cthatse) WRITE(ifatompaw,'(" CORETAILSELFENERGY ",1pe25.17," END")') ctctse WRITE(ifatompaw,'(" CORETAILHATENERGY ",1pe25.17," END")') cthatse WRITE(ifen,'("evale from matrix elements",1pe25.17)') evale WRITE(6,'("evale from matrix elements",1pe25.17)') evale WRITE(ifatompaw,'(" ENERGY ",1pe25.17," END")') evale CLOSE(ifatompaw) CLOSE(ifxml) CALL ftprod(AEGrid,PAW) CALL SCFPAW(AEGrid,AEPOT%nz,PAW,FC,AEOrbit,PSOrbit,Etotal) CALL logderiv(AEGrid,AEPot,PAW) CALL fthatpot(AEGrid,PAW) CALL ftkin(AEGrid,PAW) CALL ftvloc(AEGrid,PAW) ! Do WRITE(6,*) 'Enter 0 to end program' WRITE(6,*) 'Enter 1 to run SCFPAW' READ(5,*) i if (i==0) exit CALL SCFPAW(AEGrid,AEPOT%nz,PAW,FC,AEOrbit,PSOrbit,Etotal,.true.) WRITE(ifen,*) ' ' WRITE(ifen,*) ' PAW results for new configuration' WRITE(6,*) ' ' WRITE(6,*) ' PAW results for new configuration' DO io=1,PSOrbit%norbit WRITE(ifen,'(3i5,1p2e15.7)') io,PSOrbit%np(io),PSOrbit%l(io),& PSOrbit%occ(io),PSOrbit%eig(io) WRITE(6,'(3i5,1p2e15.7)') io,PSOrbit%np(io),PSOrbit%l(io),& PSOrbit%occ(io),PSOrbit%eig(io) ENDDO WRITE(ifen,'("evale from matrix elements",1pe25.17)') Etotal WRITE(6,'("evale from matrix elements",1pe25.17)') Etotal !CALL flush(ifen) Enddo END PROGRAM atompaw ./src/basis.f900000644004704100470410000025740711202701404013253 0ustar natalienatalieMODULE basis USE atomdata USE aeatom USE calcpotential USE Globalmath USE gridmod USE pseudo USE radialsch USE radialsr USE anderson_realmix IMPLICIT NONE CONTAINS SUBROUTINE setbasis(Grid,Pot,Orbit,FC,PAW,ifinput) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(OrbitInfo), INTENT(IN) :: Orbit TYPE(FCInfo), INTENT(IN) :: FC TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(IN) :: ifinput INTEGER :: n,irc,norbit,nbase,l,lmax,mxbase INTEGER :: i,j,k,io,ok,nbl,nr,nodes,ib,loop,niter,iter REAL(8) :: h,rc,q00,energy,rat,delta,thisconv,qeff,tq REAL(8) :: ecoul,etxc,eexc CHARACTER(1) :: answer REAL(8), POINTER :: r(:) CHARACTER(132) :: inputline n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc nr=irc+20 rc=PAW%rc lmax=PAW%lmax norbit=Orbit%norbit nbase=0 DO l=0,lmax DO io=1,norbit ! cycle through all configuration IF (Orbit%l(io).EQ.l.AND.(.NOT.FC%iscore(io))) THEN nbase=nbase+1 ENDIF ENDDO ENDDO mxbase=nbase+5*max(1,PAW%lmax) WRITE(6,*) 'Found ', nbase,' valence basis functions ' WRITE(6,*) 'Allocating for ', mxbase, ' total basis functions' ALLOCATE(PAW%phi(n,mxbase),PAW%tphi(n,mxbase),PAW%tp(n,mxbase),& PAW%ophi(n,mxbase),PAW%otphi(n,mxbase),PAW%otp(n,mxbase),& PAW%np(mxbase),PAW%l(mxbase),PAW%eig(mxbase),PAW%occ(mxbase),& PAW%ck(mxbase),PAW%vrc(mxbase),PAW%Kop(n,mxbase),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in PAW%phi allocation', n,mxbase,ok STOP ENDIF ! PAW%phi=0; PAW%tphi=0; PAW%tp=0; PAW%ck=0 PAW%np=0; PAW%l=0; PAW%eig=0; PAW%occ=0; PAW%vrc=0 nbase=0 WRITE(6,*) ' basis functions:' WRITE(6,*)' No. n l energy occ ' DO l=0,lmax nbl=0 DO io=1,norbit ! cycle through all configuration IF (Orbit%l(io).EQ.l.AND.(.NOT.FC%iscore(io))) THEN nbl=nbl+1 nbase=nbase+1 PAW%np(nbase)=Orbit%np(io) PAW%l(nbase)=l PAW%eig(nbase)=Orbit%eig(io) PAW%occ(nbase)=Orbit%occ(io) PAW%phi(:,nbase)=Orbit%wfn(:,io) WRITE(6,'(3i6,1p2e15.6)') nbase,PAW%np(nbase),l, & PAW%eig(nbase),PAW%occ(nbase) ENDIF ENDDO generalizedloop: DO WRITE(6,*) 'For l = ',l,' there are currently ',nbl,& 'basis functions' WRITE(6,*) 'enter y to add additional functions or n to ' & ,'go to next l' READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) answer IF (answer.NE.'y') EXIT generalizedloop WRITE(6,*) 'enter energy for generalized function' READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) READ(inputline,*) energy IF(energy.LT.0.d0) THEN WRITE(6,*) 'energy is negative',energy,' -- WARNING WARNING !!!' ENDIF nbase=nbase+1 IF (nbase > mxbase ) THEN WRITE(6,*) 'Error in setbasis -- too many functions ', nbase,mxbase STOP ENDIF PAW%l(nbase)=l PAW%np(nbase)=999 PAW%eig(nbase)=energy PAW%occ(nbase)=0.d0 PAW%phi(1:n,nbase)=0.d0 if (scalarrelativistic) then CALL unboundsr(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes) else CALL unboundsch(Grid,Pot,n,l,energy,PAW%phi(:,nbase),nodes) endif rat=MAX(ABS(PAW%phi(irc,nbase)),ABS(PAW%phi(irc+1,nbase))) rat=DSIGN(rat,PAW%phi(irc,nbase)) PAW%phi(1:n,nbase)=PAW%phi(1:n,nbase)/rat WRITE(6,'(3i6,1p2e15.6)') nbase,PAW%np(nbase),l, & PAW%eig(nbase),PAW%occ(nbase) nbl=nbl+1 ENDDO generalizedloop ! ENDDO ! end lmax loop WRITE(6,*) 'completed phi basis with ',nbase,' functions ' PAW%nbase=nbase ALLOCATE(PAW%oij(nbase,nbase),PAW%dij(nbase,nbase),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating oij,dij ', nbase,i STOP ENDIF PAW%oij=0; PAW%dij=0 END SUBROUTINE setbasis !************************************************************************** ! Program to generate atomic basis functions ! Version using Bloechl's form of projector and orthogonalization procedure ! At the end of this subroutine, the basis functions and projectors are ! orthogonalized with a Gram-Schmidt like scheme !************************************************************************** SUBROUTINE makebasis_bloechl(Grid,AEPot,PAW,ifinput,option) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: AEPOT TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER,INTENT(IN) :: ifinput,option INTEGER :: n,irc,nr INTEGER :: i,j,k,io,ok,lmax REAL(8) :: h,rc REAL(8), ALLOCATABLE :: denout(:),tmp(:),VNC(:) TYPE(PotentialInfo), TARGET:: PS REAL(8), POINTER :: r(:) n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc nr=irc+20 rc=PAW%rc lmax=PAW%lmax PS%nz=0 call InitPotential(Grid,PS) ALLOCATE(tmp(n),VNC(n),stat=ok) IF (ok /= 0 ) THEN WRITE(6,*) 'Error in allocating denout in makebasis ',n,ok STOP ENDIF ! find basis functions PS%rv=PAW%rveff call zeropot(Grid,PS%rv,PS%v0,PS%v0p) !write(6,*) 'VNC v0 ', PS%v0,PS%v0p,PS%rv(5) CALL formprojectors(Grid,AEPot,PS,PAW,ifinput,option) DEALLOCATE(tmp,VNC,PS%den,PS%rv) END SUBROUTINE makebasis_bloechl !************************************************************************** ! Program to generate atomic basis functions ! ! 1) Pseudization of partial waves: ! - simple polynom scheme [optps=1] ! r^(l+1).Sum[Ci.r^2i] 0<=i<=4 ! OR - ultrasoft polynom scheme [optps=2] ! r^(l+1).{Sum[Ci.r^2i]+Sum[Cj.r^2j]} 0<=i<=3 ! 33) stop 'bug: error calling makebasis_custom routine' if (optorth<0.or.optorth>1) stop 'bug: error calling makebasis_custom routine' n=Grid%n r=>Grid%r irc=PAW%irc irc_vloc=PAW%irc_vloc nbase=PAW%nbase lmax=PAW%lmax np=5;if (optps==2) np=pdeg+1 if (optps==1.or.optps==2) allocate(Ci(np)) ! Set screened local pseudopotential allocate(VNC(n),stat=i) if (i/=0) stop 'allocation error in makebasis_vanderbilt' VNC(2:n)=PAW%rveff(2:n)/r(2:n) call extrapolate(Grid,VNC) write(6,*) 'For each of the following basis functions enter rc' ! Loop on basis elements do io=1,nbase l=PAW%l(io) ! Read matching radius write(6,'(3i5,1pe15.7)') io,PAW%np(io),PAW%l(io),PAW%eig(io) READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) read(inputline,*) rc thisrc=FindGridIndex(Grid,rc) thisrc=MIN(thisrc,irc) ! make sure rcirc.or. & & (optps==1.and.thisrc>n-3).or. & & (optps==2.and.thisrc>n-6)) then write(6,*) 'rc out of range', thisrc,n,irc stop endif ! Find partial wave pseudization if (optps==1) then call pspolyn(PAW%phi(:,io),Ci,r,l,np,thisrc,n) else if (optps==2) then call psuspolyn(PAW%phi(:,io),Ci,r,l,np,thisrc,n,qcut) else if (optps==3) then call psbes(PAW%phi(:,io),al,ql,Grid,l,thisrc,n) endif ! Compute pseudized partial wave and unnormalized projector PAW%tphi(:,io)=PAW%phi(:,io) PAW%tp(:,io)=0.d0 if (optps==1.or.optps==2) then do i=1,thisrc-1 xx=r(i)*r(i) PAW%tphi(i,io)=Ci(1)+Ci(2)*xx gp=2.d0*Ci(2) gpp=2.d0*Ci(2) do j=3,np PAW%tphi(i,io)=PAW%tphi(i,io)+Ci(j)*xx**(j-1) gp=gp+dble(2*j-2)*Ci( j)*xx**(j-2) gpp=gpp+dble((2*j-2)*(2*j-3))*Ci(j)*xx**(j-2) enddo PAW%tphi(i,io)=PAW%tphi(i,io)*r(i)**(l+1) PAW%tp(i,io)=(dble(2*(l+1))*gp+gpp)*r(i)**(l+1)+(PAW%eig(io)-VNC(i))*PAW%tphi(i,io) enddo else if (optps==3) then PAW%tphi(1,io)=0.d0 do i=2,thisrc-1 xx=ql(1)*r(i) call jbessel(g,gp,gpp,l,2,xx) PAW%tphi(i,io)=al(1)*g*r(i) gg=al(1)*(2.d0*ql(1)*gp+ql(1)*xx*gpp) xx=ql(2)*r(i) call jbessel(g,gp,gpp,l,2,xx) PAW%tphi(i,io)=PAW%tphi(i,io)+al(2)*g*r(i) gg=gg+al(2)*(2.d0*ql(2)*gp+ql(2)*xx*gpp) PAW%tp(i,io)=(PAW%eig(io)-VNC(i)-dble(l*(l+1))/(r(i)**2))*PAW%tphi(i,io)+gg enddo endif if (thisrc=0) ifinish=io icount=icount+1;omap(icount)=io ENDIF ENDDO DO ibase=istart,ifinish DO jbase=istart,ibase IF (jbase.LT.ibase) THEN xx=overlap(Grid,PAW%otp(:,jbase),PAW%otphi(:,ibase),1,irc) yy=overlap(Grid,PAW%otphi(:,jbase),PAW%otp(:,ibase),1,irc) PAW%ophi(1:n,ibase)=PAW%ophi(1:n,ibase)-PAW%ophi(1:n,jbase)*xx PAW%Kop(1:n,ibase)=PAW%Kop(1:n,ibase)-PAW%Kop(1:n,jbase)*xx PAW%otphi(1:n,ibase)=PAW%otphi(1:n,ibase)-PAW%otphi(1:n,jbase)*xx PAW%otp(1:n,ibase)=PAW%otp(1:n,ibase)-PAW%otp(1:n,jbase)*yy aa(ibase-istart+1,jbase-istart+1)=xx aa(jbase-istart+1,ibase-istart+1)=xx ELSE IF (jbase.EQ.ibase) THEN xx=overlap(Grid,PAW%otp(:,jbase),PAW%otphi(:,ibase),1,irc) choice=1.d0/SQRT(ABS(xx)) PAW%otp(1:n,ibase)=PAW%otp(1:n,ibase)*DSIGN(choice,xx) PAW%otphi(1:n,ibase)=PAW%otphi(1:n,ibase)*choice PAW%ophi(1:n,ibase)=PAW%ophi(1:n,ibase)*choice PAW%Kop(1:n,ibase)=PAW%Kop(1:n,ibase)*choice aa(ibase-istart+1,ibase-istart+1)=xx ENDIF ENDDO ENDDO ai=aa;call minverse(aa,icount) do i=1,icount io=omap(i);PAW%ck(io)=ai(i,i) enddo deallocate(aa,ai,omap) ENDDO endif END SUBROUTINE makebasis_custom ! subroutine not presently used ! SUBROUTINE SCbasis(Grid,FC,nz,PAW) ! TYPE(GridInfo), INTENT(IN) :: Grid ! TYPE(FCInfo), INTENT(IN) :: FC ! INTEGER, INTENT(IN) :: nz ! TYPE(PseudoInfo), INTENT(INOUT) :: PAW ! ! INTEGER :: iv,niter,loop,i,n,nbase,io,index ! REAL(8) :: q00,tq,h,conv,ecoul,etxc,eexc,delta,v1,v2,v3,v4 ! REAL(8), ALLOCATABLE :: denout(:),dum(:) ! REAL(8), PARAMETER :: conv1=1.d13,conv2=2.d13,conv3=3.d13,conv4=4.d13 ! TYPE(PotentialInfo) :: PS ! ! h=Grid%h ! n=Grid%n ! nbase=PAW%nbase ! ! v1=conv1;v2=conv2;v3=conv3;v4=conv4 ! ! DO ! WRITE(6,*) 'Input index of basis function for setting vloc' ! READ(5,*) index ! IF (index>=1.AND.index<=nbase) EXIT ! ENDDO ! ! WRITE(PAW%Vloc_description,& ! '("Fixed shape Vloc with amplitude set for basis index",i4)')& ! index ! WRITE(6,*) PAW%Vloc_description ! ! ALLOCATE(PS%rv(n),PS%den(n),denout(n),dum(n),stat=i) ! IF (i/=0) THEN ! WRITE(6,*) 'Allocation error in SCbasis ', n,i ! STOP ! ENDIF ! ! PS%nz=0 ! PAW%vloc=0 ! DO io=1,nbase ! PAW%tphi(:,io)=PAW%phi(:,io) ! ENDDO ! ! PAW%den=FC%coreden; PAW%tden=PAW%tcore ! DO io=1,nbase ! PAW%den(:)=PAW%den(:)+PAW%occ(io)*(PAW%phi(:,io))**2 ! PAW%tden(:)=PAW%tden(:)+PAW%occ(io)*(PAW%tphi(:,io))**2 ! ENDDO ! ! DO iv=1,2 ! ! conv=nbase*1.d-7 ! niter=1000 ! loop=0 ! delta=1.d10 ! denout=PAW%tden ! ! tphiloop: DO ! loop=loop+1 ! IF(loop > niter) THEN ! WRITE(6,*) 'SCbasis pgm terminating in tphiloop ', loop ! STOP ! ENDIF ! ! ! tq=integrator(Grid,PAW%tden) ! WRITE(6,*) 'tq = ',tq ! dum=PAW%den-PAW%tden ! q00=-nz + integrator(Grid,dum,1,PAW%irc) ! WRITE(6,*) 'q00 = ',q00 ! ! PS%q=tq ! PS%den=PAW%tden ! CALL potential(Grid,PS,ecoul,etxc,eexc) ! PAW%rveff(:)=PS%rv(:)+PAW%vloc(:)*Grid%r(:)+q00*PAW%hatpot(:) ! ! IF (loop>=4) THEN ! IF ((delta.LT.1.e-11).OR.(.NOT.(v4.LE.v3.AND.v3.LE.v2 & ! .AND.v2.LE.v1).AND.v4.LE.conv)) THEN ! ! ! ! converged result ! ! ! WRITE(6,*) ' SCprojectors converged in',loop,' iterations' ! ! EXIT tphiloop ! ENDIF ! ENDIF ! ! ! CALL makebasis(Grid,PAW) ! ! PAW%tden=PAW%tcore ! DO io=1,nbase ! PAW%tden(:)=PAW%tden(:)+PAW%occ(io)*(PAW%tphi(:,io))**2 ! ENDDO ! ! dum=denout-PAW%tden ! delta=SQRT(DOT_PRODUCT(dum(1:n),dum(1:n))) ! CALL shift4(v1,v2,v3,v4,delta) ! WRITE(6,*) 'loop = ', loop,' delta = ', delta ! denout=PAW%tden ! ! ENDDO tphiloop ! ! IF (iv==1) THEN ! WRITE(6,*) 'Completed first tphiloop', PAW%ck(1:nbase) ! WRITE(6,*) 'Resetting vloc with vlocfac == ', -PAW%ck(index) ! PAW%vloc=-PAW%ck(index)*PAW%projshape ! ENDIF ! ! ENDDO !iv loop ! DEALLOCATE(PS%den,PS%rv,denout,dum) ! END SUBROUTINE SCbasis ! SUBROUTINE FindVlocfromVeff(Grid,FC,nz,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(FCInfo), INTENT(IN) :: FC INTEGER, INTENT(IN) :: nz TYPE(PseudoInfo), INTENT(INOUT) :: PAW TYPE(PotentialInfo), TARGET:: PS REAL(8), POINTER :: r(:) REAL(8) :: h,qeff,tq,rat,q00,ecoul,etxc,eexc INTEGER :: n,i,irc,io,nbase REAL(8), allocatable :: d(:),v(:),dd(:),vv(:) ! temporary arrays for abinit n=Grid%n allocate(d(n),dd(n),v(n),vv(n),STAT=i) if (i /= 0) then write(6,*) 'Error in allocating abinit arrays',n stop endif h=Grid%h r=>Grid%r irc=max(PAW%irc,PAW%irc_shap,PAW%irc_vloc,PAW%irc_core) d=FC%coreden dd=PAW%tcore PAW%den=0.d0 PAW%tden=0.d0 nbase=PAW%nbase DO io=1,nbase IF (PAW%occ(io) > 1.d-8) THEN DO i=1,n PAW%den(i)= PAW%den(i)+PAW%occ(io)*(PAW%phi(i,io)**2) PAW%tden(i)= PAW%tden(i)+PAW%occ(io)*(PAW%tphi(i,io)**2) ENDDO ENDIF ENDDO d=d+PAW%den dd=dd+PAW%tden ALLOCATE(PS%den(n),PS%rv(n),stat=i) IF (i /= 0) THEN WRITE(6,*) 'Error in FindVlocfromVeff -- ',n,i STOP ENDIF PS%den=d-dd qeff=-nz+integrator(Grid,PS%den,1,irc) WRITE(6,*) 'qeff = ',qeff tq=integrator(Grid,dd) WRITE(6,*) 'tq = ',tq q00=qeff WRITE(6,*) 'q00 = ',q00 ! generate effective potential ! PS%den=dd; PS%q=tq; PS%nz=0 CALL potential(Grid,PS,ecoul,etxc,eexc) ! rat=0 DO i=2,n PAW%vloc(i)=(PAW%rveff(i)-PS%rv(i)-q00*PAW%hatpot(i))/r(i) IF (i>=irc) rat=rat+ABS(PAW%vloc(i)) ENDDO call extrapolate(Grid,PAW%vloc) PAW%vloc(irc:n)=0 WRITE(6,*) 'Error in vloc -- ', rat ! Construct ionic local potential for abinit from screened ! pseudopotential ! in addition to ionic unscreening include hathat density ! in exchange-correlation functional d=0;dd=0 DO io=1,nbase IF (PAW%occ(io) > 1.d-8) THEN DO i=1,n d(i)= d(i)+PAW%occ(io)*(PAW%phi(i,io)**2) dd(i)= dd(i)+PAW%occ(io)*(PAW%tphi(i,io)**2) ENDDO ENDIF ENDDO d=d-dd tq=integrator(Grid,d,1,irc) write(6,*) ' abinit tq = ', tq dd=dd+tq*PAW%hatden write(6,*) ' check valence ', FC%zvale,integrator(Grid,dd) tq=FC%zvale CALL poisson(Grid,tq,dd,v,rat) dd=dd+PAW%tcore CALL exch(Grid,dd,d,etxc,eexc) dd=FC%coreden-PAW%tcore qeff=-nz+integrator(Grid,dd,1,PAW%irc_core) dd=PAW%tcore+qeff*PAW%hatden qeff=-dble(FC%zvale) CALL poisson(Grid,qeff,dd,vv,rat) do i=2,irc-1 v(i)=(PAW%rveff(i)-v(i)-d(i))/r(i) PAW%abinitvloc(i)=v(i) ! still in Rydberg units enddo call extrapolate(Grid,PAW%abinitvloc) do i=irc,n PAW%abinitvloc(i)=vv(i)/r(i) ! still in Rydberg units enddo open(123,file='compare.abinit', form='formatted') do i=2,n write(123,'(1p4e16.7)') r(i),PAW%rveff(i)/r(i),& PAW%vloc(i),PAW%abinitvloc(i) enddo close(123) DEALLOCATE(PS%rv,PS%den,d,dd,v,vv) END SUBROUTINE FindVlocfromVeff !************************************************************************* ! program to generate projector functions for Blochl's paw formalism ! starting with smooth functions ! for every basis function phi, choose smooth function with ! form for rr(iiirc) ! functions defined to be identically zero for r>r(iiirc)) !************************************************************************* SUBROUTINE formprojectors(Grid,AEPot,PS,PAW,ifinput,option) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: AEPot,PS TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER,INTENT(IN) :: ifinput,option INTEGER :: nbase,lmax,l,io,irc,wantednodes,nb,n,icount INTEGER :: istart,ifinish,ibase,jbase REAL(8) :: h,xx,yy,choice,rc INTEGER,allocatable :: irc_io(:) CHARACTER(132) :: inputline n=Grid%n h=Grid%h lmax=PAW%lmax nbase=PAW%nbase irc=PAW%irc ! ! form projector functions for each l ! if (option==1) then allocate(irc_io(nbase)) write(6,*) 'For each of the following basis functions enter rc' do io=1,nbase write(6,'(3i5,1pe15.7)') io,PAW%np(io),PAW%l(io),PAW%eig(io) READ(5,'(a)') inputline WRITE(ifinput,'(a)') TRIM(inputline) read(inputline,*) rc irc_io(io)=FindGridIndex(Grid,rc) rc=Grid%r(irc_io(io)) write(6,*) 'rc for this wfn', rc if(irc_io(io)>PAW%irc) then write(6,*) 'rc out of range', irc_io(io),n,PAW%irc stop endif enddo endif DO l=0,lmax icount=0 DO io=1,nbase IF (PAW%l(io)==l) THEN IF (icount==0) istart=io IF (icount >= 0) ifinish=io icount=icount+1 wantednodes=icount-1 ! form unorthonormalized projector functions tp WRITE(6,*) '******* projector for l = ',l if (option==1) then CALL bsolv(Grid,PS,PAW,io,wantednodes,irc_io(io)) else CALL bsolv(Grid,PS,PAW,io,wantednodes) endif PAW%ophi(:,io)=PAW%phi(:,io) PAW%otphi(:,io)=PAW%tphi(:,io) PAW%otp(:,io)=PAW%tp(:,io) PAW%Kop(1,io)=0 PAW%Kop(2:n,io)=(PAW%eig(io)-AEPot%rv(2:n)/Grid%r(2:n))& *PAW%phi(2:n,io) ENDIF ENDDO !write(6,*) 'orthnormalization' !write(6,*) 'start orthogonalization',istart,ifinish DO ibase=istart,ifinish DO jbase=istart,ibase IF (jbase.LT.ibase) THEN xx=overlap(Grid,PAW%otp(:,jbase),PAW%otphi(:,ibase),1,irc) yy=overlap(Grid,PAW%otphi(:,jbase),PAW%otp(:,ibase),1,irc) !write(6,*) 'before',jbase,ibase,xx,yy PAW%ophi(1:n,ibase)=PAW%ophi(1:n,ibase)-PAW%ophi(1:n,jbase)*xx PAW%Kop(1:n,ibase)=PAW%Kop(1:n,ibase)-PAW%Kop(1:n,jbase)*xx PAW%otphi(1:n,ibase)=PAW%otphi(1:n,ibase)-PAW%otphi(1:n,jbase)*xx PAW%otp(1:n,ibase)=PAW%otp(1:n,ibase)-PAW%otp(1:n,jbase)*yy ELSE IF (jbase.EQ.ibase) THEN xx=overlap(Grid,PAW%otp(:,ibase),PAW%otphi(:,ibase),1,irc) !write(6,*) 'before',jbase,ibase,xx choice=1.d0/SQRT(ABS(xx)) PAW%otp(1:n,ibase)=PAW%otp(1:n,ibase)*DSIGN(choice,xx) PAW%otphi(1:n,ibase)=PAW%otphi(1:n,ibase)*choice PAW%ophi(1:n,ibase)=PAW%ophi(1:n,ibase)*choice PAW%Kop(1:n,ibase)=PAW%Kop(1:n,ibase)*choice ENDIF ENDDO ENDDO ENDDO if (option==1) deallocate(irc_io) END SUBROUTINE formprojectors !************************************************************************* ! on input tphi=phi ! on output tphi recalculated for rGrid%r rv=>Pot%rv if (present(irc_io)) then irc=irc_io else irc=PAW%irc endif ALLOCATE(fakerv(n),f(n),chi(n),tphi(n),tp(n),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in bsolv allocation ', n,ok STOP ENDIF tphi=PAW%phi(:,io) en=PAW%eig(io) l=PAW%l(io) deriv=(Gfirstderiv(Grid,irc,tphi))/tphi(irc) ! log derivative tderiv=0 ! initial log derive cp=0 ! initial projector constant del=1000 ! initial error cpmin=-100 cpmax=100 if (present(irc_io)) then rc_io=r(irc_io) f(1)=1.d0;f(irc_io:n)=0.d0 DO i=2,irc_io-1 f(i)=(SIN(pi*r(i)/rc_io)/(pi*r(i)/rc_io))**2 ENDDO else DO i=1,n f(i)=PAW%projshape(i) ENDDO endif WRITE(6,*) 'in bsolv -- l, en, n',l,en,wantednodes iter=0 DO iter=iter+1 WRITE(6,*) 'bsolv iter cp',iter,cp fakerv=rv-cp*f*Grid%r call zeropot(Grid,fakerv,v0,v0p) ! initialize chi chi=0 chi(2)=wfninit(0,l,v0,v0p,en,Grid%r(2)) zeroval=0 if (l==1) zeroval=2 call forward_numerov(Grid,l,irc+5,en,fakerv,zeroval,chi,nodes) WRITE(6,'("iter nodes cp cpmin cpmax",2i5,1p3e15.7)')& iter,nodes,cp,cpmin,cpmax IF (nodes.EQ.wantednodes) THEN tderiv=(Gfirstderiv(Grid,irc,chi))/chi(irc) ! log derivative tp=0 tp(1:irc)=chi(1:irc)/chi(irc) chi(1:irc)=f(1:irc)*(tp(1:irc))**2 xnorm=integrator(Grid,chi(1:irc),1,irc) del=(tderiv-deriv)/xnorm WRITE(6,*) 'iter nodes del', iter,nodes,del IF (ABS(del).LT.small) EXIT IF (iter.GE.mxiter) THEN WRITE(6,*)' terminating projector',iter STOP ENDIF IF (ABS(del).GT.step) del=DSIGN(step,del) cp=cp+del IF (cp.GT.cpmax) cp=cpmax-ranx()*step IF (cp.LT.cpmin) cp=cpmin+ranx()*step ELSE IF(nodes.GT.wantednodes) THEN cpmax=cp cp=cpmax-ranx()*step ELSE IF(nodes.LT.wantednodes) THEN cpmin=cp cp=cpmin+ranx()*step ENDIF ENDDO tphi(1:irc-1)=tphi(irc)*tp(1:irc-1) tphi(irc:n)=PAW%phi(irc:n,io) tp(1:irc)=f(1:irc)*tphi(1:irc) chi(1:irc)=tphi(1:irc)*tp(1:irc) xnorm=integrator(Grid,chi(1:irc),1,irc) WRITE(6,*) 'normalization for projector l,n=',l,nodes,xnorm tp(1:irc)=tp(1:irc)/xnorm tp(irc+1:n)=0 PAW%tphi(:,io)=tphi PAW%tp(:,io)=tp PAW%ck(io)=cp WRITE(6,*) 'completed bsolv',io,cp DEALLOCATE(fakerv,f,chi,tphi,tp) END SUBROUTINE bsolv SUBROUTINE trunk(Grid,f,rstart,rend) TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(INOUT) :: f(:) REAL(8), INTENT(IN) :: rstart,rend INTEGER :: i,n REAL(8) :: r,delta,arg delta=rend-rstart DO i=1,Grid%n r=Grid%r(i) IF (r>rstart .AND. r<=rend) THEN arg=pi*(r-rstart)/delta f(i)=f(i)*(SIN(arg)/arg)**2 ENDIF IF (r>rend) f(i)=0 ENDDO END SUBROUTINE trunk !*********************************************************************** ! program to calculate Fourier transform of paw product tp*tphi ! in order to get an idea of the convergence ! and output them to files tprod.l !*********************************************************************** SUBROUTINE ftprod(Grid,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, PARAMETER :: nq=200 REAL(8), PARAMETER :: qmax=15.d0 REAL(8), ALLOCATABLE :: q(:),dum(:),dum1(:) REAL(8), POINTER :: r(:) REAL(8) :: h,dq,tphij INTEGER :: i,ib,l,iq,n,irc CHARACTER(4) flnm ! WRITE(6,*) 'calculating Fourier transforms of tp*tphi products ',& 'For bound states only ' n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc ALLOCATE(q(nq),dum(n),dum1(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating space in ftprod',n,nq,i STOP ENDIF dq=qmax/nq DO ib=1,PAW%nbase IF (PAW%eig(ib)< 0.d0) THEN l=PAW%l(ib) CALL mkname(ib,flnm) OPEN(55,file='tprod.'//TRIM(flnm),form='formatted') DO iq=1,nq q(iq)=iq*dq DO i=1,n dum(i)=q(iq)*r(i) ENDDO CALL sphbes(l,n,dum) DO i=1,n dum1(i)=dum(i)*r(i)*PAW%otphi(i,ib) IF (i.LE.irc) dum(i)=dum(i)*r(i)*PAW%otp(i,ib) ENDDO tphij=integrator(Grid,dum1(1:n))*& integrator(Grid,dum(1:irc),1,irc) WRITE(55,'(1p2e16.7)') q(iq),tphij ENDDO CLOSE(55) ENDIF !(e<=0) ENDDO ! ib DEALLOCATE(q,dum,dum1) END SUBROUTINE ftprod !*********************************************************************** ! program to calculate Fourier transform of hatpot functions ! in order to get an idea of the convergence ! and output them to files hatpot.l !*********************************************************************** SUBROUTINE fthatpot(Grid,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, PARAMETER :: nq=200 REAL(8), PARAMETER :: qmax=15.d0 REAL(8), ALLOCATABLE :: q(:),dum(:),dum1(:),dum2(:),dum3(:),arg(:) REAL(8), POINTER :: r(:) REAL(8) :: h,dq,fthatp,fthatd,fthattd INTEGER :: i,ib,l,iq,n,irc,ll CHARACTER(4) flnm ! WRITE(6,*) 'calculating Fourier transforms of hatpot for each l ' n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc ALLOCATE(q(nq),dum(n),dum1(n),dum2(n),dum3(n),arg(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating space in fthatpot',n,nq,i STOP ENDIF dq=qmax/nq ll=2*MAXVAL(PAW%l(:)) DO l=0,ll CALL mkname(l,flnm) OPEN(55,file='fthatpot.'//TRIM(flnm),form='formatted') CALL hatL(Grid,PAW,l,dum2) DO iq=1,nq q(iq)=iq*dq DO i=1,n dum(i)=q(iq)*r(i) ENDDO CALL sphbes(l,n,dum) DO i=1,n dum3(i)=dum(i)*dum2(i) ENDDO fthatd=integrator(Grid,dum3(1:n)) fthatp=8*PI*fthatd/q(iq)**2 fthattd=0 IF(l==0) THEN arg(1:n)=dum(1:n)*PAW%tden(1:n) fthattd=integrator(Grid,arg) ENDIF WRITE(55,'(1p5e16.7)') q(iq),fthatp,fthatd,fthatp*fthatd,fthatp*fthattd ENDDO CLOSE(55) ENDDO ! l DEALLOCATE(q,dum,dum1,dum2,dum3,arg) END SUBROUTINE fthatpot !*********************************************************************** ! program to calculate Fourier transform of tphi*q^2 ! in order to get an idea of the convergence of kinetic energy ! and output them to files ftkin.l !*********************************************************************** SUBROUTINE ftkin(Grid,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, PARAMETER :: nq=200 REAL(8), PARAMETER :: qmax=15.d0 REAL(8), ALLOCATABLE :: q(:),dum(:),dum1(:) REAL(8), POINTER :: r(:) REAL(8) :: h,dq,kin INTEGER :: i,ib,l,iq,n,irc CHARACTER(4) flnm ! WRITE(6,*) 'calculating Fourier transforms of tphi ',& 'For bound states only ' n=Grid%n h=Grid%h r=>Grid%r ALLOCATE(q(nq),dum(n),dum1(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating space in ftkin',n,nq,i STOP ENDIF dq=qmax/nq DO ib=1,PAW%nbase IF (PAW%eig(ib)<=0.d0) THEN l=PAW%l(ib) CALL mkname(ib,flnm) OPEN(55,file='ftkin.'//TRIM(flnm),form='formatted') DO iq=1,nq q(iq)=iq*dq DO i=1,n dum(i)=q(iq)*r(i) ENDDO CALL sphbes(l,n,dum) DO i=1,n dum1(i)=dum(i)*r(i)*PAW%tphi(i,ib) ENDDO kin=integrator(Grid,dum1(1:n))*(q(iq)) kin=kin*kin WRITE(55,'(1p2e16.7)') q(iq),kin ENDDO CLOSE(55) ENDIF !(e<=0) ENDDO ! ib DEALLOCATE(q,dum,dum1) END SUBROUTINE ftkin !*********************************************************************** ! program to calculate Fourier transform of vloc and tden ! in order to get an idea of their convergence ! and output them to files ftvloc !*********************************************************************** SUBROUTINE ftvloc(Grid,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, PARAMETER :: nq=200 REAL(8), PARAMETER :: qmax=15.d0 REAL(8), ALLOCATABLE :: q(:),dum(:),dum1(:) REAL(8), POINTER :: r(:) REAL(8) :: h,dq,vloc,tden INTEGER :: i,ib,l,iq,n,irc CHARACTER(4) flnm ! WRITE(6,*) 'calculating Fourier transforms of vloc and tden' n=Grid%n h=Grid%h irc=PAW%irc r=>Grid%r ALLOCATE(q(nq),dum(n),dum1(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating space in ftvloc',n,nq,i STOP ENDIF OPEN(55,file='ftvloc',form='formatted') dq=qmax/nq l=0 DO iq=1,nq q(iq)=iq*dq DO i=1,n dum(i)=q(iq)*r(i) ENDDO CALL sphbes(l,n,dum) DO i=1,n dum1(i)=dum(i)*PAW%vloc(i)*(r(i)**2) dum(i)=dum(i)*PAW%tden(i) ENDDO vloc=integrator(Grid,dum1(1:n),1,irc) tden=integrator(Grid,dum(1:n)) WRITE(55,'(1p4e16.7)') q(iq),vloc,tden,vloc*tden ENDDO CLOSE(55) DEALLOCATE(q,dum,dum1) END SUBROUTINE ftvloc !******************************************************************* ! function to calculated for smooth paw wavefunction !******************************************************************* FUNCTION sepnorm(Grid,PAW,nr,l,wfn) REAL(8) :: sepnorm TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: nr,l REAL(8), INTENT(IN) :: wfn(:) INTEGER :: n,ib,ic,nbase,irc REAL(8) :: h REAL(8), ALLOCATABLE :: b(:) n=Grid%n; h=Grid%h; nbase=PAW%nbase; irc=PAW%irc ALLOCATE(b(nbase),stat=ib) IF (ib/=0) THEN WRITE(6,*) 'Error in sepnorm allocation', nbase,ib STOP ENDIF IF (nr0) THEN ALLOCATE(a(lcount,lcount),stat=ib) IF (ib/=0) THEN WRITE(6,*) 'Error in unboundsep allocation', lcount,ib STOP ENDIF icount=0 DO ib=1,nbase summ=0.d0 IF (l==PAW%l(ib)) THEN icount=icount+1 DO ic=1,nbase IF (l==PAW%l(ic)) THEN summ=summ+(PAW%dij(ib,ic)-energy*PAW%oij(ib,ic))*& overlap(Grid,PAW%otp(:,ic),wfn,1,irc) ENDIF ENDDO b(icount)=-summ ENDIF ENDDO ! icount=0 DO ia=1,nbase IF (l==PAW%l(ia)) THEN icount=icount+1 jcount=0 DO ib=1,nbase IF (l==PAW%l(ib)) THEN jcount=jcount+1 summ=0.d0 IF (ia.EQ.ib) summ=1.d0 DO ic=1,nbase IF (l==PAW%l(ic)) THEN summ=summ+(PAW%dij(ia,ic)-energy*PAW%oij(ia,ic))*& overlap(Grid,PAW%otp(:,ic),y(:,jcount),1,irc) ENDIF ENDDO a(icount,jcount)=summ ENDIF ENDDO ENDIF ENDDO ! CALL linsol(a,b,lcount) icount=0 DO ib=1,nbase IF(l==PAw%l(ib)) THEN icount=icount+1 wfn(1:nr)=wfn(1:nr)+b(icount)*y(1:nr,icount) ENDIF ENDDO DEALLOCATE(a) ENDIF ! ! normalize to unity within integration range ! scale=1.d0/sepnorm(Grid,PAW,nr,l,wfn) IF (scale.LE.0.d0) THEN WRITE(6,*) 'warning -- negative norm for l=',l scale=-scale IF (scale.EQ.0.d0) scale=1.d0 ENDIF scale=DSIGN(SQRT(scale),wfn(nr-2)) wfn(1:nr)=wfn(1:nr)*scale DEALLOCATE(b,y) END SUBROUTINE unboundsep !*************************************************************************** ! pgm to solve separable radial schroedinger equation ! for bound state near energy 'energy' and at angular momentum l ! ! with smooth potential rveff/r, given in uniform mesh of n points ! r=i*h, i=1,...n-1 ;assuming p(r)=C*r**(l+1)*polynomial(r) for r==0; ! p((n+1)*h)=0 ! ! uses Noumerov algorithm ! ! For l=0,1 corrections are needed to approximate wfn(r=0) ! These depend upon: ! e0 (current guess of energy eigenvalue) ! l,nz==0 ! v(0) == v0 electronic potential at r=0 ! v'(0) == v0p derivative of electronic potential at r=0 ! ! also returns node == number of nodes for calculated state ! ! proj == projector functions ! hij and qij == hamiltonianian and overlap matrix elements !*************************************************************************** SUBROUTINE boundsep(Grid,Pot,PAW,l,node,energy,emin,emax,wfn) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: l,node REAL(8), INTENT(INOUT) :: energy,emin,emax REAL(8), INTENT(INOUT) :: wfn(:) INTEGER, PARAMETER :: niter=100 INTEGER :: n,i,j,ia,ib,ic,nbase,icount,jcount,lcount INTEGER :: match,mmatch,irc,node1,iter REAL(8), PARAMETER :: convre=1.d-10,err=1.d-9 REAL(8) :: summ,h,scale,best,energy0,dele,x,rin,rout,zeroval,ppp REAL(8), ALLOCATABLE :: p1(:),u(:),y(:,:),b(:),a(:,:) n=Grid%n; h=Grid%h; nbase=PAW%nbase; irc=PAW%irc ! ALLOCATE(p1(n),u(n),y(n,nbase),b(nbase),stat=ib) IF (ib/=0) THEN WRITE(6,*) 'Error in boundsep allocation', n,nbase,ib STOP ENDIF !WRITE(6,*) 'in boundsep with ', l,node,energy,emin,emax lcount=0 DO ib=1,nbase IF (l==PAW%l(ib)) THEN lcount=lcount+1 ENDIF ENDDO ! IF(lcount>0) THEN ALLOCATE(a(lcount,lcount),stat=ib) IF (ib/=0) THEN WRITE(6,*) 'Error in boundsep allocation', lcount,ib STOP ENDIF ENDIF IF (emax.GT.0.d0) emax=0.d0 best=1.d10 IF (energy.LT.emin) energy=emin+err IF (energy.GT.emax) energy=emax energy0=energy iter=0 DO match=MIN(irc+10,n-10) x=0.5d0*(Pot%rv(n)/Grid%r(n)+Pot%rv(n-1)/Grid%r(n-1))+& l*(l+1)/(Grid%r(n)**2) ppp=SQRT(ABS(x-energy)) p1=0 p1(n)=1 p1(n-1)=exp(-ppp*(Grid%r(n-1)-Grid%r(n))) !write(6,*) 'before backward', n,p1(n-1),p1(n) !write(6,*) 'before backward', x,ppp,exp(-ppp*(Grid%r(n-1)-Grid%r(n))) !write(6,*) 'x,energy', x,energy,ABS(x-energy),SQRT(ABS(x-energy)) !call flush(6) CALL backward_numerov(Grid,l,match-5,energy,Pot%rv,p1) rin=Gfirstderiv(Grid,match,p1)/p1(match) mmatch=match+1 !WRITE(6,*) 'match, rin ' ,match,rin ! ! perform outward integration until match point -- it is assumed ! that projector functions proj are zero for r>r(match) ! ! initialize u u=0 u(2)=wfninit(0,l,Pot%v0,Pot%v0p,energy,Grid%r(2)) zeroval=0 if (l==1) zeroval=2 call forward_numerov(Grid,l,mmatch+5,energy& ,Pot%rv,zeroval,u,node1) ! lcount=0 DO ib=1,nbase IF (l==PAW%l(ib)) THEN lcount=lcount+1 CALL inhomogeneous_numerov(Grid,l,mmatch+5,energy,& Pot%rv,PAW%otp(:,ib),y(:,lcount)) ENDIF ENDDO ! IF(lcount>0) THEN icount=0 DO ib=1,nbase summ=0.d0 IF (l==PAW%l(ib)) THEN icount=icount+1 DO ic=1,nbase IF (l==PAW%l(ic)) THEN summ=summ+(PAW%dij(ib,ic)-energy*PAW%oij(ib,ic))*& overlap(Grid,PAW%otp(:,ic),u,1,irc) ENDIF ENDDO b(icount)=-summ ENDIF ENDDO ! icount=0 DO ia=1,nbase IF (l==PAW%l(ia)) THEN icount=icount+1 jcount=0 DO ib=1,nbase IF (l==PAW%l(ib)) THEN jcount=jcount+1 summ=0.d0 IF (ia.EQ.ib) summ=1.d0 DO ic=1,nbase IF (l==PAW%l(ic)) THEN summ=summ+(PAW%dij(ia,ic)-energy*PAW%oij(ia,ic))*& overlap(Grid,PAW%otp(:,ic),y(:,jcount),1,irc) ENDIF ENDDO a(icount,jcount)=summ ENDIF ENDDO ENDIF ENDDO ! CALL linsol(a,b,lcount) wfn=0 wfn(1:mmatch+5)=u(1:mmatch+5) icount=0 DO ib=1,nbase IF(l==PAw%l(ib)) THEN icount=icount+1 wfn(1:mmatch+5)=wfn(1:mmatch+5)+b(icount)*y(1:mmatch+5,icount) ENDIF ENDDO ENDIF rout=Gfirstderiv(Grid,match,wfn)/wfn(match) !WRITE(6,'("node,match,rin,rout",2i8,1p2e15.7)') node1,match,rin,rout ! -- estimate correction node1=0 wfn(:)=wfn(:)/wfn(match) DO j=3,match IF (wfn(j)*wfn(j-1).LT.0.d0) node1=node1+1 ENDDO !WRITE(6,*) 'actual number of nodes', node1 !This test is obsolete: pseudo-WFs do not have to be orthogonal ! IF (node1node) THEN ! ! too many nodes -- lower energy ! emax=MIN(energy-err,emax) ! energy=emin+(energy-emin)*ranx() ! !WRITE(6,*) 'too many nodes -- energy lowered', energy,emin,emax ! !do i=1,mmatch ! !write(200+iter,'(1p7e15.7)')Grid%r(i),wfn(i) ! !enddo ! ELSEIF (node1==node) THEN DO j=match,n wfn(j)=p1(j)/p1(match) ENDDO ! normalization scale=1.d0/sepnorm(Grid,PAW,n,l,wfn) dele=(rout-rin)*scale !WRITE(6,*) 'dele,scale',dele,scale scale=SQRT(scale) wfn=scale*wfn !do i=1,n ! write(100+iter,'(1p2E15.7)') Grid%r(i),wfn(i) !enddo x=ABS(dele) IF (x.LT.best) THEN energy0=energy best=x ENDIF IF (ABS(dele).LE.convre) EXIT energy=energy+dele !WRITE(6,*) 'next energy' , energy,dele ! if energy is out of range, pick random energy in correct range IF (emin-energy.GT.convre.OR.energy-emax.GT.convre) THEN energy=emin+(emax-emin)*ranx()+err ! WRITE(6,*) 'energy out of range -- reranged --', energy ENDIF ! ENDIF iter=iter+1 !WRITE(6,*) 'Energy for next iteration ', iter,energy IF (iter.GT.niter) THEN WRITE(6,*) 'no convergence in boundsep',l,dele,energy WRITE(6,*) ' best guess of eig, dele = ',energy0,best STOP ENDIF ENDDO ! ! normalize to unity within integration range ! CALL filter(n,wfn,1.d-11) scale=1.d0/sepnorm(Grid,PAW,n,l,wfn) IF (scale.LE.0.d0) THEN WRITE(6,*) 'warning -- negative norm for l=',l scale=-scale IF (scale.EQ.0.d0) scale=1.d0 ENDIF scale=DSIGN(SQRT(scale),wfn(n-2)) wfn(1:n)=wfn(1:n)*scale !WRITE(6,*) 'exiting boundsep with energy ', l,energy DEALLOCATE(a,b,y,u,p1) END SUBROUTINE boundsep !********************************************************* ! program to to transform smooth wavefunction to all-electron ! wavefunction within Blochl's paw formalism ! otp == projector function ! odphi == ophi - otphi !********************************************************* SUBROUTINE PStoAE(Grid,PAW,nr,l,tpsi,psi) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: nr,l REAL(8), INTENT(IN) :: tpsi(:) REAL(8), INTENT(INOUT) :: psi(:) INTEGER :: n,ib,nbase,irc REAL(8) :: h,scale n=Grid%n; h=Grid%h; nbase=PAW%nbase; irc=PAW%irc IF (nrib) THEN !!!! PAW%oij(ic,ib)=PAW%oij(ib,ic) !!!! PAW%dij(ic,ib)=PAW%dij(ib,ic) !!!! ENDIF !!!! ENDIF !!!! ENDDO !!!! ENDDO ! load PS PS%rv=PAW%rveff ; PS%nz=0 call zeropot(Grid,PS%rv,PS%v0,PS%v0p) ! ! calculate logderivatives at irc ! WRITE(6,*) 'calculating log derivatives at irc',Grid%r(irc) ! mbase=nbase DO l=0,PAW%lmax+1 CALL mkname(l,flnm) OPEN(56,file='logderiv.'//TRIM(flnm),form='formatted') DO ie=1,ne energy=e0+de*(ie-1) psi=0;tpsi=0;ttpsi=0 if (scalarrelativistic) then CALL unboundsr(Grid,Pot,nr,l,energy,psi,nodes) else CALL unboundsch(Grid,Pot,nr,l,energy,psi,nodes) endif CALL unboundsep(Grid,PS,PAW,nr,l,energy,tpsi,nodes) CALL PStoAE(Grid,PAW,nr,l,tpsi,ttpsi) ! dwdr=Gfirstderiv(Grid,irc,psi)/psi(irc) dcwdr=Gfirstderiv(Grid,irc,ttpsi)/ttpsi(irc) WRITE(56,'(1p5e12.4)') energy,dwdr,dcwdr IF (ie.EQ.ke) THEN mbase=mbase+1 CALL mkname(mbase,flnm) OPEN(57,file='wfn'//TRIM(flnm),form='formatted') WRITE(57,*) '# l=',l,'energy=',energy ! ! form converted wavefunction and rescale exact wavefunction ! scale=ttpsi(irc)/psi(irc) DO i=1,nr WRITE(57, '(1p5e12.4)') Grid%r(i),tpsi(i),ttpsi(i),psi(i)*scale ENDDO CLOSE(57) ENDIF ENDDO !ie CLOSE(56) ENDDO !l DEALLOCATE(psi,tpsi,PS%rv) END SUBROUTINE logderiv !************************************************************************** !************************************************************************** SUBROUTINE SCFPAW(Grid,nz,PAW,FC,AEOrbit,PSOrbit,Etotal,newconfig) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: nz TYPE (PseudoInfo), INTENT(INOUT) :: PAW TYPE (FCinfo), INTENT(INOUT) :: FC TYPE (OrbitInfo), INTENT(IN) :: AEOrbit TYPE (OrbitInfo), INTENT(INOUT) :: PSOrbit REAL(8), INTENT(OUT) :: Etotal LOGICAL, INTENT(IN), OPTIONAL :: newconfig TYPE (Anderson_Context) , POINTER :: PSd,PSw ! program to calculate the self-consistent density functional ! atom for a given configuration within the PAW formalism INTEGER, PARAMETER :: mxloop=1000 INTEGER :: n,io,nbase,ip,l,nfix,i,j,k,mnbase,norbit INTEGER :: loop,irc,ib,ic,id,ie,node,ns,nb INTEGER , ALLOCATABLE :: mmap(:),mp(:) REAL(8), PARAMETER :: rimix=0.5,worst=1.d-5 REAL(8), PARAMETER :: conv1=1.d13,conv2=2.d13,conv3=3.d13,conv4=4.d13 REAL(8) :: occ,xocc,rmix,cnvrg,ecoul,etxc,eexc,Q00,dEdQ,h REAL(8) :: energy, emin,emax,x,delta,w1,w2,w3,w4,dcore,tcore REAL(8), ALLOCATABLE :: v1(:),v2(:),d1(:),d2(:),wij(:,:),Psi(:,:),Eig(:) REAL(8), ALLOCATABLE :: den(:),dendiff(:),dij(:,:),wijold(:),wijdiff(:) REAL(8), ALLOCATABLE :: vtcore(:) TYPE(PotentialInfo) :: PSPot w1=conv1;w2=conv2;w3=conv3;w4=conv4 nbase=PAW%nbase; irc=PAW%irc; n=Grid%n; mnbase=(nbase*(nbase+1))/2 h=Grid%h !WRITE(6,*) ' in SCFPAW ', nbase,irc,n,mnbase !CALL flush(6) if (present(newconfig)) then norbit=0 WRITE(6,*) 'Current occupancies:' WRITE(6,*) ' n l occupancy energy ' DO io=1,AEOrbit%norbit IF (.NOT.FC%iscore(io)) THEN WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') AEOrbit%np(io),& AEOrbit%l(io),AEOrbit%occ(io),& AEOrbit%eig(io) norbit=norbit+1 ENDIF ENDDO PSOrbit%norbit=norbit ALLOCATE(PSOrbit%np(norbit),PSOrbit%l(norbit),PSOrbit%occ(norbit),& PSOrbit%eig(norbit),PSOrbit%wfn(n,norbit),stat=ib) IF (ib /= 0 ) THEN WRITE(6,*) 'Allocation error in SCFPAW -- norbit,n',norbit,n,ib STOP ENDIF norbit=0 DO io=1,AEOrbit%norbit IF (.NOT.FC%iscore(io)) THEN norbit=norbit+1 PSOrbit%np(norbit)=AEOrbit%np(io) PSOrbit%l(norbit)=AEOrbit%l(io) PSOrbit%occ(norbit)=AEOrbit%occ(io) PSOrbit%eig(norbit)=AEOrbit%eig(io) ENDIF ENDDO ALLOCATE(d1(n),d2(n),v1(n),v2(n),PSPot%rv(n),PSPot%den(n),& den(n),dendiff(n),vtcore(n),& wij(nbase,nbase),dij(nbase,nbase),wijold(mnbase),wijdiff(mnbase),& Psi(n,norbit),Eig(norbit),mmap(norbit),mp(norbit),stat=ib) IF (ib /= 0 ) THEN WRITE(6,*) 'Allocation error in SCFPAW -- nbase,n',nbase,n,ib STOP ENDIF WRITE(6,*) 'enter np l occ for all revisions' WRITE(6,*) ' enter 0 0 0 to end' DO READ(5,*) ip,l,xocc IF (ip.LE.0) EXIT nfix=-100 DO io=1,norbit IF (ip==PSOrbit%np(io).AND.l==PSOrbit%l(io)) THEN nfix=io EXIT ENDIF ENDDO IF (nfix.LE.0.OR.nfix.GT.norbit) THEN WRITE(6,*) 'error in occupations -- ip,l,xocc', & ip,l,xocc,nfix,norbit STOP ENDIF PSOrbit%occ(nfix)=xocc ENDDO PSPot%nz=0 PSPot%den=0 FC%zvale=0 WRITE(6,*) 'New configuration:' DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') PSOrbit%np(io),& PSOrbit%l(io),PSOrbit%occ(io), PSOrbit%eig(io) FC%zvale=FC%zvale+PSOrbit%occ(io) DO ib=1,PAW%nbase IF (PSOrbit%l(io)==PAW%l(ib).AND. & PSOrbit%np(io)==PAW%np(ib)) THEN PSOrbit%wfn(:,io)=PAW%tphi(:,ib) ENDIF ENDDO ENDDO else norbit=0 DO io=1,AEOrbit%norbit IF (.NOT.FC%iscore(io)) THEN norbit=norbit+1 ENDIF ENDDO PSOrbit%norbit=norbit ALLOCATE(PSOrbit%np(norbit),PSOrbit%l(norbit),PSOrbit%occ(norbit),& PSOrbit%eig(norbit),PSOrbit%wfn(n,norbit),stat=ib) IF (ib /= 0 ) THEN WRITE(6,*) 'Allocation error in SCFPAW -- norbit,n',norbit,n,ib STOP ENDIF norbit=0 DO io=1,AEOrbit%norbit IF (.NOT.FC%iscore(io)) THEN norbit=norbit+1 PSOrbit%np(norbit)=AEOrbit%np(io) PSOrbit%l(norbit)=AEOrbit%l(io) PSOrbit%occ(norbit)=AEOrbit%occ(io) PSOrbit%eig(norbit)=AEOrbit%eig(io) ENDIF ENDDO ALLOCATE(d1(n),d2(n),v1(n),v2(n),PSPot%rv(n),PSPot%den(n),& den(n),dendiff(n),vtcore(n),& wij(nbase,nbase),dij(nbase,nbase),wijold(mnbase),wijdiff(mnbase),& Psi(n,norbit),Eig(norbit),mmap(norbit),mp(norbit),stat=ib) IF (ib /= 0 ) THEN WRITE(6,*) 'Allocation error in SCFPAW -- nbase,n',nbase,n,ib STOP ENDIF PSPot%nz=0 PSPot%den=0 FC%zvale=0 WRITE(6,*) 'Recalculating configuration:' DO io=1,norbit WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') PSOrbit%np(io),& PSOrbit%l(io),PSOrbit%occ(io), PSOrbit%eig(io) FC%zvale=FC%zvale+PSOrbit%occ(io) DO ib=1,PAW%nbase IF (PSOrbit%l(io)==PAW%l(ib).AND. & PSOrbit%np(io)==PAW%np(ib)) THEN PSOrbit%wfn(:,io)=PAW%tphi(:,ib) ENDIF ENDDO ENDDO endif WRITE(6,*) ' Total charge, Valence charge = ', FC%zvale+FC%zcore, FC%zvale ! initialize Anderson Mix arrays rmix=rimix CALL InitAnderson(PSd,6,5,n,rmix,1.d5) CALL InitAnderson(PSw,6,5,mnbase,rmix,1.d5) cnvrg=worst WRITE(6,*) 'Density convergence parameter set to at least',cnvrg den=0; dendiff=0; wijold=0; wijdiff=0 d1=FC%coreden-PAW%tcore dcore=integrator(Grid,d1,1,PAW%irc_core) WRITE(6,*) 'Delta core den = ', dcore tcore=integrator(Grid,PAW%tcore) WRITE(6,*) 'tcore total = ', tcore CALL poisson(Grid,tcore,PAW%tcore,vtcore,ecoul) DO loop = 1,mxloop delta=0 IF (loop > 1) THEN den=PSPot%den i=0 do ib=1,PAW%nbase do ic=ib,PAW%nbase i=i+1 wijold(i)=wij(ib,ic) enddo enddo ENDIF PSPot%den=0; wij=0 Etotal=0 WRITE(6,*) ' results for loop = ',loop WRITE(6,*) ' n l occupancy energy' DO io=1,norbit PSPot%den=PSPot%den+PSOrbit%occ(io)*(PSOrbit%wfn(:,io))**2 CALL calcwij(Grid,PAW,PSOrbit%l(io),PSOrbit%occ(io),& PSOrbit%wfn(:,io),wij) CALL kinetic(Grid,PSOrbit%l(io),PSOrbit%wfn(:,io),x) Etotal=Etotal+PSOrbit%occ(io)*x WRITE(6,'(i2,1x,i2,4x,1p2e15.7)') & PSOrbit%np(io),PSOrbit%l(io),& PSOrbit%occ(io),PSOrbit%eig(io) ENDDO i=0 do ib=1,PAW%nbase do ic=ib,PAW%nbase i=i+1 wijdiff(i)=wij(ib,ic)-wijold(i) enddo enddo ! open(88,file='wijtest',form='formatted') ! Do ib=1,nbase ! Do ic=1,nbase ! write(88,'(2i5,1pe15.7)') ib,ic,wij(ib,ic) ! Enddo ! Enddo ! close(88) Q00=-nz+dcore DO ib=1,nbase DO ic=1,nbase Q00=Q00+wij(ib,ic)*PAW%Oij(ib,ic) ENDDO ENDDO WRITE(6,*) 'loop = ',loop,' Q00 = ',Q00 x=integrator(Grid,PSPot%den) !WRITE(6,*) ' x, density scaling ', x,-(Q00+tcore)/x !x=-(Q00+tcore)/x WRITE(6,*) ' x, density scaling ', & x,(FC%zvale-nz+dcore-Q00)/x x=(FC%zvale-nz+dcore-Q00)/x PSPot%den=PSPot%den*x dendiff=PSPot%den-den IF (loop > 1 ) THEN delta=SUM(ABS(dendiff)) WRITE(6,*) ' tden delta ',delta delta=delta+SUM(ABS(wijdiff)) WRITE(6,*) ' second delta ' , delta CALL shift4(w1,w2,w3,w4,delta) CALL Anderson_Mix(PSd,den,dendiff) do i=1,n if (den(i) < 1.d-11) den(i)=0 enddo PSPot%den=den CALL Anderson_Mix(PSw,wijold,wijdiff) CALL filter(mnbase,wijold,1.d-11) i=0 DO ib=1,nbase DO ic=ib,nbase i=i+1 wij(ib,ic)=wijold(i) wij(ic,ib)=wijold(i) ENDDO ENDDO !Rescale densities Q00=-nz+dcore DO ib=1,nbase DO ic=1,nbase Q00=Q00+wij(ib,ic)*PAW%Oij(ib,ic) ENDDO ENDDO WRITE(6,*) ' Q00 after Andersonmix = ',Q00 x=integrator(Grid,PSPot%den) !WRITE(6,*) ' x, density scaling ', x,-(Q00+tcore)/x !x=-(Q00+tcore)/x WRITE(6,*) ' x, density scaling ', & x,(FC%zvale-nz+dcore-Q00)/x x=(FC%zvale-nz+dcore-Q00)/x PSPot%den=PSPot%den*x ENDIF PSPot%q=integrator(Grid,PSPot%den) WRITE(6,*) 'tq = ', PSPot%q CALL poisson(Grid,PSPot%q,PSPot%den,PSPot%rv,ecoul) v1(2:n)=PSPot%rv(2:n)/Grid%r(2:n) call extrapolate(Grid,v1) dEdQ=overlap(Grid,v1,PAW%hatden,1,PAW%irc_shap) write(6,*) 'dEdQ old', dEdQ d1(2:n)=PAW%hatpot(2:n)/Grid%r(2:n) call extrapolate(Grid,d1) dEdQ=overlap(Grid,d1,PSPot%den) write(6,*) 'dEdQ new', dEdQ DO ib=1,nbase DO ic=1,nbase dEdQ=dEdQ-wij(ib,ic)*PAW%vhatij(ib,ic) ENDDO ENDDO WRITE(6,*) ' dEdQ = ', dEdQ d1=PAW%tcore+PSPot%den x=integrator(Grid,d1) write(6,*) 'tcore+tden total ', x CALL poisson(Grid,x,d1,v1,ecoul) CALL exch(Grid,d1,v2,etxc,eexc) PSPot%rv(:)=v1+v2+Grid%r(:)*PAW%vloc(:)+Q00*PAW%hatpot(:) !do i=1,n !write(122,'(1p2e15.7)') Grid%r(i),PSPot%rv(i) !enddo !stop call zeropot(Grid,PSPot%rv,PSPot%v0,PSPot%v0p) ! if((loop/10)*10==loop) then ! do i=1,n ! write(100+(loop/10),'(1p12e15.7)') Grid%r(i),PSPot%rv(i),rv(i),rvdiff(i) ! enddo ! endif v1(2:n)=PAW%vloc(2:n)+(vtcore(2:n)+Q00*PAW%hatpot(2:n))/Grid%r(2:n) call extrapolate(Grid,v1) Etotal=Etotal+overlap(Grid,PSPot%den,v1) CALL poisson(Grid,PSPot%q,PSPot%den,v1,ecoul) Etotal=Etotal+ecoul+eexc PAW%dij=0 DO ib=1,nbase DO ic=1,nbase PAW%dij(ib,ic)=PAW%tvij(ib,ic)-Q00*PAW%vhatij(ib,ic) & +dEdQ*PAW%v0ij(ib,ic) ! write(6,'("dij part",2i3,1p10e15.7)') ib,ic,PAW%dij(ib,ic),PAW%tvij(ib,ic),PAW%vhatij(ib,ic),PAW%v0ij(ib,ic) ! call flush(6) Etotal=Etotal+wij(ib,ic)*(PAW%tvij(ib,ic)-Q00*PAW%vhatij(ib,ic)) DO id=1,nbase DO ie=1,nbase PAW%dij(ib,ic)=PAW%dij(ib,ic)+& wij(id,ie)*PAW%vhijkl(ib,ic,id,ie) ! write(6,'("dij part",4i3,1p10e15.7)') ib,ic,id,ie,PAW%dij(ib,ic),PAW%vhijkl(ib,ic,id,ie) ! call flush(6) Etotal=Etotal+0.5d0*wij(ib,ic)*wij(id,ie)*PAW%vhijkl(ib,ic,id,ie) ENDDO ENDDO ENDDO ENDDO ! exchange-correlation part d1=FC%coreden; d2=PAW%tcore DO ib=1,nbase DO ic=1,nbase d1=d1+wij(ib,ic)*PAW%ophi(:,ib)*PAW%ophi(:,ic) d2=d2+wij(ib,ic)*PAW%otphi(:,ib)*PAW%otphi(:,ic) ENDDO ENDDO CALL exch(Grid,d1,v1,etxc,eexc,irc) Etotal=Etotal+eexc CALL exch(Grid,d2,v2,etxc,eexc,irc) Etotal=Etotal-eexc !CALL exch(n,h,FC%coreden,d2,x,eexc) !Etotal=Etotal-eexc !CALL exch(n,h,PAW%tcore,d2,x,eexc) !Etotal=Etotal+eexc DO ib=1,nbase DO ic=1,nbase IF (PAW%l(ib)==PAW%l(ic)) THEN d1=v1(:)*PAW%ophi(:,ib)*PAW%ophi(:,ic) & -v2(:)*PAW%otphi(:,ib)*PAW%otphi(:,ic) d1(2:n)=d1(2:n)/Grid%r(2:n) call extrapolate(Grid,d1) PAW%dij(ib,ic)=PAW%dij(ib,ic)+integrator(Grid,d1,1,irc) ! write(6,*)' after vxc',ib,ic,PAW%dij(ib,ic) ENDIF ENDDO ENDDO WRITE(6,'(" loop, Etotal, delta",i8,1p2e15.7)') loop,Etotal,delta DO l=0,PAW%lmax ns=0; Psi=0; Eig=0;mmap=0;mp=0;nb=0 nb=0 DO io=1,PAW%nbase IF (l == PAW%l(io)) THEN nb=nb+1 mp(nb)=io ENDIF ENDDO DO io=1,norbit IF (l == PSOrbit%l(io)) THEN ns=ns+1 mmap(ns)=io Psi(:,ns)=PSOrbit%wfn(:,io) CALL calcHPsi(Grid,PSPot,PAW,l,nb,mp,Psi(:,ns),d1) Eig(ns)=overlap(Grid,Psi(:,ns),d1) !write(6,*) 'Eig',ns,Eig(ns) !Eig(ns)=PSOrbit%eig(io) ENDIF ENDDO !CALL BlockDavidson(Grid,PSPot,PAW,l,ns,Psi,Eig) emin=-100 DO io=1,ns If (io==1) then do i=1,AEOrbit%norbit if (AEOrbit%l(i)==l.AND.& FC%iscore(i)) & emin=AEOrbit%eig(i)+0.00001 enddo Endif node=io-1; emax=0 !write(6,*) 'calling boundsep', node,emax,Eig(io) CALL boundsep(Grid,PSPot,PAW,l,node,& Eig(io),emin,emax,Psi(:,io)) !PSOrbit%eig(mmap(io))=Eig(io) !PSOrbit%wfn(:,mmap(io))=Psi(:,io) emin=Eig(io)+0.00001 ENDDO CALL gramschmidt(Grid,PAW,nb,mp,ns,Psi(:,1:ns)) PSOrbit%eig(mmap(1:ns))=Eig(1:ns) PSOrbit%wfn(:,mmap(1:ns))=Psi(:,1:ns) ENDDO IF (loop>=4) THEN IF (.NOT.(w4.LE.w3.AND.w3.LE.w2 & .AND.w2.LE.w1).AND.w4.LE.cnvrg) THEN ! ! converged result ! WRITE(6,*) ' SCFPAW converged in',loop,& ' iterations -- delta = ',delta EXIT ENDIF ENDIF ENDDO CALL FreeAnderson(PSd) CALL FreeAnderson(PSw) DEALLOCATE(d1,d2,v1,v2,PSPot%rv,PSPot%den,den,dendiff,wij,& wijold,wijdiff,Psi,Eig,mmap,mp,vtcore) END SUBROUTINE SCFPAW !*** NOTE: Block-Davidson routines are not currently working !*************************************************************************** ! Routines needed for Block-Davidson solver !*************************************************************************** SUBROUTINE gramschmidt(Grid,PAW,nb,mp,many,wfn) TYPE (GridInfo), INTENT(IN) :: Grid TYPE (PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: nb,mp(:) INTEGER, INTENT(INOUT) :: many REAL(8), INTENT(INOUT) :: wfn(:,:) REAL(8) :: smallest REAL(8), ALLOCATABLE :: b(:),bp(:),res(:) REAL(8) :: h,x INTEGER :: i,j,k,l,n,irc smallest=1.e-11 n=Grid%n; h=Grid%h; irc=PAW%irc ALLOCATE(b(nb),bp(nb),res(many),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in graschmidt allocation', nb,i STOP ENDIF DO i=1,many IF (i>1) THEN DO j=1,i-1 IF (res(j) >= smallest) THEN DO k=1,nb b(k)=overlap(Grid,wfn(:,i),PAW%otp(:,mp(k)),1,irc) ENDDO DO k=1,nb bp(k)=overlap(Grid,wfn(:,j),PAW%otp(:,mp(k)),1,irc) ENDDO x=overlap(Grid,wfn(:,i),wfn(:,j)) DO k=1,nb DO l=1,nb x=x+b(k)*bp(l)*PAW%Oij(mp(k),mp(l)) ENDDO ENDDO wfn(:,i)=wfn(:,i)-x*wfn(:,j) ENDIF ENDDO ENDIF DO k=1,nb b(k)=overlap(Grid,wfn(:,i),PAW%otp(:,mp(k)),1,irc) ENDDO res(i)=overlap(Grid,wfn(:,i),wfn(:,i)) DO k=1,nb DO l=1,nb res(i)=res(i)+b(k)*b(l)*PAW%Oij(mp(k),mp(l)) ENDDO ENDDO !write(6,*) 'gramschmidt norm',i,res(i) IF (res(i) >= smallest) THEN x=SQRT(res(i)) wfn(:,i)=wfn(:,i)/x ENDIF ENDDO i=0 DO j=1,many IF (res(j) >= smallest) THEN i=i+1 IF (j/=i) wfn(:,j)=wfn(:,i) ENDIF ENDDO !WRITE(6,*) 'Returning from gramschmidt with ',i,many many=i DEALLOCATE(b,bp,res) END SUBROUTINE gramschmidt !*** NOTE: Block-Davidson routines are not currently working SUBROUTINE calcHPsi(Grid,Pot,PAW,l,nb,mp,Psi,HPsi) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(in) :: l,nb,mp(:) REAL(8), INTENT(IN) :: Psi(:) REAL(8), INTENT(INOUT) :: HPsi(:) INTEGER :: n,irc,ib,ic REAL(8) :: h REAL(8), ALLOCATABLE :: b(:) ALLOCATE(b(nb),stat=ib) IF (ib /= 0) THEN WRITE(6,*) 'Allocation Error in calcHpsi --',ib,nb STOP ENDIF n=GRID%n; h=GRID%h; irc=PAW%irc HPsi=0 CALL laplacian(Grid,l,Psi,HPsi) HPsi(2:n)=(Pot%rv(2:n)*Psi(2:n)-Hpsi(2:n))/Grid%r(2:n) DO ib=1,nb b(ib)=overlap(Grid,Psi,PAW%otp(:,mp(ib)),1,irc) ENDDO DO ib=1,nb DO ic=1,nb HPsi=HPsi+PAW%otp(:,mp(ib))*PAW%Dij(mp(ib),mp(ic))*b(ic) ENDDO ENDDO DEALLOCATE(b) END SUBROUTINE calcHPsi !*** NOTE: Block-Davidson routines are not currently working SUBROUTINE calcOPsi(Grid,PAW,nb,mp,Psi,OPsi) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(in) :: nb,mp(:) REAL(8), INTENT(IN) :: Psi(:) REAL(8), INTENT(INOUT) :: OPsi(:) INTEGER :: n,irc,ib,ic REAL(8) :: h REAL(8), ALLOCATABLE :: b(:) ALLOCATE(b(nb),stat=ib) IF (ib /= 0) THEN WRITE(6,*) 'Allocation Error in calcOpsi --',ib,nb STOP ENDIF n=GRID%n; h=GRID%h; irc=PAW%irc OPsi=Psi DO ib=1,nb b(ib)=overlap(Grid,Psi,PAW%otp(:,mp(ib)),1,irc) ENDDO DO ib=1,nb DO ic=1,nb OPsi=OPsi+PAW%otp(:,mp(ib))*PAW%Oij(mp(ib),mp(ic))*b(ic) ENDDO ENDDO DEALLOCATE(b) END SUBROUTINE calcOPsi !****************************************************************************** ! ! Diagonalizer - Diagonalizes Hbase & OBase matrices ! ! VecSize - Number of basis vectors used to construct Hbase, OBase ! ArraySize - Dimension of Hbase, OBase ! NewSize - Number of EigenValues and EigenVectors returned ! Eigen - List of EigenValues ! Vec - MAtrix containing the new eigenvectors ! DoOrthog - If true, assume Obase is identity matrix ! Hbase, Obase - Assumed to be Hermitian ! ! Based on Alan Tackett's routine !****************************************************************************** !*** NOTE: Block-Davidson routines are not currently working Subroutine Diagonalizer(VecSize, ArraySize, NewSize, Hbase, Obase, & Eigen, Vec) Integer, Intent(IN) :: VecSize Integer, Intent(IN) :: ArraySize Integer, Intent(OUT) :: NewSize REAL(8), Intent(INOUT) :: Hbase(:,:) REAL(8), Intent(INOUT) :: Obase(:,:) REAL(8), Intent(OUT) :: Eigen(:) REAL(8), Intent(OUT) :: Vec(:,:) Integer :: i, j, k, LWork, LSize Integer :: Info REAL(8), allocatable :: Omat(:,:),Hmat(:,:),VecR(:,:),Work(:),JUNK(:,:) Real(8) ,allocatable :: Lambda(:) Real(8) :: tol,val Allocate(Hmat(ArraySize, ArraySize), VecR(ArraySize, ArraySize), & Omat(ArraySize, ArraySize), Work(4*ArraySize), & JUNK(ArraySize,ArraySize), Lambda(ArraySize)) tol=1.d-8 LWork = 4*ArraySize NewSize=VecSize Hmat = Hbase; Omat = Obase; VecR = 0 Hmat = Hbase; Omat = Obase Info =13; NewSize=VecSize Call DSYEV('V', 'U', VecSize, Omat(1,1), ArraySize, Lambda, & Work, LWork, Info) write(6,*) ' completed Omat diagonalization with Info=',Info j=0 ; VecR=0 Do i=1,VecSize write(6,*) 'i lambda',i,Lambda(i) If (Lambda(i) > tol) then j=j+1 VecR(1:VecSize,j)=Omat(1:VecSize,i)/SQRT(Lambda(i)) EndIf Enddo If (j > 0) then NewSize=j Else Write(6,*) 'O matrix is singular', Lambda Stop Endif Write(6,*) 'NewSize = ',NewSize Omat=0 do k=1,NewSize do i=1,VecSize do j=1,VecSize Omat(i,k)=Omat(i,k)+(Hmat(j,i))*VecR(j,k) Enddo Enddo Enddo Hmat=0 do k=1,NewSize do i=1,NewSize Do j=1,VecSize Hmat(i,k)=Hmat(i,k)+(VecR(j,i))*Omat(j,k) Enddo Enddo Enddo Call DSYEV('V', 'U', NewSize, Hmat(1,1), ArraySize, Eigen, & Work, LWork, Info) write(6,*) ' completed Hmat diagonalization with Info=',Info Omat=Hmat Hmat=0 JUNK(1:NewSize,1:VecSize)=TRANSPOSE(VecR(1:VecSize,1:NewSize)) do k=1,NewSize do i=1,VecSize Do j=1,NewSize Hmat(i,k)=Hmat(i,k)+JUNK(j,i)*Omat(j,k) Enddo Enddo Enddo write(6,*) ' completed Hmat diagonalization with Info=',Info if (info /= 0) then write(6,*) 'Stopping due to diagonalizer error' stop endif Vec = Hmat DeAllocate(Hmat,Omat,VecR,Work,JUNK,Lambda) End Subroutine !*** NOTE: Block-Davidson routines are not currently working SUBROUTINE BlockDavidson(Grid,Pot,PAW,l,ns,Psi,Eig) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(in) :: l,ns REAL(8), INTENT(INOUT) :: Psi(:,:),Eig(:) INTEGER, ALLOCATABLE :: mp(:) INTEGER :: nb,na,last,start,finish,nbase INTEGER :: i,j,k,ib,ic,in,iter,n,irc,lwork INTEGER, PARAMETER :: niter=1000,repeat=1 REAL(8), PARAMETER :: small=1.e-8 REAL(8), PARAMETER :: conv1=4.d13,conv2=3.d13,conv3=2.d13,conv4=1.d13 REAL(8), ALLOCATABLE :: A(:,:),O(:,:),Vec(:,:),fn(:,:),en(:),w(:),work(:) REAL(8) :: delta,h,v1,v2,v3,v4 v1=conv1;v2=conv2;v3=conv3;v4=conv4 IF (ALLOCATED(mp)) DEALLOCATE(mp) nbase=PAW%nbase nb=0 DO i=1,nbase IF (l==PAW%l(i)) THEN nb=nb+1 ENDIF ENDDO IF (nb > 0) THEN ALLOCATE(mp(nb),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in BlockDavidson-makemp',nb,i STOP ENDIF j=0 DO i=1,nbase IF (l==PAW%l(i)) THEN j=j+1 mp(j)=i ENDIF ENDDO ELSE WRITE(6,*) 'Error in BlockDavidson-makemap',l,PAW%l STOP ENDIF n=Grid%n; h=Grid%h; irc=PAW%irc na=ns*(repeat+1); lwork=na*na+3*na ALLOCATE(A(na,na),O(na,na),Vec(na,na),fn(n,na),en(na),w(n),work(lwork),stat=i) IF (i /=0) THEN WRITE(6,*) 'Allocation error in BlockDavidson',na,i STOP ENDIF A=0;O=0;fn=0;en=0 in=ns CALL gramschmidt(Grid,PAW,nb,mp,in,Psi) IF (inrc ! Ci coefficients are returned !****************************************************************************** SUBROUTINE pspolyn(func,Ci,r,l,np,irc,n) INTEGER,INTENT(IN) :: irc,l,n,np REAL(8),INTENT(IN) :: func(n),r(n) REAL(8),INTENT(OUT) :: Ci(np) INTEGER :: i,j,np2 REAL(8) :: rc,xx,y,scale REAL(8),ALLOCATABLE :: A(:,:),X(:) if (irc<3.or.irc>irc.or.irc>n-3) stop 'pspolyn: rc out of range' if (np<1) stop 'pspolyn: p out of range' allocate(A(np,np),X(np),stat=i) if (i/=0) stop 'allocation error in pspolyn' rc=r(irc);np2=np/2 scale=(rc/(rc-r(irc-1)))**2 ! Scale to limit rounding error in linsol do i=1,np xx=r(i+irc-np2-1)/rc y=xx*xx A(i,1)=scale do j=2,np A(i,j)=A(i,j-1)*y enddo X(i)=scale*func(i+irc-np2-1)/(xx**(l+1)) enddo call linsol(A,X,np) write(6,*) 'Completed linsol with coefficients' write(6,'(1p10e15.7)') (X(i),i=1,np) do i=1,np Ci(i)=X(i)/rc**(l+2*i-1) enddo deallocate(A,X) END SUBROUTINE pspolyn !****************************************************************************** ! Pseudization routine: PSUSPOLYN ! Pseudize a function with a polynom ! tfunc(r)=r^(l+1).Sum[Ci.r^2i] 0<=i<=np-1 if r<=rc ! tfunc(r)=func(r) if r>rc ! For i>3, Ci coefficients are computed so that to minimize ! Fourier coefficients of pseudized function for q>qcut ! Ci coefficients are returned !****************************************************************************** SUBROUTINE psuspolyn(func,Ci,r,l,np,irc,n,qcut) INTEGER,INTENT(IN) :: irc,l,n,np REAL(8),INTENT(IN) :: qcut REAL(8),INTENT(IN) :: func(n),r(n) REAL(8),INTENT(OUT) :: Ci(np) INTEGER,PARAMETER :: nq=2001 REAL(8),PARAMETER :: lfact(0:5)=(/1.d0,3.d0,15.d0,105.d0,945.d0,10395.d0/) INTEGER :: i,j,k,ip,iq,jq,il,ix,jx REAL(8) :: qh,qrc2,rc,xx,scale,yy(6,6),zz(6) REAL(8),ALLOCATABLE :: A(:,:),X(:),Q(:,:),qq(:),ff(:),gg(:) if (irc<3.or.irc>irc.or.irc>n-6) stop 'psuspolyn: rc out of range' if (np<4) stop 'psuspolyn: polynomial degree for pseudization was too small' allocate(A(np+4,np+4),X(np+4),Q(nq,np+4),qq(nq),ff(nq),gg(nq),stat=i) if (i/=0) stop 'allocation error in psuspolyn' il=l+1;rc=r(irc) qh=qcut/dfloat(nq-1) do iq=1,nq qq(iq)=0.5d0*qcut+qh*dble(iq-1) enddo Q(:,:)=0.d0 do ip=1,np do iq=1,nq qrc2=0.5d0*(qq(iq)*rc)**2 xx=1.d0;ix=0 do while (abs(xx)>1.d-20) ix=ix+1 xx=xx*qrc2/dble(ix)/dble(2*(ix+l)+1) enddo xx=0.d0 do jx=ix,1,-1 xx=qrc2/dble(jx)/dble(2*(jx+l)+1)*(1.d0/dble(2*(jx+ip+l)+1)-xx) enddo Q(iq,ip)=4.d0*pi*rc**dble(2*ip+il)*(qq(iq)*rc)**dble(l)/lfact(l) & & *(1.0/dble(2*(l+ip)+1)-xx) enddo enddo A(:,:)=0.d0 do iq=1,np do ip=1,np do jq=1,nq ff(jq)=qq(jq)**4*Q(jq,iq)*Q(jq,ip) enddo A(iq,ip)=overint(nq,qh,ff) enddo enddo do iq=1,np ix=2*(iq-1)+il A(np+1,iq)=rc**dble(ix) A(np+2,iq)=dble(ix)*rc**(ix-1) A(np+3,iq)=dble(ix*(ix-1))*rc**(ix-2) A(np+4,iq)=dble(ix*(ix-1)*(ix-2))*rc**(ix-3) A(iq,np+1)=A(np+1,iq) A(iq,np+2)=A(np+2,iq) A(iq,np+3)=A(np+3,iq) A(iq,np+4)=A(np+4,iq) enddo yy(:,:)=0.d0;zz(:)=0.d0 do i=1,6 do j=1,6 if (i==1.and.j==1) then yy(i,j)=12.d0 else do k=1,12 yy(i,j)=yy(i,j)+(r(irc+k-6)-rc)**(i+j-2) enddo endif enddo enddo do k=1,12 zz(1)=zz(1)+func(irc+k-6) end do do i=2,6 do k=1,12 zz(i)=zz(i)+func(irc+k-6)*(r(irc+k-6)-rc)**(i-1) end do end do scale=1/(rc-r(irc-1))**3;yy=yy*scale;zz=zz*scale ! Scale to limit rounding error in linsol call linsol(yy,zz,6) zz(3)=2.d0*zz(3);zz(4)=6.d0*zz(4) X(np+1:np+4)=zz(1:4) do iq=1,nq gg(iq)=4.d0*pi*intjl(rc,qq(iq),zz,l) enddo do ip=1,np do iq=1,nq ff(iq)=qq(iq)**4*gg(iq)*Q(iq,ip) enddo X(ip)=-overint(nq,qh,ff) enddo scale=(rc/(rc-r(irc-1)))**2;A=A*scale;X=X*scale ! Scale to limit rounding error in linsol call linsol(A,X,np+4) write(6,*) 'Completed linsol with coefficients' write(6,'(1p10e15.7)') (X(i),i=1,np+4) Ci(1:np)=X(1:np) deallocate(A,X,Q,qq,ff,gg) END SUBROUTINE psuspolyn !****************************************************************************** ! Pseudization routine: PSBES ! Pseudize a function with a sum of 2 Bessel functions ! (following PHYS REV B 41,1227 (1990)) ! tfunc(r)=[al(1)*jl(ql(1)*r)+al(2)*jl(ql(2)*r)]*r if r<=rc ! tfunc(r)=func(r) if r>rc ! al and ql coefficients are returned !****************************************************************************** SUBROUTINE psbes(func,al,ql,Grid,l,irc,n) INTEGER,INTENT(IN) :: irc,l,n REAL(8),INTENT(IN) :: func(n) REAL(8),INTENT(OUT) :: al(2),ql(2) TYPE(GridInfo),INTENT(IN) :: Grid INTEGER :: i REAL(8) :: alpha,beta,det,qr,jbes,jbesp,jbespp,rc REAL(8) :: amat(2,2),bb(2) rc=Grid%r(irc) beta=1.D0 alpha=1.D0-Gfirstderiv(Grid,irc,func)*rc/func(irc) call solvbes(ql,alpha,beta,l,2) ql(1:2)=ql(1:2)/rc do i=1,2 qr=ql(i)*rc call jbessel(jbes,jbesp,jbespp,l,2,qr) jbespp=2.d0*ql(i)*jbesp+jbespp*ql(i)*ql(i)*rc jbesp=jbes+jbesp*ql(i)*rc jbes=jbes*rc amat(1,i)=jbes amat(2,i)=jbespp enddo bb(1)=func(irc) bb(2)=Gsecondderiv(Grid,irc,func) det=amat(1,1)*amat(2,2)-amat(1,2)*amat(2,1) al(1)=(amat(2,2)*bb(1)-amat(1,2)*bb(2))/det al(2)=(amat(1,1)*bb(2)-amat(2,1)*bb(1))/det END SUBROUTINE psbes END MODULE basis ./src/calcpotential.f900000644004704100470410000000663011202701404014762 0ustar natalienatalieMODULE calcpotential USE gridmod USE excor USE atomdata, only : finitenucleus USE globalmath, only : pi,derf IMPLICIT NONE TYPE PotentialInfo INTEGER :: nz ! nz is nuclear charge CHARACTER(2) :: sym REAL(8) :: q,v0,v0p ! q is total electron charge ! v0,v0p are potential value and deriv at r=0 REAL(8) , POINTER :: den(:),rv(:) ! den(n) is electron density * (4*pi*r**2) ! rv(n) is veff * r END TYPE PotentialInfo CONTAINS SUBROUTINE potential(Grid,Pot,ecoul,etxc,eexc) ! calculate veff for density functional theory from electron density ! ecoul and etxc are coulomb and exchange-correlation contributions ! to the total energy ! eexc is the total exchange energy (int(den*exc)) ! v0=v(0) ! v0p=dv/dr(0) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(INOUT) :: Pot REAL(8), INTENT(INOUT) :: ecoul,etxc,eexc REAL(8), POINTER :: den(:),rv(:) REAL(8), allocatable :: rvxc(:) INTEGER :: n,nz REAL(8) :: h,q,v0,v0p REAL(8) :: r,RR INTEGER :: i,j,k ! INTEGER :: fcount=0 n=Grid%n h=Grid%h den=>Pot%den rv=>Pot%rv nz=Pot%nz v0=0;v0p=0 ! ! Coulomb contribution ! CALL poisson(Grid,Pot%q,den,rv,ecoul,v0) ! ! Exchange-correlation contribution exc-vxc ! allocate(rvxc(n),stat=i) if (i /= 0) then write(6,*) 'Error in potential -- allocation of rvxc', n,i stop endif Pot%v0=v0 CALL exch(Grid,den,rvxc,etxc,eexc,n,v0,v0p) ! !fcount=fcount+1 !do i=1,n ! write(400+fcount,'(1p7e15.7)') Grid%r(i),den(i),rv(i),rvxc(i) !enddo rv(1:n)=rv(1:n)+rvxc(1:n) ! ! calculate v0 and v0p ! Pot%v0=Pot%v0+v0 Pot%v0p=v0p !call zeropot(Grid,rv,Pot%v0,Pot%v0p) ! ! Add in Nuclear contribution ! If (.not.finitenucleus) then DO i=1,n rv(i)=rv(i)-2*nz ENDDO Else RR=nz RR=2.9d-5*(RR**0.3333333333333333333333333d0) DO i=1,n rv(i)=rv(i)-2*nz*derf(Grid%r(i)/RR) ENDDO Pot%v0=Pot%v0-4*nz/(sqrt(pi)*RR) Endif WRITE(6,*) 'v0, v0p = ', Pot%v0,Pot%v0p DEALLOCATE(rvxc) END SUBROUTINE potential subroutine ClassicalTurningPoint(Grid,Pot,l,energy,turningpoint) Type(GridInfo), INTENT(IN) :: Grid Type(PotentialInfo), INTENT(IN) :: Pot Integer, INTENT(IN) :: l Real(8), INTENT(IN) :: energy Integer, INTENT(OUT) :: turningpoint integer :: i,n Real(8), allocatable :: v(:) n=Grid%n allocate(v(n), stat=i) if (i /= 0) then write(6,*) 'Allocation error in ClassicalTurningPoint ', i,n stop endif v=0 v(2:n)=Pot%rv(2:n)/Grid%r(2:n)+l*(l+1)/(Grid%r(2:n)**2) turningpoint=n do i=n,2,-1 if (v(i) machine_infinity .or. t*t > machine_infinity) THEN fxc=0.d0; dfxcdn=0.d0; dfxcdgbg=0.d0 RETURN ENDIF ex=-3.d0*kf/(4.d0*pi) pprs=SQRT(rs)*(b1+b3*rs)+rs*(b2+b4*rs) !ec=-2.d0*AA*(1.d0+a1*rs)*ddlog(1.d0+1.d0/(2.d0*AA*pprs)) term=Logofterm(1.d0/(2.d0*AA*pprs)) ec=-2.d0*AA*(1.d0+a1*rs)*term Fx=1.d0+kappa -kappa/(1.d0+(mu/kappa)*s*s) A=Aofec(ec) At2=A*t*t ppt=(1.d0+At2*(1.d0+At2)) !H=gamm*ddlog(1.d0+(betabygamm)*(t*t)*((1.d0+At2)/ppt)) H=gamm*Logofterm((betabygamm)*(t*t)*((1.d0+At2)/ppt)) fxc=n*(ex*Fx+ec+H) dFds = (2.d0*mu*s)/(1.d0+(mu/kappa)*(s**2))**2 dFdsbg = ((2.d0*mu)/(1.d0+(mu/kappa)*(s**2))**2)/(2.d0*kf*n) dHdt = (2.d0*t*beta*gamm*(1.d0+2.d0*At2))/((gamm*ppt+beta*t*t*(1.d0+At2))*ppt) dHdtbg = ((2.d0*beta*gamm*(1.d0+ & 2.d0*At2))/((gamm*ppt+beta*t*t*(1.d0+At2))*ppt))/(2.d0*ks*n) !decdrs=-(2.d0*AA*a1)*ddlog(1.d0+1.d0/(2*AA*pprs)) & decdrs=-(2.d0*AA*a1)*term & +((1.d0+a1*rs)*((b1+3*b3*rs)/(2.d0*SQRT(rs))+b2+2*b4*rs))/(pprs*(pprs+1.d0/(2.d0*AA))) dHdA=((2.d0+At2)*(At2*t*t*t*t*beta*gamm))/((gamm*ppt+beta*t*t*(1.d0+At2))*ppt) dAdrs=-ddexp(-ec/gamm)*A*A*decdrs/beta dHdrs=dHdA*dAdrs dfxcdn = (4.d0/3.d0)*ex*(Fx-dFds*s)+ec-(decdrs*rs)/3.d0+H-(dHdrs*rs)/3.d0 & - (7.d0/6.d0)*dHdt*t dfxcdgbg = ex*dFdsbg/(2.d0*kf) + dHdtbg/(2.d0*ks) IF ((ABS(fxc).GT.1.d65).OR.(ABS(dfxcdn).GT.1.d65).OR.(ABS(dfxcdgbg).GT.1.d65)) THEN WRITE(6,*) 'Problem in PBE',n,g,rs,s,t,ec,A,H ENDIF RETURN END SUBROUTINE pbefunc !******************************************************************* ! ! Function Logofterm -- needed to take care of behavior for small term ! Evaluates log(1+term) FUNCTION Logofterm(term) REAL(8) :: term, Logofterm IF (ABS(term)>machine_precision) THEN Logofterm=ddlog(1.d0+term) ELSE Logofterm=term ENDIF RETURN END FUNCTION Logofterm !******************************************************************* ! ! Function Aofec -- needed to take care of behavior for small ec FUNCTION Aofec(ec) REAL(8) :: ec, Aofec IF (ABS(ec)>machine_precision) THEN Aofec=betabygamm/(ddexp(-ec/gamm)-1.d0) ELSEIF (ABS(ec)>machine_zero) THEN Aofec=beta/(-ec) ELSE Aofec=-beta*DSIGN(machine_infinity,ec) ENDIF RETURN END FUNCTION Aofec !******************************************************************** ! ! Subroutine radialexcpbe ! Density(:) input on a uniform radial mesh of Npts ! Grid%r(:) input mesh points ! Exc - output integrated exchange correlation energy -- in Rydberg units ! vxc(:) -- output exchange correlation potential -- in Rydberg units ! !******************************************************************** SUBROUTINE radialexcpbe(Grid,density,Exc,vxc,fin) IMPLICIT NONE Type (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: density(:) REAL(8), INTENT(OUT) :: Exc, vxc(:) INTEGER, INTENT(IN), OPTIONAL :: fin INTEGER :: i,j , ierr,Npts REAL(8),allocatable :: gradient(:),gradmag(:),gxc(:),dgxcdr(:),fxc(:) REAL(8) :: dfxcdn,dfxcdgbg,sgn REAL(8) :: h !rewind(201); rewind(202) Npts=Grid%n if (present(fin)) Npts=fin allocate(gradient(Npts),gradmag(Npts),gxc(Npts),dgxcdr(Npts), & fxc(Npts),stat=i) if (i /=0) then write(6,*) 'error in radialexcpbe allocation ', Npts,i stop endif ! if (.not.scalarrelativistic) then CALL derivative(Grid,density(1:Npts),gradient(1:Npts),1,Npts) ! else ! CALL simplederiv(Grid,density(1:Npts),gradient(1:Npts),1,Npts) ! endif gradmag=ABS(gradient) DO i=1,Npts CALL pbefunc(density(i),gradmag(i),fxc(i),dfxcdn,dfxcdgbg) vxc(i)=dfxcdn gxc(i)=dfxcdgbg*gradient(i) !write(201,'(i5,1p6e15.7)') i,Grid%r(i),density(i),gradient(i),vxc(i),gxc(i) ENDDO ! if (.not.scalarrelativistic) then CALL derivative(Grid,gxc(1:Npts),dgxcdr(1:Npts),1,Npts) ! else ! CALL simplederiv(Grid,gxc(1:Npts),dgxcdr(1:Npts),1,Npts) ! endif DO i=2,Npts fxc(i)=2*fxc(i)*4*pi*(Grid%r(i)**2) !2* changes from Har to Ryd vxc(i)=2*vxc(i)-2*dgxcdr(i)-4*gxc(i)/Grid%r(i) ! Correction thanks ! to Marc Torrent and Francois Jollet ENDDO fxc(1)=0 CALL extrapolate(Grid,vxc) !Do i=1,Npts ! write(202,'(i5,1p6e15.7)') i,Grid%r(i),density(i),fxc(i),vxc(i),dgxcdr(i) !enddo Exc = integrator(Grid,fxc,1,Npts) RETURN END SUBROUTINE radialexcpbe !******************************************************************* SUBROUTINE exch(Grid,den,rvxc,etxc,eexc,fin,v0,v0p) ! calculate exchange correlation potentials and energys ! for density functional theory from electron density ! den(n) is electron density * (4*pi*r**2) ! rvxc(n) is returned as vxc * r ! to the total energy ! eexc is the total exchange energy (int(den*exc)) ! etxc is eexc - int(den*vxc) Type (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: den(:) REAL(8), INTENT(INOUT) :: rvxc(:),etxc,eexc INTEGER, INTENT(IN), OPTIONAL :: fin REAL(8), INTENT(OUT), OPTIONAL :: v0,v0p REAL(8), ALLOCATABLE :: tmpd(:),tmpv(:),dum(:) REAL(8) :: fpi INTEGER :: i,n,i1,i2 REAL(8) :: r,r2,rho,exc,vxc n=Grid%n if (present(fin)) n=fin fpi=4*pi rvxc=0 SELECT CASE(itype) CASE default WRITE(6,*) 'Error in exch -- itype not correct', itype STOP CASE(GGA_PBE) !!!!!!!PBE form!!!!!! ALLOCATE(tmpd(n),tmpv(n)) tmpd=0 DO i=2,n tmpd(i)=den(i)/(fpi*(Grid%r(i)**2)) ENDDO call extrapolate(Grid,tmpd) if (present(fin)) then CALL radialexcpbe(Grid,tmpd,eexc,tmpv,fin) else CALL radialexcpbe(Grid,tmpd,eexc,tmpv) endif WRITE(6,*) 'eexc',eexc if (present(v0).and.present(v0p)) then call derivative(Grid,tmpv,tmpd,1,15) v0=tmpv(1) v0p=tmpd(1) endif DO i=1,n rvxc(i)=tmpv(i)*Grid%r(i) tmpv(i)=tmpv(i)*den(i) ENDDO etxc=eexc-integrator(Grid,tmpv(1:n),1,n) DEALLOCATE(tmpd,tmpv) CASE (LDA_PW) !!! ! Perdew-Wang LDA !!!! ALLOCATE(tmpd(n),tmpv(n),dum(n)) tmpd=0;tmpv=0;rvxc=0;dum=0 DO i=2,n r=Grid%r(i) r2=r*r tmpd(i)=den(i)/(fpi*r2) ENDDO call extrapolate(Grid,tmpd) Do i=1,n CALL pwldafunc(tmpd(i),exc,vxc) tmpd(i)=den(i)*(exc-vxc) tmpv(i)=den(i)*exc rvxc(i)=Grid%r(i)*vxc if (present(v0).and.present(v0p)) then if (i==1) v0=vxc dum(i)=vxc endif ENDDO ! calculate exchange-correlation contribution to the potential ! etxc=dsum(n,a,1)*h ! eexc=dsum(n,b,1)*h etxc=integrator(Grid,tmpd(1:n),1,n) eexc=integrator(Grid,tmpv(1:n),1,n) WRITE(6,*) 'etxc,eexc = ',etxc,eexc if (present(v0).and.present(v0p)) then call derivative(Grid,dum,tmpd,1,15) v0p=tmpd(1) endif DEALLOCATE(tmpd,tmpv,dum) END SELECT END SUBROUTINE exch END MODULE excor ./src/globalmath.f900000644004704100470410000010475511202701404014261 0ustar natalienatalieMODULE GlobalMath IMPLICIT NONE REAL(8) :: pi , machine_precision , machine_zero , machine_infinity REAL(8), PRIVATE :: minlog,maxlog,minexp,maxexp REAL(8), PRIVATE :: minlogarg,maxlogarg,minexparg,maxexparg CONTAINS !**************************************************** SUBROUTINE Init_GlobalConstants INTEGER :: i REAL(8) :: tmp , a1,a2,a3 ! Calculate machine accuracy machine_precision = 0 a1 = 4.d0/3.d0 DO WHILE (machine_precision == 0.d0) a2 = a1 - 1.d0 a3 = a2 + a2 + a2 machine_precision = ABS(a3 - 1.d0) ENDDO machine_zero= machine_precision**4 machine_infinity = 1.d0/machine_zero pi = ACOS(-1.d0) minlogarg=machine_precision; minlog=LOG(minlogarg) maxlogarg=1.d0/machine_precision; maxlog=LOG(maxlogarg) minexparg=LOG(machine_precision); minexp=0.d0 maxexparg=-LOG(machine_precision); maxexp=EXP(maxexparg) RETURN END SUBROUTINE Init_GlobalConstants !**************************************************** FUNCTION ddlog(arg) REAL(8) :: arg,ddlog IF (arg>maxlogarg) THEN ddlog=maxlog ELSE IF (argmaxexparg) THEN ddexp=maxexp ELSE IF (arg 0) THEN DO i=1, kkm s = 0.0d0 DO j=i,kk r=ABS(a(j,i)) IF(r > s) THEN s=r l=j ENDIF ENDDO IF(l /= i) THEN DO j=i,kk s=a(i,j) a(i,j)=a(l,j) a(l,j)=s ENDDO s=b(i) b(i)=b(l) b(l)=s d = -d ENDIF IF (a(i,i) /= 0.0d0) THEN ipo=i+1 DO j=ipo,kk IF (a(j,i) /= 0.0d0) THEN s=a(j,i)/a(i,i) a(j,i) = 0.0d0 DO k=ipo,kk a(j,k)=a(j,k)-a(i,k)*s ENDDO b(j)=b(j)-b(i)*s ENDIF ENDDO ENDIF ENDDO DO i=1,kk d=d*a(i,i) ENDDO kmo=kk-1 b(kk)=b(kk)/a(kk,kk) DO i=1,kmo n=kk-i DO j=n,kmo b(n)=b(n)-a(n,j+1)*b(j+1) ENDDO b(n)=b(n)/a(n,n) ENDDO ENDIF IF(ABS(d).LT.1.d-10) WRITE(6,*) '**warning from linsol --',& 'determinant too small --',d END SUBROUTINE linsol SUBROUTINE minverse(a,kk) REAL(8), INTENT(INOUT) :: a(:,:) INTEGER, INTENT(IN) :: kk REAL(8) :: d,s,r REAL(8), allocatable :: ai(:,:) INTEGER :: kkm,i,j,k,l,ipo,n,kmo allocate(ai(kk,kk),stat=i) if (i/=0) then write(6,*) 'Allocation error in minverse',i,kk stop endif ai=0 do i=1,kk ai(i,i)=1 enddo d = 1.00000d0 kkm=kk-1 IF (kkm == 0) THEN ai(1,1)=ai(1,1)/a(1,1) ELSE IF (kkm > 0) THEN DO i=1, kkm s = 0.0d0 DO j=i,kk r=ABS(a(j,i)) IF(r > s) THEN s=r l=j ENDIF ENDDO IF(l /= i) THEN DO j=i,kk s=a(i,j) a(i,j)=a(l,j) a(l,j)=s ENDDO Do k=1,kk s=ai(i,k) ai(i,k)=ai(l,k) ai(l,k)=s Enddo d = -d ENDIF IF (a(i,i) /= 0.0d0) THEN ipo=i+1 DO j=ipo,kk IF (a(j,i) /= 0.0d0) THEN s=a(j,i)/a(i,i) a(j,i) = 0.0d0 DO k=ipo,kk a(j,k)=a(j,k)-a(i,k)*s ENDDO Do k=1,kk ai(j,k)=ai(j,k)-ai(i,k)*s enddo ENDIF ENDDO ENDIF ENDDO DO i=1,kk d=d*a(i,i) ENDDO kmo=kk-1 do k=1,kk ai(kk,k)=ai(kk,k)/a(kk,kk) DO i=1,kmo n=kk-i DO j=n,kmo ai(n,k)=ai(n,k)-a(n,j+1)*ai(j+1,k) ENDDO ai(n,k)=ai(n,k)/a(n,n) ENDDO enddo ENDIF a=ai deallocate(ai) IF(ABS(d).LT.1.d-10) WRITE(6,*) '**warning from linsol --',& 'determinant too small --',d END SUBROUTINE minverse FUNCTION factorial(n) REAL(8) :: factorial INTEGER, INTENT(IN) :: n INTEGER :: i factorial=1 IF (n.LT.2) RETURN DO i=2,n factorial=factorial*i ENDDO END FUNCTION factorial !************************************************************************* ! FUNCTION hwfn(z,np,l,r) ! ! function to calculate the radial H wfn for nuclear charge z ! (note in this version z is real and need not be integral) ! principal qn np ! orbital qn l ! r*(radial H wfn) is returned !************************************************************************* FUNCTION hwfn(z,np,l,r) REAL(8) :: hwfn REAL(8), INTENT(IN) :: z,r INTEGER, INTENT(IN) :: np,l INTEGER :: node,k REAL(8) :: scale,rho,pref,term,sum node=np-l-1 scale=2.d0*z/np rho=scale*r pref=scale*SQRT(scale*factorial(np+l)/(2*np*factorial(node))) term=(rho**l)/factorial(2*l+1) sum=term IF (node.GT.0) THEN DO k=1,node term=-term*(node-k+1)*rho/(k*(2*l+1+k)) sum=sum+term ENDDO ENDIF hwfn=r*pref*EXP(-0.5d0*rho)*sum ! write(6,*) 'r,hwfn=',r,hwfn END FUNCTION hwfn !*************************************************************************** ! subroutine filter(n,func,small) !*************************************************************************** SUBROUTINE filter(n,func,small) INTEGER, INTENT(IN) :: n REAL(8), INTENT(INOUT) :: func(:) REAL(8), INTENT(IN) :: small INTEGER :: i DO i=1,n IF (ABS(func(i)).LT.small) func(i)=0.d0 ENDDO END SUBROUTINE filter !****************************************************************************** ! From: ! File : misc.f90 ! by : Alan Tackett ! on : 10/17/95 ! for : Misc general purpose functions ! ! This module contains misc. general purpose routines that don't fit ! in another library. Below is a list of routines contained : ! ! PrintDate(Unit, Text) ! Prints the date and time to the specified unit along with the TEXT ! !***************************************************************************** !****************************************************************************** ! ! PrintDate - Prints the date to the specified unit with TEXT prepended. ! ! Unit - Output unit ! Text - Text for prepending. All trailing blanks are removed. ! !****************************************************************************** Subroutine PrintDate(Unit, Text) Integer, Intent(IN) :: Unit Character*(*), Intent(IN) :: Text Character*10 :: DateStr, TimeStr Character*50 :: FmtStr Call Date_And_Time(DateStr, TimeStr) FmtStr=' ' // DateStr(5:6) // '/' // DateStr(7:8) // '/' // DateStr(1:4) // & ', ' // TimeStr(1:2) // ':' // TimeStr(3:4) // ':' // & TimeStr(5:10) Write(Unit, '(a,a)') Trim(Text), Trim(FmtStr) Return End Subroutine Function stripchar(inputchar) CHARACTER(132) :: stripchar CHARACTER*(*), INTENT(IN) :: inputchar INTEGER :: i,j,n n=LEN(inputchar) do i=1,132 stripchar(i:i)='' enddo j=0 do i=1,n if (inputchar(i:i) /= '') then j=j+1 stripchar(j:j)=inputchar(i:i) endif enddo End function stripchar Subroutine ConvertChar(inchar,outn) CHARACTER*(*),INTENT(IN) :: inchar INTEGER, INTENT(OUT) :: outn INTEGER :: i, j, k, n, fac n=LEN(inchar) fac=1; outn=0 do i=n,1,-1 If (inchar(i:i)==''.or.inchar(i:i)=="-") exit j=ichar(inchar(i:i))-48 outn=outn+fac*j fac=fac*10 enddo outn=outn write(6,*) 'exiting ConvertChar', inchar,outn end subroutine ConvertChar subroutine extractword(wordindex,stringin,stringout) integer, INTENT(IN) :: wordindex Character(*), INTENT(IN) :: stringin Character(*), INTENT(OUT) :: stringout integer :: i,j,n,str,fin,icount stringout='' n=len(stringin) i=index(stringin,'!');if (i==0) i=n j=index(stringin,'#');if (j==0) j=n n=min(i,j,n) str=1;fin=n do icount=1,max(1,wordindex-1) do i=str,n if (stringin(i:i)/=' ') exit enddo str=i if (n>str) then do i=str+1,n if(stringin(i:i)==' ') exit enddo fin=i endif if (wordindex>2) then if (fin1) then if (fin>=n) return do i=fin+1,n if (stringin(i:i)/=' ') exit enddo str=i if (n>str) then do i=str+1,n if(stringin(i:i)==' ') exit enddo fin=i endif endif stringout=stringin(str:fin) end subroutine extractword !***************************************************************************** ! !!! Routine written by Alan Tackett ! UpperCase - Converts a string to Upper Case ! ! str - String to convert ! !***************************************************************************** Subroutine UpperCase(str) Character(*), Intent(INOUT) :: str Integer :: i, j, k j = len(Str) Do i=1, j k = IACHAR(str(i:i)) if ((k>96) .AND. (k<123)) str(i:i) = ACHAR(k-32) End Do Return End subroutine UpperCase !***************************************************************** ! subroutine conthomas(n,o,d,sol) !***************************************************************** ! use Thomas's algorithm for inverting matrix ! Dale U. von Rosenberg, "Methods for the Numerical Solution of ! Partial Differential Equations, ! Am. Elsevier Pub., 1969, pg. 113 ! On input, sol contains the RHS of the equation ! On ouput, sol contains the solution of the equation ! Equation: o*sol(i-1)+d*sol(i)+o*sol(i+1) = RHS(i) ! sol(1)==sol(n+1)==0 ! simplified version for constant tridiagonal terms -- SUBROUTINE conthomas(n,o,d,sol) INTEGER, INTENT(IN) :: n REAL(8), INTENT(IN) :: o,d REAL(8), INTENT(INOUT) :: sol(:) REAL(8), ALLOCATABLE :: a(:),b(:) REAL(8) :: ss2 INTEGER :: i ALLOCATE(a(n),b(n),stat=i) IF (i /= 0) THEN WRITE(6,*) 'Thomas: allocation error ', i,n STOP ENDIF a(2)=d ss2=o*o DO i=3,n a(i)=d-ss2/a(i-1) ENDDO b(2)=sol(2)/d DO i=3,n b(i)=(sol(i)-o*b(i-1))/a(i) ENDDO sol(n)=b(n) DO i=n-1,2,-1 sol(i)=b(i)-o*sol(i+1)/a(i) ENDDO sol(1)=0 DEALLOCATE(a,b) END SUBROUTINE conthomas SUBROUTINE thomas(n,a,b,c,d) ! subroutine to use Thomas's algorithm to solve tridiagonal matrix ! Dale U. von Rosenberg, "Methods for the Numerical Solution of ! Partial Differential Equations, Am. Elsevier Pub., 1969, pg. 113 ! a(i)*u(i-1)+b(i)*u(i)+c(i)*u(i+1)=d(i) ! a(1)=c(n)==0 ! upon return, d(i)=u(i), a,b, & c modified INTEGER, INTENT(IN) :: n REAL(8), INTENT(INOUT) :: a(:),b(:),c(:),d(:) INTEGER :: i IF (n.LT.1) THEN WRITE(6,*) '***error in thomas -- n = ',n STOP ELSE IF (n.EQ.1) THEN d(1)=d(1)/b(1) RETURN ELSE DO i=2,n b(i)=b(i)-a(i)*c(i-1)/b(i-1) ENDDO d(1)=d(1)/b(1) DO i=2,n d(i)=(d(i)-a(i)*d(i-1))/b(i) ENDDO DO i=n-1,1,-1 d(i)=d(i)-c(i)*d(i+1)/b(i) ENDDO ENDIF RETURN END SUBROUTINE thomas FUNCTION intjl(rc,q,ff,l) ! Compute the integral from rc to inf of ! r**2*f(r)*jl(q*r) ! assuming large q and small f(inf) ! Expanded up to q**(-5) integer :: l real(8) :: intjl,q,rc,ff(4) real(8) :: cqr,sqr,qinv,qinv2 cqr=cos(q*rc);sqr=sin(q*rc) qinv=1.0/q;qinv2=qinv*qinv if(l.eq.0) then intjl=cqr*qinv2*(ff(1)-ff(3)*qinv2)& & -sqr*qinv2*qinv*(ff(2)-ff(4)*qinv2) else if(l.eq.1) then intjl=sqr*qinv2*(ff(1)-qinv2*(ff(3)+ff(2)/rc-ff(1)/(rc*rc)))& & +cqr*qinv2*qinv*(ff(2)+ff(1)/rc-qinv2*(ff(4)& & +ff(3)/rc-2.0*(ff(2)-ff(1)/rc)/(rc*rc))) else if(l.eq.2) then intjl=cqr*qinv2*(-ff(1)+qinv2*(ff(3)+3.0*ff(2)/rc))& & +sqr*qinv2*qinv*(ff(2)+3.0*ff(1)/rc& & -qinv2*(ff(4)+3.0*(ff(3)-ff(2)/rc)/rc)) else if(l.eq.3) then intjl=ff(1)*(cqr*(-6.d0*qinv**3/rc-3.d0*qinv**5/rc**3)+& & sqr*(9.d0*qinv**4/rc**2-qinv2)) +& & ff(2)*(cqr*(3.d0*qinv**5/rc**2-qinv**3)+& & sqr*6.d0*qinv**4/rc) +& & ff(3)*(6.d0*cqr*qinv**5/rc+sqr*qinv**4)+& & ff(4)*cqr*qinv**5 else stop 'Error in intjl: l too large !' endif END FUNCTION intjl !****************************************************************** ! subroutine jbessel(bes,besp,bespp,ll,order,xx) ! Spherical bessel function and derivatives !****************************************************************** SUBROUTINE jbessel(bes,besp,bespp,ll,order,xx) INTEGER,INTENT(IN) :: ll,order REAL(8),INTENT(IN) :: xx REAL(8),INTENT(OUT) :: bes,besp,bespp INTEGER,PARAMETER :: imax=40 REAL(8),PARAMETER :: prec=1.d-15 INTEGER :: ii,il REAL(8) :: besp1,fact,factp,factpp,jn,jnp,jnpp,jr,xx2,xxinv IF (order>2) STOP "Wrong order in jbessel !" if (abs(xx)=1) then besp=0.d0;if (ll==1) besp=1.d0/3.d0 endif if (order==2) then bespp=0.d0 if (ll==0) bespp=-1.d0/3.d0 if (ll==2) bespp=2.d0/15.d0 endif return endif xxinv=1.d0/xx IF (xx<1.d0) THEN xx2=0.5d0*xx*xx fact=1.D0;DO il=1,ll;fact=fact*xx/dble(2*il+1);ENDDO jn=1.D0;jr=1.D0;ii=0 DO WHILE(abs(jr)>=prec.AND.iiprec) STOP 'Error: Bessel function did not converge !' IF (order>=1) THEN factp=fact*xx/dble(2*ll+3) jnp=1.D0;jr=1.D0;ii=0 DO WHILE(abs(jr)>=prec.AND.iiprec) STOP 'Error: 1st der. of Bessel function did not converge !' ENDIF IF (order==2) THEN factpp=factp*xx/dble(2*ll+5) jnpp=1.D0;jr=1.D0;ii=0 DO WHILE(abs(jr)>=prec.AND.iiprec) STOP 'Error: 2nd der. of Bessel function did not converge !' ENDIF ELSE jn =sin(xx)*xxinv jnp=(-cos(xx)+jn)*xxinv DO il=2,ll+1 jr=-jn+dble(2*il-1)*jnp*xxinv jn=jnp;jnp=jr ENDDO bes=jn IF (order>=1) besp =-jnp+jn *xxinv*dble(ll) IF (order==2) besp1= jn -jnp*xxinv*dble(ll+2) ENDIF IF (order==2) bespp=-besp1+besp*ll*xxinv-bes*ll*xxinv*xxinv END SUBROUTINE jbessel !****************************************************************** ! subroutine solvbes(root,alpha,l,nq) ! Find nq first roots of instrinsic equation: ! alpha.jl(Q) + beta.Q.djl/dr(Q) = 0 !****************************************************************** SUBROUTINE solvbes(root,alpha,beta,ll,nq) INTEGER,INTENT(IN) :: ll,nq REAL(8),INTENT(IN) :: alpha,beta REAL(8),INTENT(OUT) :: root(nq) REAL(8),PARAMETER :: dh=1.D-1, tol=1.D-12 INTEGER :: nroot REAL(8) :: dum,y1,y2,jbes,jbesp,qq,qx,hh qq=dh;nroot=0 do while (nroot=0.D0) qq=qq+dh call jbessel(jbes,jbesp,dum,ll,1,qq) y2=alpha*jbes+beta*qq*jbesp enddo hh=dh;qx=qq do while (hh>tol) hh=0.5D0*hh if (y1*y2<0) then qx=qx-hh else qx=qx+hh endif call jbessel(jbes,jbesp,dum,ll,1,qx) y2=alpha*jbes+beta*qx*jbesp enddo nroot=nroot+1 root(nroot)=qx enddo END SUBROUTINE solvbes !****************************************************************** ! subroutine shapebes(al,ql,ll,rc) ! Find al and ql parameters for a "Bessel" shape function: ! Shape(r)=al1.jl(ql1.r)+al2.jl(ql2.r) ! such as Shape(r) and 2 derivatives are zero at r=rc ! Intg_0_rc[Shape(r).r^(l+2).dr]=1 !****************************************************************** SUBROUTINE shapebes(al,ql,ll,rc) INTEGER,INTENT(IN) :: ll REAL(8),INTENT(IN) :: rc REAL(8),INTENT(OUT) :: al(2),ql(2) INTEGER :: i REAL(8) :: alpha,beta,det,qr,jbes,jbesp,jbespp,amat(2,2),bb(2) alpha=1.D0;beta=0.D0 call solvbes(ql,alpha,beta,ll,2) ql(1:2)=ql(1:2)/rc do i=1,2 qr=ql(i)*rc call jbessel(jbes,jbesp,jbespp,ll,1,qr) amat(1,i)=jbesp*ql(i) call jbessel(jbes,jbesp,jbespp,ll+1,0,qr) amat(2,i)=jbes*rc**(ll+2)/ql(i) ! Intg_0_rc[jl(qr).r^(l+2).dr] enddo bb(1)=0.d0;bb(2)=1.d0 det=amat(1,1)*amat(2,2)-amat(1,2)*amat(2,1) al(1)=(amat(2,2)*bb(1)-amat(1,2)*bb(2))/det al(2)=(amat(1,1)*bb(2)-amat(2,1)*bb(1))/det END SUBROUTINE shapebes !****************************************************************** SUBROUTINE CALERF(ARG,RESULT,JINT) ! ------------------------------------------------------------------ ! ! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) ! for a real argument x. It contains three FUNCTION type ! subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX), ! and one SUBROUTINE type subprogram, CALERF. The calling ! statements for the primary entries are: ! ! Y=ERF(X) (or Y=DERF(X)), ! ! Y=ERFC(X) (or Y=DERFC(X)), ! and ! Y=ERFCX(X) (or Y=DERFCX(X)). ! ! The routine CALERF is intended for internal packet use only, ! all computations within the packet being concentrated in this ! routine. The function subprograms invoke CALERF with the ! statement ! ! CALL CALERF(ARG,RESULT,JINT) ! ! where the parameter usage is as follows ! ! Function Parameters for CALERF ! call ARG Result JINT ! ! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0 ! ERFC(ARG) ABS(ARG) .LT. XBIG ERFC(ARG) 1 ! ERFCX(ARG) XNEG .LT. ARG .LT. XMAX ERFCX(ARG) 2 ! ! The main computation evaluates near-minimax approximations ! from "Rational Chebyshev approximations for the error function" ! by W. J. Cody, Math. Comp., 1969, PP. 631-638. This ! transportable program uses rational functions that theoretically ! approximate erf(x) and erfc(x) to at least 18 significant ! decimal digits. The accuracy achieved depends on the arithmetic ! system, the compiler, the intrinsic functions, and proper ! selection of the machine-dependent constants. ! !******************************************************************* !******************************************************************* ! ! Explanation of machine-dependent constants ! ! XMIN = the smallest positive floating-point number. ! XINF = the largest positive finite floating-point number. ! XNEG = the largest negative argument acceptable to ERFCX; ! the negative of the solution to the equation ! 2*exp(x*x) = XINF. ! XSMALL = argument below which erf(x) may be represented by ! 2*x/sqrt(pi) and above which x*x will not underflow. ! A conservative value is the largest machine number X ! such that 1.0 + X = 1.0 to machine precision. ! XBIG = largest argument acceptable to ERFC; solution to ! the equation: W(x) * (1-0.5/x**2) = XMIN, where ! W(x) = exp(-x*x)/[x*sqrt(pi)]. ! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to ! machine precision. A conservative value is ! 1/[2*sqrt(XSMALL)] ! XMAX = largest acceptable argument to ERFCX; the minimum ! of XINF and 1/[sqrt(pi)*XMIN]. ! ! Approximate values for some important machines are: ! ! XMIN XINF XNEG XSMALL ! ! CDC 7600 (S.P.) 3.13E-294 1.26E+322 -27.220 7.11E-15 ! CRAY-1 (S.P.) 4.58E-2467 5.45E+2465 -75.345 7.11E-15 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 1.18E-38 3.40E+38 -9.382 5.96E-8 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2.23D-308 1.79D+308 -26.628 1.11D-16 ! IBM 195 (D.P.) 5.40D-79 7.23E+75 -13.190 1.39D-17 ! UNIVAC 1108 (D.P.) 2.78D-309 8.98D+307 -26.615 1.73D-18 ! VAX D-Format (D.P.) 2.94D-39 1.70D+38 -9.345 1.39D-17 ! VAX G-Format (D.P.) 5.56D-309 8.98D+307 -26.615 1.11D-16 ! ! ! XBIG XHUGE XMAX ! ! CDC 7600 (S.P.) 25.922 8.39E+6 1.80X+293 ! CRAY-1 (S.P.) 75.326 8.39E+6 5.45E+2465 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 9.194 2.90E+3 4.79E+37 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 26.543 6.71D+7 2.53D+307 ! IBM 195 (D.P.) 13.306 1.90D+8 7.23E+75 ! UNIVAC 1108 (D.P.) 26.582 5.37D+8 8.98D+307 ! VAX D-Format (D.P.) 9.269 1.90D+8 1.70D+38 ! VAX G-Format (D.P.) 26.569 6.71D+7 8.98D+307 ! !******************************************************************* !******************************************************************* ! ! Error returns ! ! The program returns ERFC = 0 for ARG .GE. XBIG; ! ! ERFCX = XINF for ARG .LT. XNEG; ! and ! ERFCX = 0 for ARG .GE. XMAX. ! ! ! Intrinsic functions required are: ! ! ABS, AINT, EXP ! ! ! Author: W. J. Cody ! Mathematics and Computer Science Division ! Argonne National Laboratory ! Argonne, IL 60439 ! ! Latest modification: March 19, 1990 ! !------------------------------------------------------------------ implicit none INTEGER I,JINT !S REAL DOUBLE PRECISION :: & A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEN,SQRPI, & TWO,THRESH,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL,& Y,YSQ,ZERO DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5) Logical :: goto300 !------------------------------------------------------------------ ! Mathematical constants !------------------------------------------------------------------ !S DATA FOUR,ONE,HALF,TWO,ZERO/4.0E0,1.0E0,0.5E0,2.0E0,0.0E0/, !S 1 SQRPI/5.6418958354775628695E-1/,THRESH/0.46875E0/, !S 2 SIXTEN/16.0E0/ DATA FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, & SQRPI/5.6418958354775628695D-1/,THRESH/0.46875D0/, & SIXTEN/16.0D0/ !------------------------------------------------------------------ ! Machine-dependent constants !------------------------------------------------------------------ !S DATA XINF,XNEG,XSMALL/3.40E+38,-9.382E0,5.96E-8/, !S 1 XBIG,XHUGE,XMAX/9.194E0,2.90E3,4.79E37/ DATA XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, & XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/ !------------------------------------------------------------------ ! Coefficients for approximation to erf in first interval !------------------------------------------------------------------ !S DATA A/3.16112374387056560E00,1.13864154151050156E02, !S 1 3.77485237685302021E02,3.20937758913846947E03, !S 2 1.85777706184603153E-1/ !S DATA B/2.36012909523441209E01,2.44024637934444173E02, !S 1 1.28261652607737228E03,2.84423683343917062E03/ DATA A/3.16112374387056560D00,1.13864154151050156D02, & 3.77485237685302021D02,3.20937758913846947D03, & 1.85777706184603153D-1/ DATA B/2.36012909523441209D01,2.44024637934444173D02, & 1.28261652607737228D03,2.84423683343917062D03/ !------------------------------------------------------------------ ! Coefficients for approximation to erfc in second interval !------------------------------------------------------------------ !S DATA C/5.64188496988670089E-1,8.88314979438837594E0, !S 1 6.61191906371416295E01,2.98635138197400131E02, !S 2 8.81952221241769090E02,1.71204761263407058E03, !S 3 2.05107837782607147E03,1.23033935479799725E03, !S 4 2.15311535474403846E-8/ !S DATA D/1.57449261107098347E01,1.17693950891312499E02, !S 1 5.37181101862009858E02,1.62138957456669019E03, !S 2 3.29079923573345963E03,4.36261909014324716E03, !S 3 3.43936767414372164E03,1.23033935480374942E03/ DATA C/5.64188496988670089D-1,8.88314979438837594D0, & 6.61191906371416295D01,2.98635138197400131D02, & 8.81952221241769090D02,1.71204761263407058D03, & 2.05107837782607147D03,1.23033935479799725D03, & 2.15311535474403846D-8/ DATA D/1.57449261107098347D01,1.17693950891312499D02, & 5.37181101862009858D02,1.62138957456669019D03, & 3.29079923573345963D03,4.36261909014324716D03, & 3.43936767414372164D03,1.23033935480374942D03/ !------------------------------------------------------------------ ! Coefficients for approximation to erfc in third interval !------------------------------------------------------------------ !S DATA P/3.05326634961232344E-1,3.60344899949804439E-1, !S 1 1.25781726111229246E-1,1.60837851487422766E-2, !S 2 6.58749161529837803E-4,1.63153871373020978E-2/ !S DATA Q/2.56852019228982242E00,1.87295284992346047E00, !S 1 5.27905102951428412E-1,6.05183413124413191E-2, !S 2 2.33520497626869185E-3/ DATA P/3.05326634961232344D-1,3.60344899949804439D-1, & 1.25781726111229246D-1,1.60837851487422766D-2, & 6.58749161529837803D-4,1.63153871373020978D-2/ DATA Q/2.56852019228982242D00,1.87295284992346047D00, & 5.27905102951428412D-1,6.05183413124413191D-2, & 2.33520497626869185D-3/ !------------------------------------------------------------------ Goto300 = .FALSE. X = ARG Y = ABS(X) IF (Y .LE. THRESH) THEN !------------------------------------------------------------------ ! Evaluate erf for |X| <= 0.46875 !------------------------------------------------------------------ YSQ = ZERO IF (Y .GT. XSMALL) YSQ = Y * Y XNUM = A(5)*YSQ XDEN = YSQ DO I = 1, 3 XNUM = (XNUM + A(I)) * YSQ XDEN = (XDEN + B(I)) * YSQ End Do RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) IF (JINT .NE. 0) RESULT = ONE - RESULT IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT RETURN !*** goto 800 !------------------------------------------------------------------ ! Evaluate erfc for 0.46875 <= |X| <= 4.0 !------------------------------------------------------------------ ELSE IF (Y .LE. FOUR) THEN XNUM = C(9)*Y XDEN = Y DO I = 1, 7 XNUM = (XNUM + C(I)) * Y XDEN = (XDEN + D(I)) * Y End DO RESULT = (XNUM + C(8)) / (XDEN + D(8)) IF (JINT .NE. 2) THEN YSQ = AINT(Y*SIXTEN)/SIXTEN DEL = (Y-YSQ)*(Y+YSQ) RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT END IF !------------------------------------------------------------------ ! Evaluate erfc for |X| > 4.0 !------------------------------------------------------------------ ELSE Goto300 = .FALSE. RESULT = ZERO IF (Y .GE. XBIG) THEN IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GOTO300 = .TRUE. IF ((Y .GE. XHUGE) .AND. (.NOT. Goto300)) THEN RESULT = SQRPI / Y GOTO300 = .TRUE. END IF END IF If (.NOT. Goto300) then YSQ = ONE / (Y * Y) XNUM = P(6)*YSQ XDEN = YSQ DO I = 1, 4 XNUM = (XNUM + P(I)) * YSQ XDEN = (XDEN + Q(I)) * YSQ End Do RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5)) RESULT = (SQRPI - RESULT) / Y IF (JINT .NE. 2) THEN YSQ = AINT(Y*SIXTEN)/SIXTEN DEL = (Y-YSQ)*(Y+YSQ) RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT END IF End If END IF !------------------------------------------------------------------ ! Fix up for negative argument, erf, etc. !------------------------------------------------------------------ IF (JINT .EQ. 0) THEN !*** Goto300 *** RESULT = (HALF - RESULT) + HALF IF (X .LT. ZERO) RESULT = -RESULT ELSE IF (JINT .EQ. 1) THEN IF (X .LT. ZERO) RESULT = TWO - RESULT ELSE IF (X .LT. ZERO) THEN IF (X .LT. XNEG) THEN RESULT = XINF ELSE YSQ = AINT(X*SIXTEN)/SIXTEN DEL = (X-YSQ)*(X+YSQ) Y = EXP(YSQ*YSQ) * EXP(DEL) RESULT = (Y+Y) - RESULT END IF END IF END IF RETURN !*** 800 !---------- Last card of CALERF ---------- END Subroutine !S REAL FUNCTION ERF(X) DOUBLE PRECISION FUNCTION DERF(X) !-------------------------------------------------------------------- ! ! This subprogram computes approximate values for erf(x). ! (see comments heading CALERF). ! ! Author/date: W. J. Cody, January 8, 1985 ! !-------------------------------------------------------------------- INTEGER JINT !S REAL X, RESULT DOUBLE PRECISION :: X, RESULT !------------------------------------------------------------------ JINT = 0 CALL CALERF(X,RESULT,JINT) !S ERF = RESULT DERF = RESULT RETURN !---------- Last card of DERF ---------- END Function !S REAL FUNCTION ERFC(X) DOUBLE PRECISION FUNCTION DERFC(X) !-------------------------------------------------------------------- ! ! This subprogram computes approximate values for erfc(x). ! (see comments heading CALERF). ! ! Author/date: W. J. Cody, January 8, 1985 ! !-------------------------------------------------------------------- INTEGER JINT !S REAL X, RESULT DOUBLE PRECISION :: X, RESULT !------------------------------------------------------------------ JINT = 1 CALL CALERF(X,RESULT,JINT) !S ERFC = RESULT DERFC = RESULT RETURN !---------- Last card of DERFC ---------- END Function !S REAL FUNCTION ERFCX(X) DOUBLE PRECISION FUNCTION DERFCX(X) !------------------------------------------------------------------ ! ! This subprogram computes approximate values for exp(x*x) * erfc(x). ! (see comments heading CALERF). ! ! Author/date: W. J. Cody, March 30, 1987 ! !------------------------------------------------------------------ INTEGER JINT !S REAL X, RESULT DOUBLE PRECISION :: X, RESULT !------------------------------------------------------------------ JINT = 2 CALL CALERF(X,RESULT,JINT) !S ERFCX = RESULT DERFCX = RESULT RETURN !---------- Last card of DERFCX ---------- END Function END MODULE GlobalMath ./src/graphatom.f900000644004704100470410000001533211202701404014121 0ustar natalienataliePROGRAM graphatom !************************************************************* ! program to calculate the self-consistent density functional ! atom ground state for atom with atomic number nz !************************************************************ USE GlobalMath USE atomdata USE aeatom USE gridmod IMPLICIT NONE INTEGER, PARAMETER :: ifen=9, ifden=7,ifwfn=8 CHARACTER (len=4) :: flnm CHARACTER (len=20) :: nm CHARACTER (len=2) :: sym CHARACTER (len=1) :: syml REAL(8), POINTER :: r(:),den(:),rv(:),wfn(:,:) INTEGER, POINTER :: n,norbit,nps,npp,npd,npf,npg INTEGER :: i,j,io,many,l,istart TYPE (GridInfo), TARGET :: AEGrid TYPE (PotentialInfo), TARGET :: AEPot TYPE (OrbitInfo), TARGET :: AEOrbit TYPE (OrbitInfo), TARGET :: FCOrbit TYPE (SCFInfo), TARGET :: AESCF TYPE (FCInfo), TARGET :: FC CALL Init_GlobalConstants CALL iSCFatom(AEGrid,AEPot,AEOrbit,AESCF) OPEN (unit = ifen, file=TRIM(AEPot%sym)//'.GA', form='formatted') i=1 do WRITE(ifen,*) 'Completed calculations for ',TRIM(AEPOT%sym) call reportgrid(AEGrid,ifen) if (scalarrelativistic) then WRITE(ifen,*) 'Scalar relativistic calculation' else WRITE(ifen,*) 'Non-relativistic calculation' endif if (i==1)WRITE(ifen,*) ' aeatom converged in',AESCF%iter,' iterations' if (i==2)WRITE(ifen,*) ' FCatom converged in',AESCF%iter,' iterations' WRITE(ifen,*) ' for nz = ',AEPot%nz WRITE(ifen,*) ' delta(density) = ', AESCF%delta WRITE(ifen,*) ' Orbital energies: ' WRITE(ifen,*) ' n l occupancy energy' If (i==1) then DO io=1,AEorbit%norbit WRITE(ifen,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) ENDDO Else if (i==2) then DO io=1,FC%norbit IF (.NOT.FC%iscore(io))WRITE(ifen,'(i2,1x,i2,4x,1p2e15.7)') & AEOrbit%np(io),AEOrbit%l(io),& AEOrbit%occ(io),AEOrbit%eig(io) ENDDO Endif WRITE(ifen,*) WRITE(ifen,*) ' Total energy' WRITE(ifen,*) ' Total : ',AESCF%etot If (i==2) then WRITE(ifen,*) ' Valence : ',FC%evale EndIf write(6,*) ' Input 0 for plotting results and completing program' write(6,*) ' Input 1 for changing configuration (all-electron)' write(6,*) ' Input 2 for changing configuration (frozen-core)' read(5,*) i if (i == 0) exit if (i == 1) CALL cSCFatom(AEGrid,AEPot,AEOrbit,AESCF) if (i == 2) CALL FCSCFatom(AEGrid,AEPot,AEOrbit,FCOrbit,AESCF,FC) enddo n=>AEGrid%n r=>AEGrid%r den=>AEPot%den rv=>AEPot%rv norbit=>AEOrbit%norbit nps=>AEOrbit%nps npp=>AEOrbit%npp npd=>AEOrbit%npd npf=>AEOrbit%npf npg=>AEOrbit%npg wfn=>AEOrbit%wfn ! ! write density and wavefunctions ! CLOSE(ifen) OPEN (unit = ifden, file = 'density.GA', form = 'formatted') DO i = 1, n IF (r (i) .LE.6.d0) THEN WRITE (ifden, '(1p6e12.4)') r (i), den (i) ENDIF ENDDO CLOSE (ifden) OPEN (unit = ifden, file = 'potential.GA', form = 'formatted') DO i = 1, n IF (r (i) .LE.6.d0) THEN WRITE (ifden, '(1p6e12.4)') r (i), rv (i) ENDIF ENDDO CLOSE (ifden) OPEN (unit = ifden, file = 'plotdensity.GA', form = 'formatted') nm = 'density.GA' WRITE (ifden, '("gplot -t ""Radial density for ",a2, & &""" -tx ""r (bohr)"" -f ",a10, " 1 2 lines")') AEpot%sym, nm CLOSE (ifden) OPEN (unit = ifden, file = 'plotpotential.GA', form = 'formatted') nm = 'potential.GA' WRITE (ifden, '("gplot -t ""rxV(r) for ",a2, & &""" -tx ""r (bohr)"" -f ",a12, " 1 2 lines")') AEpot%sym, nm CLOSE (ifden) DO i = 1, n DO io = 1, norbit IF (dabs (wfn (i, io) ) .LT.1.d-8) wfn (i, io) = 0.d0 ENDDO ENDDO istart = 0 DO l = 0, 4 IF (l.EQ.0) many = nps IF (l.EQ.1) many = npp - 1 IF (l.EQ.2) many = npd-2 IF (l.EQ.3) many = npf - 3 IF (l.EQ.4) many = npg - 4 IF (l.EQ.0) syml = 's' IF (l.EQ.1) syml = 'p' IF (l.EQ.2) syml = 'd' IF (l.EQ.3) syml = 'f' IF (l.EQ.4) syml = 'g' IF (many.GT.0) THEN CALL mkname (l, flnm) OPEN (unit = ifwfn, file = 'GAwfn'//flnm, form = 'formatted') DO i = 1, n IF (r (i) .LE.6.d0) THEN WRITE (ifwfn, '(1p8e10.2)') r (i) , (wfn (i, j) , j = & istart + 1, istart + many) ENDIF ENDDO CLOSE (ifwfn) nm = 'GAwfn'//flnm OPEN (unit = ifwfn, file = 'plotGAwfn'//flnm, form = 'formatted') IF (many.EQ.1) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines")') syml, AEpot%sym, nm IF (many.EQ.2) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines -f ",a8," 1 3 lines")') syml & , AEpot%sym, nm, nm IF (many.EQ.3) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines -f ",a8," 1 3 lines -f ", & &a8," 1 4 lines")') syml, AEpot%sym, nm, nm, nm IF (many.EQ.4) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines -f ",a8," 1 3 lines -f ", & &a8," 1 4 lines -f ",a8," 1 5 lines")') syml, AEpot%sym, nm, nm, nm, nm IF (many.EQ.5) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines -f ",a8," 1 3 lines -f ", & &a8," 1 4 lines -f ",a8," 1 5 lines -f ",a8," 1 6 lines")') syml, & &AEpot%sym, nm, nm, nm, nm, nm IF (many.EQ.6) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines -f ",a8," 1 3 lines -f ", & &a8," 1 4 lines -f ",a8," 1 5 lines -f ",a8," 1 6 lines -f " & &,a8," 1 7 lines")') syml, AEpot%sym, nm, nm, nm, nm, nm, nm IF (many.EQ.7) WRITE (ifwfn, '("gplot -t ""Radial ",a1, & & " wavefunctions for ",a2, & &""" -tx ""r (bohr)"" -f ",a8, " 1 2 lines -f ",a8," 1 3 lines -f ", & &a8," 1 4 lines -f ",a8," 1 5 lines -f ",a8," 1 6 lines -f " & &,a8," 1 7 lines -f ",a8," 1 8 lines" )') syml, AEpot%sym, nm, nm, nm, nm & &, nm, nm, nm CLOSE (ifwfn) ENDIF istart = istart + many ENDDO END PROGRAM graphatom ./src/gridmod.f900000644004704100470410000011266311202701404013571 0ustar natalienatalieMODULE gridmod Use globalmath IMPLICIT NONE INTEGER, PARAMETER, PRIVATE :: lineargrid=1 ! r(i)=h*(i-1) INTEGER, PARAMETER, PRIVATE :: loggrid=2 ! r(i)=r0*(exp(h*(i-1))-1) TYPE GridInfo INTEGER :: TYPE INTEGER :: n REAL(8) :: h REAL(8), POINTER :: r(:) REAL(8), POINTER :: drdu(:) ! for loggrid -- dr/du REAL(8), POINTER :: pref(:) ! for loggrid -- r0*exp(u/2) REAL(8), POINTER :: rr02(:) ! for loggrid -- (r+r0)**2 END TYPE GridInfo CONTAINS !********************************************************************** ! function usingloggrid(Grid) !********************************************************************** FUNCTION usingloggrid(Grid) logical :: usingloggrid Type(GridInfo), INTENT(IN) :: Grid usingloggrid=.false. if (Grid%type==loggrid) usingloggrid=.true. END FUNCTION !********************************************************************** FUNCTION overint(n,h,f1,icorr) ! function to calculate the integral of one vectors f1 ! using simpsons rule assuming a regular grid with ! spacing of h and n total points ! ! icorr: optional parameter: used only when n is even ! if icorr<0, a trapezoidal correction is applied ! at the start of interval ! if icorr>=0, a trapezoidal correction is applied ! at the end of interval ! default (if missing) is icorr=0 REAL(8) :: overint INTEGER, INTENT(IN) :: n REAL(8), INTENT(IN) :: h,f1(:) INTEGER, OPTIONAL :: icorr REAL(8),PARAMETER :: tol=1.D-14 INTEGER :: i,j,istart,m overint=0 !Eliminate zeros at end of interval i=n;do while(abs(f1(i))2);i=i-1;enddo m=min(i+1,n) IF (m<=1) THEN RETURN ELSEIF (m==2) THEN overint=(f1(1)+f1(2))*(h/2) ! Trapezoidal rule RETURN ENDIF istart=1 if (present(icorr)) then if (icorr<0.and.mod(m,2)==0) istart=2 endif overint=f1(istart)+4*f1(istart+1)+f1(istart+2) j=((m-istart)/2)*2+istart IF (j>=istart+4) THEN DO i=istart+4,j,2 overint=overint+f1(i-2)+4*f1(i-1)+f1(i) ENDDO ENDIF overint=overint*(h/3) IF (m>j) overint=overint+(f1(j)+f1(m))*(h/2) IF (istart==2) overint=overint+(f1(1)+f1(2))*(h/2) RETURN END FUNCTION overint !******************************************************************* ! function integrator(Grid,arg) !******************************************************************* FUNCTION integrator(Grid,arg,str,fin) REAL(8) :: integrator TYPE(GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: arg(:) INTEGER, INTENT(IN), OPTIONAL :: str,fin REAL(8), ALLOCATABLE :: dum(:) INTEGER :: i,n,i1,i2 n=Grid%n i1=1;i2=n IF (PRESENT(str).AND.PRESENT(fin)) THEN i1=str; i2=fin; n=i2-i1+1 ENDIF SELECT CASE(Grid%type) CASE default WRITE(6,*) 'Error in integrator -- grid ', Grid%type STOP CASE(lineargrid) integrator=overint(n,Grid%h,arg(i1:i2)) CASE(loggrid) ALLOCATE(dum(i1:i2),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in integrator -- allocation ', Grid%n,i STOP ENDIF dum(i1:i2)=arg(i1:i2)*Grid%drdu(i1:i2) integrator=overint(n,Grid%h,dum(i1:i2),-1) DEALLOCATE(dum) END SELECT END FUNCTION integrator !***************************************************************** FUNCTION overlap(Grid,f1,f2,str,fin) ! function to calculate the overlap between two vectors f1 and f2 REAL(8) :: overlap TYPE(GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: f1(:),f2(:) INTEGER, INTENT(IN), OPTIONAL :: str,fin REAL(8), ALLOCATABLE :: dum(:) INTEGER :: i,n,i1,i2 n=Grid%n i1=1;i2=n IF (PRESENT(str).AND.PRESENT(fin)) THEN i1=str; i2=fin; n=i2-i1+1 ENDIF ALLOCATE(dum(i1:i2),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in overlap allocation ', n,i STOP ENDIF dum(1:n)=f1(i1:i2)*f2(i1:i2) overlap=integrator(Grid,dum(1:n),1,n) DEALLOCATE(dum) END FUNCTION overlap !***************************************************** SUBROUTINE nderiv(h,y,z,ndim,ierr) INTEGER, INTENT(IN) :: ndim INTEGER, INTENT(INOUT) :: ierr REAL(8) , INTENT(IN) :: h,y(:) REAL(8) , INTENT(INOUT) :: z(:) ! subroutine ddet5(h,y,z,ndim) ! ssp routine modified by nawh 6/8/76 REAL(8) :: hh,yy,a,b,c INTEGER :: i ierr=-1 IF (ndim.LT.5) RETURN ! prepare differentiation loop hh=.08333333333333333d0/h yy=y(ndim-4) b=hh*(-25.d0*y(1)+48.d0*y(2)-36.d0*y(3)+16.d0*y(4)-3.d0*y(5)) c=hh*(-3.d0*y(1)-10.d0*y(2)+18.d0*y(3)-6.d0*y(4)+y(5)) ! ! start differentiation loop DO i=5,ndim a=b b=c c=hh*(y(i-4)-y(i)+8.d0*(y(i-1)-y(i-3))) z(i-4)=a ENDDO ! end of differentiation loop ! ! normal exit a=hh*(-yy+6.d0*y(ndim-3)-18.d0*y(ndim-2)+10.d0*y(ndim-1) & +3.d0*y(ndim)) z(ndim)=hh*(3.d0*yy-16.d0*y(ndim-3)+36.d0*y(ndim-2) & -48.d0*y(ndim-1)+25.d0*y(ndim)) z(ndim-1)=a z(ndim-2)=c z(ndim-3)=b ! ierr=0 RETURN END SUBROUTINE nderiv !********************************************************************** ! subroutine derivative(Grid,f,dfdr) !********************************************************************* SUBROUTINE derivative(Grid,f,dfdr,begin,bend) TYPE(GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: f(:) REAL(8), INTENT(OUT) :: dfdr(:) INTEGER, OPTIONAL, INTENT(IN) :: begin,bend INTEGER :: i,n,i1,i2 i1=1;i2=Grid%n;n=i2-i1+1 IF (PRESENT(begin).OR.PRESENT(bend)) THEN IF (begin>=1.AND.bend<= Grid%n) THEN i1=begin;i2=bend;n=i2-i1+1 ELSE WRITE(6,*) 'Error in derivative', begin,bend,Grid%n STOP ENDIF ENDIF SELECT CASE(Grid%type) CASE default WRITE(6,*) 'Error in derivative -- grid ', Grid%type STOP CASE(lineargrid) CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i) IF (i/=0) THEN WRITE(6,*) 'Error in derivative -nderiv problem', i STOP ENDIF CASE(loggrid) CALL nderiv(Grid%h,f(i1:i2),dfdr(i1:i2),n,i) IF (i/=0) THEN WRITE(6,*) 'Error in derivative -nderiv problem', i STOP ENDIF dfdr(i1:i2)=dfdr(i1:i2)/Grid%drdu(i1:i2) END SELECT END SUBROUTINE derivative !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! simplederiv(Grid,f,dfdr,begin,bend) ! low order formula !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE simplederiv(Grid,f,dfdr,begin,bend) TYPE(GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: f(:) REAL(8), INTENT(OUT) :: dfdr(:) INTEGER, OPTIONAL, INTENT(IN) :: begin,bend INTEGER :: i,n,i1,i2 REAL(8) :: HH i1=1;i2=Grid%n;n=i2-i1+1 IF (PRESENT(begin).OR.PRESENT(bend)) THEN IF (begin>=1.AND.bend<= Grid%n) THEN i1=begin;i2=bend;n=i2-i1+1 if (n<3) then WRITE(6,*) 'Error in simplederiv -- n too small',n,i1,i2 stop endif ELSE WRITE(6,*) 'Error in simplederive', begin,bend,Grid%n STOP ENDIF ENDIF HH=0.5d0/Grid%h dfdr(i1)=HH*(-3*f(i1)+4*f(i1+1)-f(i1+2)) do i=i1,i2-2 dfdr(i+1)=HH*(f(i+2)-f(i)) enddo dfdr(i2)=HH*(3*f(i2)-4*f(i2-1)+f(i2-2)) if (Grid%type==loggrid) then dfdr(i1:i2)=dfdr(i1:i2)/Grid%drdu(i1:i2) endif end subroutine simplederiv SUBROUTINE laplacian(Grid,l,wfn,del,fin) TYPE(GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: l REAL(8), INTENT(IN) :: wfn(:) REAL(8), INTENT(INOUT) :: del(:) INTEGER, INTENT(IN),OPTIONAL :: fin INTEGER :: OK,i,lfac,n REAL(8), ALLOCATABLE :: dum1(:),dum2(:) n=Grid%n if (present(fin)) n=fin ALLOCATE(dum1(n),dum2(n),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Error in laplace allocation',n STOP ENDIF lfac=l*(l+1) del=0 DO i=2,n dum2(i)=wfn(i)/Grid%r(i) del(i)=-lfac*dum2(i) ENDDO call extrapolate(Grid,dum2) call derivative(Grid,dum2,dum1,1,n) del(:)=del(:)+2*Grid%r(:)*dum1(:) call derivative(Grid,dum1,dum2,1,n) del(:)=del(:)+(Grid%r(:)**2)*dum2(:) DEALLOCATE(dum1,dum2) END SUBROUTINE laplacian !****************************************************** ! SUBROUTINE poisson(Grid,q,den,rv,ecoul,v00) !***************************************************** SUBROUTINE poisson(Grid,q,den,rv,ecoul,v00) ! use Numerov algorithm to solve poisson equation ! den(n) is electron density * (4*pi*r**2) ! rv(n) is returned as electrostatic potential * r ! ecoul is the coulomb interaction energy TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN):: den(:) REAL(8), INTENT(INOUT) :: rv(:),ecoul,q REAL(8), optional, INTENT(OUT) :: v00 REAL(8), ALLOCATABLE :: a(:),b(:) REAL(8) :: sd,sl,h,h2 INTEGER :: i,n n=Grid%n h=Grid%h rv=0 q=integrator(Grid,den) ALLOCATE(a(n),b(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating arrays in poisson',i,n STOP ENDIF IF (Grid%type==lineargrid) THEN sd=2 sl=-1 a(1)=0 DO i=2,n a(i)=h*den(i)/(6*(i-1)) ENDDO rv(1)=0 rv(2)=10*a(2)+a(3) DO i=3,n-1 rv(i)=10*a(i)+a(i+1)+a(i-1) ENDDO rv(n)=10*a(n)+a(n-1)+2*q ELSEIF (Grid%type==loggrid) THEN sd=2+10*h*h/48 sl=-1+h*h/48 a(1)=0 h2=h*h DO i=2,n a(i)=h2*Grid%rr02(i)*den(i)/(6*Grid%r(i))/Grid%pref(i) ENDDO rv(1)=0 rv(2)=10*a(2)+a(3) DO i=3,n-1 rv(i)=10*a(i)+a(i+1)+a(i-1) ENDDO ! last term is boundary value at point n+1 rv(n)=10*a(n)+a(n-1)-2*q*sl/(Grid%pref(n)*EXP(h/2)) ENDIF CALL conthomas(n,sl,sd,rv) IF (Grid%type==loggrid) rv=rv*Grid%pref ! ! calculate ecoul ! DO i=2,n a(i)=den(i)*rv(i)/Grid%r(i) ENDDO a(1)=0 ecoul=0.5d0*integrator(Grid,a) WRITE(6,*) ' from poisson: ecoul = ',ecoul if (present(v00)) then a=0 a(2:n)=den(2:n)/Grid%r(2:n) v00=2*integrator(Grid,a) endif DEALLOCATE(a,b) ! END SUBROUTINE poisson !***************************************************************** !Alternative form of poisson solver written by Marc Torrent 6/9/06 ! works well for loggrid !****************************************************************** SUBROUTINE poisson_marc(Grid,q,den,rv,ecoul) ! use Numerov algorithm to solve poisson equation ! den(n) is electron density * (4*pi*r**2) ! rv(n) is returned as electrostatic potential * r ! ecoul is the coulomb interation energy TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN):: den(:) REAL(8), INTENT(INOUT) :: rv(:),ecoul,q REAL(8), ALLOCATABLE :: aa(:),bb(:),cc(:),dd(:) REAL(8) :: sd,sl,h,h2 INTEGER :: i,n,ir,jr n=Grid%n h=Grid%h rv=0 q=integrator(Grid,den) IF (Grid%type==loggrid) THEN ALLOCATE(aa(n),bb(n),cc(n),dd(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating arrays in poisson',i,n STOP ENDIF do jr=n,2,-1 ir=n-jr+1 aa(ir)=den(jr)*Grid%drdu(jr) bb(ir)=den(jr)*Grid%drdu(jr)/Grid%r(jr) end do aa(n)=aa(n-3)+3.d0*(aa(n-1)-aa(n-2)) bb(n)=bb(n-3)+3.d0*(bb(n-1)-bb(n-2)) cc(1)=0.d0;dd(1)=0.d0 do ir=3,n,2 cc(ir) =cc(ir-2)+h/3.d0*(aa(ir-2)+4.d0*aa(ir-1)+aa(ir)) cc(ir-1)=cc(ir-2)+h/3.d0*(1.25d0*aa(ir-2)+2.0d0*aa(ir-1)-0.25d0*aa(ir)) dd(ir) =dd(ir-2)+h/3.d0*(bb(ir-2)+4.d0*bb(ir-1)+bb(ir)) dd(ir-1)=dd(ir-2)+h/3.d0*(1.25d0*bb(ir-2)+2.d0*bb(ir-1)-0.25d0*bb(ir)) end do if (mod(n,2)==0) then cc(n)=cc(n-2)+h/3.d0*(aa(n-2)+4.d0*aa(n-1)+aa(n)) dd(n)=dd(n-2)+h/3.d0*(bb(n-2)+4.d0*bb(n-1)+bb(n)) end if rv(1)=0.d0 do ir=2,n jr=n-ir+1 rv(ir)=2.d0*(dd(jr)*Grid%r(ir)+(cc(n)-cc(jr))) end do ! ! calculate ecoul ! DO i=2,n aa(i)=den(i)*rv(i)/Grid%r(i) ENDDO aa(1)=0 ecoul=0.5d0*integrator(Grid,aa) WRITE(6,*) 'ecoul = ',ecoul deallocate(aa,bb,cc,dd) ELSE write(6,*) 'Error in subroutine poisson.marc -- must be loggrid' stop endif end subroutine poisson_marc !******************************************************************** ! use Numerov algorithm to solve poisson equation ! for angularly dependent charge distribution of angular momentum l ! den(n) is electron density * (4*pi*r**2) appropriate for l ! rv(n) is returned as electrostatic potential * r ! a(n), b(n), and c(n) are work arrays !******************************************************************** SUBROUTINE apoisson(Grid,l,irc,den,rv) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: l,irc REAL(8), INTENT(IN) :: den(:) REAL(8), INTENT(OUT) :: rv(:) INTEGER :: i,j REAL(8) :: angm,r,q,h,h2 REAL(8), ALLOCATABLE :: a(:),b(:),c(:) ALLOCATE(a(irc),b(irc),c(irc),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in allocating arrays in apoisson ',i,irc STOP ENDIF b=den(1:irc)*(Grid%r(1:irc))**L q=integrator(Grid,b,1,irc)/(2*l+1) h=Grid%h WRITE(6,*) 'check l multipole',l,q IF (Grid%type==lineargrid) THEN a=0;b=0; c=0; rv=0 DO i=2,irc a(i)=0.2d0*h*den(i)/((i-1)) ENDDO DO i=2,irc-1 rv(i)=10*a(i)+a(i+1)+a(i-1) ENDDO ! set up Tridiagonal equations a=0; angm=l*(l+1) DO i=2,irc-1 if (i>2) a(i)=-1.2d0+0.1d0*angm/((i-2)**2) c(i)=-1.2d0+0.1d0*angm/((i)**2) b(i)=2.4d0+angm/((i-1)**2) ENDDO a(2)=0 IF (l==1) b(2)=b(2)+0.2d0 rv(irc)=2*q/(Grid%r(irc)**l) rv(irc-1)=rv(irc-1)-c(irc-1)*rv(irc) c(irc-1)=0;rv(1)=0 CALL thomas(irc-2,a(2:irc-1),b(2:irc-1),c(2:irc-1),rv(2:irc-1)) ELSEIF (Grid%type==loggrid) THEN a=0;b=0; c=0; rv=0; h2=h*h DO i=2,irc a(i)=0.2d0*h2*Grid%rr02(i)*den(i)/(Grid%pref(i)*Grid%r(i)) ENDDO DO i=2,irc-1 rv(i)=10*a(i)+a(i+1)+a(i-1) ENDDO ! set up Tridiagonal equations a=0; angm=l*(l+1) DO i=2,irc-1 if (i>2) a(i)=-1.2d0+& 0.1d0*h2*(0.25d0+angm*Grid%rr02(i-1)/Grid%r(i-1)**2) c(i)=-1.2d0+0.1d0*h2*(0.25d0+angm*Grid%rr02(i+1)/Grid%r(i+1)**2) b(i)=2.4d0+h2*(0.25d0+angm*Grid%rr02(i)/Grid%r(i)**2) ENDDO a(2)=0 IF (l==1) b(2)=b(2)+0.2d0*Grid%rr02(1)/(Grid%r(2)**2) rv(irc)=2*q/(Grid%r(irc)**l)/Grid%pref(irc) rv(irc-1)=rv(irc-1)-c(irc-1)*rv(irc) c(irc-1)=0;rv(1)=0 CALL thomas(irc-2,a(2:irc-1),b(2:irc-1),c(2:irc-1),rv(2:irc-1)) rv(1:irc)=Grid%pref(1:irc)*rv(1:irc) ENDIF ! DEALLOCATE(a,b,c) END SUBROUTINE apoisson !****************************************************************** ! pgm to determine r=0 form of potential assuming that ! nuclear contribution (-2*nz) is not yet included !****************************************************************** SUBROUTINE zeropot(Grid,rv,v0,v0p) ! extrapolate potential to value at r=0 TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(INOUT) :: rv(:) ! Note: rv(1) corresponds to r=0 REAL(8), INTENT(OUT) :: v0,v0p REAL(8) :: tmp(15),tmp1(15) INTEGER :: i,n tmp(2:15)=rv(2:15)/Grid%r(2:15) call extrapolate(Grid,tmp(1:15)) v0=tmp(1) CALL derivative(Grid,tmp(1:15),tmp1(1:15),2,15) call extrapolate(Grid,tmp1(1:15)) v0p=tmp1(1) END SUBROUTINE zeropot SUBROUTINE extrapolate(Grid,v) ! extrapolate array v to r=0 at v(1) TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(INOUT) :: v(:) ! assume v(2),v(3)... given v(1)=v(4)+3*(v(2)-v(3)) END SUBROUTINE extrapolate !************************************************************* ! subroutine forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes) !************************************************************* SUBROUTINE forward_numerov(Grid,l,many,energy,rv,zeroval,wfn,nodes) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: l,many REAL(8), INTENT(IN) :: energy,zeroval,rv(:) ! zeroval == lim r-->0 A(r)*P(r) REAL(8), INTENT(INOUT) :: wfn(:) ! on input wfn(1) and wfn(2) given ! on ouput wfn(i) given for ! i<=many INTEGER, INTENT(OUT) :: nodes REAL(8), ALLOCATABLE :: a(:),b(:),p(:) REAL(8) :: xx,angm,h,h2,scale REAL(8), PARAMETER :: vlarg=1.d30 INTEGER :: i,j,k,n ALLOCATE(a(many),b(many),p(many),stat=i) IF (i/=0) THEN WRITE(6,*) 'Allocation error forward_numerov ', many,i STOP ENDIF p(1)=wfn(1) p(2)=wfn(2) xx=zeroval angm=l*(l+1) a=0 h=Grid%h; h2=h*h DO i=2,many a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2) ENDDO IF (Grid%type==loggrid) THEN p(1:2)=Grid%pref(1:2)*wfn(1:2) xx=Grid%pref(1)*Grid%rr02(1)*xx a=0.25d0+Grid%rr02(1:many)*a ENDIF b=2.4d0+h2*a a=1.2d0-0.1d0*h2*a p(3)=(b(2)*p(2)+0.1d0*h2*xx)/a(3) nodes=0 DO i=4,many p(i)=(b(i-1)*p(i-1)-a(i-2)*p(i-2))/a(i) IF (p(i)*p(i-1) < 0.d0) nodes=nodes+1 !renormalize if necessary scale=ABS(p(i)) IF (scale > vlarg) THEN scale=1.d0/scale p(1:i)=scale*p(1:i) ENDIF ENDDO wfn(1:many)=p(1:many) IF (Grid%type==loggrid) THEN wfn(1:many)=wfn(1:many)*Grid%pref(1:many) ENDIF DEALLOCATE(a,b,p) END SUBROUTINE forward_numerov !************************************************************* ! subroutine shifted_forward_numerov(Grid,many,istart,ww,wfn,nodes) ! designed for use with scalar relativistic case in which ! l and energy information is stored in ww !************************************************************* SUBROUTINE shifted_forward_numerov(Grid,many,istart,ww,wfn,nodes) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: many,istart REAL(8), INTENT(IN) :: ww(:) REAL(8), INTENT(INOUT) :: wfn(:) ! on input wfn(1:5) given ! on ouput wfn(i) given for ! i<=many INTEGER, INTENT(OUT) :: nodes REAL(8), ALLOCATABLE :: a(:),b(:),p(:) REAL(8) :: xx,angm,h,h2,scale REAL(8), PARAMETER :: vlarg=1.d30 INTEGER :: i,j,k,n if (istart>many) then write(6,*) 'shifted_forward_numerov: error istart many',istart,many stop endif ALLOCATE(a(many),b(many),p(many),stat=i) IF (i/=0) THEN WRITE(6,*) 'Allocation error forward_numerov ', many,i STOP ENDIF p(1:istart)=wfn(1:istart) a=0 h=Grid%h; h2=h*h DO i=2,many a(i)=ww(i) ENDDO IF (Grid%type==loggrid) THEN p(1:istart)=Grid%pref(1:istart)*wfn(1:istart) a=0.25d0+Grid%rr02(1:many)*a ENDIF b=2.4d0+h2*a a=1.2d0-0.1d0*h2*a nodes=0 DO i=istart+1,many p(i)=(b(i-1)*p(i-1)-a(i-2)*p(i-2))/a(i) IF (p(i)*p(i-1) < 0.d0) nodes=nodes+1 !renormalize if necessary scale=ABS(p(i)) IF (scale > vlarg) THEN scale=1.d0/scale p(1:i)=scale*p(1:i) ENDIF ENDDO wfn(1:many)=p(1:many) IF (Grid%type==loggrid) THEN wfn(1:many)=wfn(1:many)*Grid%pref(1:many) ENDIF DEALLOCATE(a,b,p) END SUBROUTINE shifted_forward_numerov !********************************************************************** ! pgm to integrate outward the radial schroedinger inhomogeneous equation ! at energy 'energy' and at angular momentum l ! with potential smooth rv/r ! proj/r == inhomogeneous function ! It is assumed that for r~0, proj~~(r**(l+1))*(c0+r**2*c2+...) ! and wfn~C*r**(l+3)*polynomial(r) for r~0; ! ! uses Noumerov algorithm !************************************************************************* !************************************************************* ! subroutine inhomogeneous_numerov(Grid,l,many,energy,rv,proj,wfn) !************************************************************* SUBROUTINE inhomogeneous_numerov(Grid,l,many,energy,rv,proj,wfn) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: l,many REAL(8), INTENT(IN) :: energy,rv(:),proj(:) REAL(8), INTENT(OUT) :: wfn(:) ! initial values of wfn determined from proj(r=0) REAL(8), ALLOCATABLE :: a(:),b(:),c(:),p(:) REAL(8) :: xx,angm,h,h2,scale INTEGER :: i,j,k,n ALLOCATE(a(many),b(many),c(many),p(many),stat=i) IF (i/=0) THEN WRITE(6,*) 'Allocation error forward_numerov ', many,i STOP ENDIF a=0 a(2:3)=proj(2:3)/(Grid%r(2:3)**(l+1)) call extrapolate(Grid,a) wfn=0 wfn(2)=-a(1)*(Grid%r(2)**(l+3))/(4*l+6.d0) p(1)=wfn(1) p(2)=wfn(2) angm=l*(l+1) a=0 h=Grid%h; h2=h*h DO i=2,many a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2) ENDDO b(1:many)=0.1d0*h2*proj(1:many) IF (Grid%type==loggrid) THEN p(1:2)=Grid%pref(1:2)*wfn(1:2) a=0.25d0+Grid%rr02(1:many)*a b=Grid%rr02(1:many)*b/Grid%pref(1:many) ENDIF c=0 do i=2,many-1 c(i)=10*b(i)+b(i-1)+b(i+1) enddo b=2.4d0+h2*a a=1.2d0-0.1d0*h2*a p(3)=(b(2)*p(2)-c(2))/a(3) DO i=4,many p(i)=(b(i-1)*p(i-1)-a(i-2)*p(i-2)-c(i-1))/a(i) ENDDO wfn(1:many)=p(1:many) IF (Grid%type==loggrid) THEN wfn(1:many)=wfn(1:many)*Grid%pref(1:many) ENDIF DEALLOCATE(a,b,c,p) END SUBROUTINE inhomogeneous_numerov !********************************************************* ! subroutine backward_numerov(Grid,l,match,energy,rv,wfn) !********************************************************* SUBROUTINE backward_numerov(Grid,l,match,energy,rv,wfn) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: l,match REAL(8), INTENT(IN) :: energy,rv(:) REAL(8), INTENT(INOUT) :: wfn(:) ! on input wfn(n-1) and wfn(n) given ! on ouput wfn(i) given for ! start<=i<=n REAL(8), ALLOCATABLE :: a(:),b(:),p(:) REAL(8) :: xx,angm,h,h2,scale REAL(8), PARAMETER :: vlarg=1.d30 INTEGER :: i,j,k,n n=Grid%n ALLOCATE(a(n),b(n),p(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Allocation error backward_numerov ', n,i STOP ENDIF p(n)=wfn(n) p(n-1)=wfn(n-1) angm=l*(l+1) a=0 h=Grid%h; h2=h*h DO i=match,n a(i)=rv(i)/Grid%r(i)-energy+angm/(Grid%r(i)**2) ENDDO IF (Grid%type==loggrid) THEN p(n-1:n)=Grid%pref(n-1:n)*p(n-1:n) a(match:n)=0.25d0+Grid%rr02(match:n)*a(match:n) ENDIF b(match:n)=2.4d0+h2*a(match:n) a(match:n)=1.2d0-0.1d0*h2*a(match:n) DO i=n-2,match,-1 p(i)=(b(i+1)*p(i+1)-a(i+2)*p(i+2))/a(i) !renormalize if necessary scale=ABS(p(i)) IF (scale > vlarg) THEN scale=1.d0/scale p(i:n)=scale*p(i:n) ENDIF ENDDO wfn(match:n)=p(match:n) IF (Grid%type==loggrid) THEN wfn(match:n)=wfn(match:n)*Grid%pref(match:n) ENDIF DEALLOCATE(a,b,p) END SUBROUTINE backward_numerov ! Subroutine from David Vanderbilt's USPS code, modified by Marc ! Torrent and Francois Jollet, further modified by NAWH !=========================================================================== ! subroutine cfdsol(zz,yy,jj1,jj2,mesh) !=========================================================================== ! routine for solving coupled first order differential equations ! ! d yy(x,1) ! --------- = zz(x,1,1) * yy(x,1) + zz(x,1,2) * yy(2,1) ! dx ! ! d yy(x,2) ! --------- = zz(x,2,1) * yy(x,1) + zz(x,2,2) * yy(2,1) ! dx ! ! ! using fifth order predictor corrector algorithm ! ! routine integrates from jj1 to jj2 and can cope with both cases ! jj1 < jj2 and jj1 > jj2. first five starting values of yy must ! be provided by the calling program. subroutine cfdsol(Grid,zz,yy,jj1,jj2) Type(gridinfo), INTENT(IN) :: Grid real(8), INTENT(IN):: zz(:,:,:) real(8), INTENT(INOUT):: yy(:,:) integer, INTENT(IN) :: jj1,jj2 real(8):: fa(0:5),fb(0:5),abp(1:5),amc(0:4) integer :: isgn,i,j,ip,mesh real(8):: arp,brp real(8), allocatable :: tmpz(:,:,:) real(8), parameter :: verylarge=1.d30 real(8) :: scale mesh=size(yy(2,:)) !write (6,*) ' in cdfdol with mesh jj1,j22', mesh, jj1,jj2 if (size(zz(2,2,:))/=mesh) then write(6,*) 'cfdsol error - incompatible arrays', mesh,size(zz(2,2,:)) stop endif isgn = ( jj2 - jj1 ) / iabs( jj2 - jj1 ) if ( isgn .eq. + 1 ) then if ( jj1 .le. 5 .or. jj2 .gt. mesh ) then write(6,10) isgn,jj1,jj2,mesh call exit(1) endif elseif ( isgn .eq. - 1 ) then if ( jj1 .ge. ( mesh - 4 ) .or. jj2 .lt. 1 ) then write(6,10) isgn,jj1,jj2,mesh call exit(1) endif else write(6,10) isgn,jj1,jj2,mesh endif 10 format(' ***error in subroutine difsol',/,& &' isgn =',i2,' jj1 =',i5,' jj2 =',i5,' mesh =',i5,& &' are not allowed') allocate(tmpz(2,2,mesh)) tmpz=zz do i=1,2 do j=1,2 tmpz(i,j,:)=tmpz(i,j,:)*Grid%h if (Grid%TYPE==loggrid) tmpz(i,j,:)=tmpz(i,j,:)*Grid%drdu(:) enddo enddo abp(1) = 1901.d0 / 720.d0 abp(2) = -1387.d0 / 360.d0 abp(3) = 109.d0 / 30.d0 abp(4) = -637.d0 / 360.d0 abp(5) = 251.d0 / 720.d0 amc(0) = 251.d0 / 720.d0 amc(1) = 323.d0 / 360.d0 amc(2) = -11.d0 / 30.d0 amc(3) = 53.d0 / 360.d0 amc(4) = -19.d0 / 720.d0 do j = 1,5 ip = jj1 - isgn * j fa(j) = tmpz(1,1,ip) * yy(1,ip) + tmpz(1,2,ip) * yy(2,ip) fb(j) = tmpz(2,1,ip) * yy(1,ip) + tmpz(2,2,ip) * yy(2,ip) enddo do j = jj1,jj2,isgn arp = yy(1,j-isgn) brp = yy(2,j-isgn) if (abs(arp)>verylarge.or.brp>verylarge) then scale=1.d0/(abs(arp)+abs(brp)) arp=arp*scale brp=brp*scale fa(:)=fa(:)*scale; fb(:)=fb(:)*scale yy=yy*scale endif do i = 1,5 arp = arp + dble(isgn) * abp(i) * fa(i) brp = brp + dble(isgn) * abp(i) * fb(i) enddo fa(0) = tmpz(1,1,j) * arp + tmpz(1,2,j) * brp fb(0) = tmpz(2,1,j) * arp + tmpz(2,2,j) * brp yy(1,j) = yy(1,j-isgn) yy(2,j) = yy(2,j-isgn) do i = 0,4,1 yy(1,j) = yy(1,j) + dble(isgn) * amc(i) * fa(i) yy(2,j) = yy(2,j) + dble(isgn) * amc(i) * fb(i) enddo do i = 5,2,-1 fa(i) = fa(i-1) fb(i) = fb(i-1) enddo fa(1) = tmpz(1,1,j) * yy(1,j) + tmpz(1,2,j) * yy(2,j) fb(1) = tmpz(2,1,j) * yy(1,j) + tmpz(2,2,j) * yy(2,j) enddo deallocate(tmpz) end subroutine cfdsol !********************************************************* ! subroutine mod_backward_numerov(Grid,match,ww,wfn) ! version modified for scalar relativistic case when ! l and energy terms represented in array ww !********************************************************* SUBROUTINE mod_backward_numerov(Grid,match,ww,wfn) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: match REAL(8), INTENT(IN) :: ww(:) REAL(8), INTENT(INOUT) :: wfn(:) ! on input wfn(n-1) and wfn(n) given ! on ouput wfn(i) given for ! start<=i<=n REAL(8), ALLOCATABLE :: a(:),b(:),p(:) REAL(8) :: xx,angm,h,h2,scale REAL(8), PARAMETER :: vlarg=1.d30 INTEGER :: i,j,k,n n=Grid%n ALLOCATE(a(n),b(n),p(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Allocation error backward_numerov ', n,i STOP ENDIF p(n)=wfn(n) p(n-1)=wfn(n-1) a=0 h=Grid%h; h2=h*h DO i=match,n a(i)=ww(i) ENDDO IF (Grid%type==loggrid) THEN p(n-1:n)=Grid%pref(n-1:n)*p(n-1:n) a(match:n)=0.25d0+Grid%rr02(match:n)*a(match:n) ENDIF b(match:n)=2.4d0+h2*a(match:n) a(match:n)=1.2d0-0.1d0*h2*a(match:n) DO i=n-2,match,-1 p(i)=(b(i+1)*p(i+1)-a(i+2)*p(i+2))/a(i) !renormalize if necessary scale=ABS(p(i)) IF (scale > vlarg) THEN scale=1.d0/scale p(i:n)=scale*p(i:n) ENDIF ENDDO wfn(match:n)=p(match:n) IF (Grid%type==loggrid) THEN wfn(match:n)=wfn(match:n)*Grid%pref(match:n) ENDIF DEALLOCATE(a,b,p) END SUBROUTINE mod_backward_numerov !****************************************************************** ! subroutine kinetic(Grid,wfn,l,ekin) ! calculates expectation value of kinetic energy for wfn ! with orbital angular momentum l ! wfn == r*radialwfn in Schroedinger Equation ! assumes wfn=(constant)*r^(l+1) at small r !***************************************************************** SUBROUTINE kinetic(Grid,l,wfn,ekin) TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: wfn(:) INTEGER, INTENT(IN) :: l REAL(8), INTENT(OUT) :: ekin REAL(8), ALLOCATABLE :: dfdr(:),arg(:) INTEGER :: i,n n=Grid%n ALLOCATE(dfdr(n),arg(n),stat=i) CALL derivative(Grid,wfn,dfdr) arg=0 DO i=2,n arg(i)=wfn(i)/Grid%r(i) ENDDO DO i=1,n arg(i)=(dfdr(i))**2+(l*(l+1))*(arg(i))**2 ENDDO ekin=integrator(Grid,arg) DEALLOCATE(dfdr,arg) END SUBROUTINE kinetic !****************************************************************** ! subroutine altkinetic(Grid,wfn,energy,rv,ekin) ! calculates expectation value of kinetic energy for wfn ! with orbital wfn by integrating ! int(wfn**2 * (energy-rv/r), r=0..rmax) !***************************************************************** SUBROUTINE altkinetic(Grid,wfn,energy,rv,ekin) TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: wfn(:),rv(:),energy REAL(8), INTENT(OUT) :: ekin REAL(8), ALLOCATABLE :: arg(:) INTEGER :: i,n n=Grid%n ALLOCATE(arg(n),stat=i) arg=0 DO i=2,n arg(i)=(wfn(i)**2)*(energy-rv(i)/Grid%r(i)) ENDDO ekin=integrator(Grid,arg) DEALLOCATE(arg) END SUBROUTINE altkinetic !**************************************************************** ! function FindGridIndex(Grid,rpoint) !**************************************************************** FUNCTION FindGridIndex(Grid,rpoint) INTEGER :: FindGridIndex TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: rpoint REAL(8) :: r0 FindGridIndex=0 IF (Grid%type==lineargrid) THEN FindGridIndex=rpoint/Grid%h+1 IF (Grid%h*(FindGridIndex-1)SIZE(f)) THEN WRITE(6,*) 'Error in secondderiv', index, SIZE(f) STOP ENDIF secondderiv=0 secondderiv=-(f(index-2)+f(index+2))/12 + & 4*(f(index-1)+f(index+1))/3 - 5*f(index)/2 secondderiv=secondderiv/(h*h) END FUNCTION secondderiv !**************** ! finite difference first derivative !***************** FUNCTION firstderiv(index,f,h) REAL(8) :: firstderiv INTEGER, INTENT(IN) :: index REAL(8), INTENT(IN) :: f(:),h IF (index<3.OR.index+2>SIZE(f)) THEN WRITE(6,*) 'Error in firstderiv', index, SIZE(f) STOP ENDIF firstderiv=0 firstderiv=(f(index-2)-f(index+2))/12-2*(f(index-1)-f(index+1))/3 firstderiv=firstderiv/h END FUNCTION firstderiv !***************** ! Second derivative for general grid !***************** FUNCTION Gsecondderiv(Grid,index,g) REAL(8) :: Gsecondderiv TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: index REAL(8), INTENT(IN) :: g(:) REAL(8), ALLOCATABLE :: f(:) INTEGER :: i,n IF (index<3.OR.index+2>SIZE(g)) THEN WRITE(6,*) 'Error in secondderiv', index, SIZE(f) STOP ENDIF Gsecondderiv=0 IF (Grid%type==lineargrid) THEN Gsecondderiv=secondderiv(index,g,Grid%h) ELSEIF (Grid%type==loggrid) THEN n=Grid%n ALLOCATE(f(index-2:index+2),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in secondderiv ', i,n STOP ENDIF f(index-2:index+2)=g(index-2:index+2)/Grid%pref(index-2:index+2) Gsecondderiv=secondderiv(3,f(index-2:index+2),Grid%h) Gsecondderiv=Grid%pref(index)*(Gsecondderiv-& 0.25d0*f(index))/Grid%rr02(index) DEALLOCATE(f) ENDIF END FUNCTION Gsecondderiv !***************** ! First derivative for general grid !***************** FUNCTION Gfirstderiv(Grid,index,g) REAL(8) :: Gfirstderiv TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: index REAL(8), INTENT(IN) :: g(:) REAL(8), ALLOCATABLE :: f(:) INTEGER :: i,n IF (index<3.OR.index+2>SIZE(g)) THEN WRITE(6,*) 'Error in firstderiv', index, SIZE(f) STOP ENDIF Gfirstderiv=0 IF (Grid%type==lineargrid) THEN Gfirstderiv=firstderiv(index,g,Grid%h) ELSEIF (Grid%type==loggrid) THEN n=Grid%n ALLOCATE(f(index-2:index+2),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in firstderiv ', i,n STOP ENDIF f(index-2:index+2)=g(index-2:index+2)/Grid%pref(index-2:index+2) Gfirstderiv=firstderiv(3,f(index-2:index+2),Grid%h) Gfirstderiv=Grid%pref(index)*(Gfirstderiv+& 0.5d0*f(index))/SQRT(Grid%rr02(index)) DEALLOCATE(f) ENDIF END FUNCTION Gfirstderiv !***************************************************************** ! subroutine reportgrid(Grid,unit) !***************************************************************** SUBROUTINE reportgrid(Grid,unit) TYPE (GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: unit IF (Grid%type==lineargrid) THEN WRITE(unit,*) ' Radial integration grid is linear ' WRITE(unit,*) ' h = ', Grid%h,' n = ', Grid%n ELSEIF (Grid%type==loggrid) THEN WRITE(unit,*) ' Radial integration grid is logarithmic ' WRITE(unit,*) 'r0 = ', Grid%drdu(1),' h = ', Grid%h,' n = ', Grid%n ENDIF END SUBROUTINE reportgrid !****************************************************************** ! function gridindex(Grid,r) !****************************************************************** FUNCTION gridindex(Grid,r) INTEGER :: gridindex TYPE (GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: r gridindex=0 if (Grid%type==lineargrid) then gridindex=r/Grid%h +0.1d0 +1 elseif (Grid%type==loggrid) then gridindex=LOG(1.d0+r/Grid%drdu(1))/Grid%h +0.1d0 +1 endif END function gridindex !********************************************************************* ! subroutine findh(Z,range,n,hval) ! find hval for fixed number of input grid points n in loggrid case ! assumes form r(i)=(h/Z)*(exp(h*(i-1))-1) !********************************************************************* SUBROUTINE findh(Z,range,n,hval) INTEGER, INTENT(IN) :: Z,n REAL(8), INTENT(IN) :: range REAL(8), INTENT(INOUT) :: hval REAL(8) :: h0,dh,f,df INTEGER :: i,j,k INTEGER, parameter :: iter=1000 REAL(8), parameter :: eps=1.e-15 LOGICAL :: success h0=hval success=.false. do i=1,iter f=LOG(Z*range/h0+1.d0)/h0 df=-f/h0-(Z*range/h0**3)/(Z*range/h0+1.d0) dh=(n-1-f)/df if (ABS(dh)< eps) then success=.true. exit endif if (h0+dh<0.d0) then h0=h0/2 else h0=h0+dh endif enddo if (.not.success) then write(6,*) 'Warning in findh -- dh > eps ', dh,h0 endif hval=h0 end subroutine findh !****************************************************************** ! subroutine initgrid(Grid,h,range,r0) !****************************************************************** SUBROUTINE initgrid(Grid,h,range,r0) TYPE (GridInfo), INTENT(INOUT) :: Grid REAL(8), INTENT(IN) :: range REAL(8), INTENT(IN) :: h REAL(8), OPTIONAL, INTENT(IN) :: r0 INTEGER :: i,n IF (PRESENT(r0)) THEN Grid%type=loggrid n=LOG(range/r0+1)/h+1 IF (r0*(EXP(h*(n-1))-1) REAL(8), POINTER :: eig(:),occ(:),ck(:),vrc(:) REAL(8), POINTER :: oij(:,:),dij(:,:) !** L=0 matrix elements for atomic SC calculations REAL(8), POINTER :: tvij(:,:),vhatij(:,:),kin(:,:) REAL(8), POINTER :: v0ij(:,:),vhijkl(:,:,:,:) END TYPE Pseudoinfo CONTAINS !*************************************************************** ! SUBROUTINE troullier(lmax,Grid,Pot) ! Creates screened norm-conserving pseudopotential following ! approach of N. Troullier and J. L. Martins, PRB 43, 1993 (1991) ! Uses p(r)=a0+f(r); f(r)=SUMm(Coef(m)*r^(2*m), where ! m=1,2..6 ! Psi(r) = r^(l+1)*exp(p(r)) !*************************************************************** SUBROUTINE Troullier(Grid,Pot,PAW,l,e) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Potentialinfo), INTENT(IN) :: Pot TYPE(Pseudoinfo), INTENT(INOUT) :: PAW INTEGER,INTENT(IN) :: l REAL(8),INTENT(IN) :: e REAL(8), ALLOCATABLE :: VNC(:) REAL(8) :: A0,A,B,B0,C,C0,D,F,S REAL(8) :: Coef(6),Coef0,Coef0old REAL(8) :: h,rc,delta,x,pp,dpp,ddpp,dddpp,ddddpp REAL(8) :: gam,bet INTEGER :: i,j,k,n,iter,nr,nodes,irc,ok,m,wavetype INTEGER, PARAMETER :: niter=5000 REAL(8), PARAMETER :: small=1.0d-9 REAL(8), ALLOCATABLE :: wfn(:),p(:),dum(:) REAL(8), POINTER :: r(:),rv(:) CHARACTER(132) :: line n=Grid%n h=Grid%h r=>Grid%r rv=>Pot%rv nr=min(PAW%irc_vloc+10,n) irc=PAW%irc_vloc rc=PAW%rc_vloc ALLOCATE(VNC(n),wfn(nr),p(nr),dum(nr),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in troullier -- in allocating wfn,p', nr,ok STOP ENDIF !write(6,*) ' Troullier ', n,nr,irc !call flush(6) if (scalarrelativistic) then CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes) else CALL unboundsch(Grid,Pot,nr,l,e,wfn,nodes) endif IF (wfn(irc)<0) wfn=-wfn dum(1:irc)=(wfn(1:irc)**2) S=integrator(Grid,dum(1:irc),1,irc) A0=LOG(wfn(irc)/(rc**(l+1))) B0=(rc*Gfirstderiv(Grid,irc,wfn)/wfn(irc)-(l+1)) C0=rc*(rv(irc)-rc*e)-B0*(B0+2*l+2) D=-rc*(rv(irc)-rc*Gfirstderiv(Grid,irc,rv))-2*B0*C0-2*(l+1)*(C0-B0) F=rc*(2*rv(irc)-rc*(2*Gfirstderiv(Grid,irc,rv) & -rc*Gsecondderiv(Grid,irc,rv)))+& 4*(l+1)*(C0-B0)-2*(l+1)*D-2*C0**2-2*B0*D WRITE(6,*) 'In troullier -- matching parameters',S,A0,B0,C0,D,F delta=1.d10 iter=0 Coef0=0 DO WHILE(delta>small.AND.iter<=niter) iter=iter+1 A=A0-Coef0 B=B0 C=C0 CALL EvaluateTp(l,A,B,C,D,F,coef) dum=0 DO i=1,irc x=(r(i)/rc)**2 p(i)=x*(Coef(1)+x*(Coef(2)+x*(Coef(3)+& x*(Coef(4)+x*(Coef(5)+x*Coef(6)))))) dum(i)=((r(i)**(l+1))*EXP(p(i)))**2 ENDDO Coef0old=Coef0 x=integrator(Grid,dum(1:irc),1,irc) Coef0=(LOG(S/x))/2 delta=ABS(Coef0-Coef0old) WRITE(6,'(" VNC: iter Coef0 delta",i5,1p2e15.7)') iter,Coef0,delta ENDDO WRITE(6,*) ' VNC converged in ', iter,' iterations' WRITE(6,*) ' Coefficients -- ', Coef0,Coef(1:6) ! ! Now calculate VNC OPEN(88,file='NC',form='formatted') ! VNC=0 DO i=2,nr x=(r(i)/rc)**2 p(i)=Coef0+x*(Coef(1)+x*(Coef(2)+& x*(Coef(3)+x*(Coef(4)+x*(Coef(5)+x*Coef(6)))))) dpp=2*r(i)/(rc**2)*(Coef(1)+x*(2*Coef(2)+x*(3*Coef(3)+& x*(4*Coef(4)+x*(5*Coef(5)+x*6*Coef(6)))))) ddpp=(1/(rc**2))*(2*Coef(1)+x*(12*Coef(2)+x*(30*Coef(3)+& x*(56*Coef(4)+x*(90*Coef(5)+x*132*Coef(6)))))) dddpp=(r(i)/rc**4)*(24*Coef(2)+x*(120*Coef(3)+x*(336*Coef(4)+& x*(720*Coef(5)+x*1320*Coef(6))))) ddddpp=(1/(rc**4)*(24*Coef(2)+x*(360*Coef(3)+x*(1680*Coef(4)+& x*(5040*Coef(5)+x*11880*Coef(6)))))) IF (i==irc) THEN WRITE(6,*) 'check dp ', dpp, B0/rc WRITE(6,*) 'check ddp ', ddpp, C0/rc**2 WRITE(6,*) 'check dddp', dddpp, D/rc**3 WRITE(6,*) 'check ddddp', ddddpp, F/rc**4 ENDIF VNC(i)=e+ddpp+dpp*(dpp+2*(l+1)/r(i)) dum(i)=(r(i)**(l+1))*EXP(p(i)) WRITE(88,'(1p5e15.7)') r(i),wfn(i),dum(i),VNC(i)*r(i),rv(i) ENDDO CLOSE(88) x=overlap(Grid,dum(1:irc),dum(1:irc),1,irc) WRITE(6,*) 'check norm ',x,S VNC(irc:n)=rv(irc:n)/r(irc:n) PAW%rveff(1:n)=VNC(1:n)*r(1:n) DEALLOCATE(VNC,wfn,p,dum) END SUBROUTINE troullier !*************************************************************** ! SUBROUTINE kerker(lmax,Grid,Pot) ! Creates screened norm-conserving pseudopotential following ! approach of G. P. Kerker, J. Phys. C. 13,L189-L194 (1980) ! Uses p(r)=a0+f(r); f(r)=SUMi(Coef(i)*r^m(i)), where m(i) ! are input powers ! Psi(r) = r^(l+1)*exp(p(r)) if PStype = EXPF ! Psi(r) = r^(l+1)*(p(r)) if PStype = POLY !*************************************************************** SUBROUTINE kerker(Grid,Pot,PAW) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Potentialinfo), INTENT(IN) :: Pot TYPE(Pseudoinfo), INTENT(INOUT) :: PAW REAL(8), ALLOCATABLE :: VNC(:) REAL(8) :: A0,A,B,C,D,S,Coef(4),Coef0,Coef0old REAL(8) :: h,e,rc,delta,x,pp,dpp,ddpp,dddpp REAL(8) :: gam,bet INTEGER :: i,j,k,n,iter,nr,nodes,irc,l,ok,m(4),wavetype INTEGER, PARAMETER :: EXPF=1, POLY=2 INTEGER, PARAMETER :: niter=5000 REAL(8), PARAMETER :: small=1.0d-12 CHARACTER(10) :: vtype REAL(8), ALLOCATABLE :: wfn(:),p(:),dum(:) REAL(8), POINTER :: r(:),rv(:) DO WRITE(6,*) 'Input "EXPF" or "POLY" pseudowave form' READ(5,*) vtype IF (TRIM(vtype)=="EXPF".OR.TRIM(vtype)=="expf") THEN wavetype=EXPF EXIT ELSE IF (TRIM(vtype)=="POLY".OR.TRIM(vtype)=="poly") THEN wavetype=POLY EXIT ENDIF ENDDO DO WRITE(6,*) 'Input angular momentum l and energy e to set VNC ' READ(5,*) l,e IF (l >= 0 .AND. l < 10) EXIT ENDDO m=0 DO WRITE(6,*) 'Input the 4 powers for the polynomial f(r)' READ(5,*) m(1),m(2),m(3),m(4) IF (m(1)>0.AND.m(2)>0.AND.m(3)>0.AND.m(4)>0) EXIT ENDDO IF (wavetype==EXPF) THEN WRITE(PAW%Vloc_description,& '("Norm-conserving Exp Vloc; l = ",i1,"; powers = ",4i3,"; e = ",1pe12.3)')& l, m(1),m(2),m(3),m(4),e WRITE(6,*) PAW%Vloc_description ENDIF IF (wavetype==POLY) THEN WRITE(PAW%Vloc_description,& '("Norm-conserving Poly Vloc; l = ",i1,"; powers = ",4i3,"; e = ",1pe12.3)')& l, m(1),m(2),m(3),m(4),e WRITE(6,*) PAW%Vloc_description ENDIF n=Grid%n n=Grid%n h=Grid%h r=>Grid%r rv=>Pot%rv nr=min(PAW%irc_vloc+10,n) irc=PAW%irc_vloc rc=PAW%rc_vloc ALLOCATE(VNC(n),wfn(nr),p(nr),dum(nr),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in kerker -- in allocating wfn,p', nr,ok STOP ENDIF if (scalarrelativistic) then CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes) else CALL unboundsch(Grid,Pot,nr,l,e,wfn,nodes) endif IF (wfn(irc)<0) wfn=-wfn dum(1:irc)=(wfn(1:irc)**2) S=integrator(Grid,dum(1:irc),1,irc) IF (wavetype==EXPF) THEN A0=LOG(wfn(irc)/(rc**(l+1))) B=(rc*Gfirstderiv(Grid,irc,wfn)/wfn(irc)-(l+1)) C=rc*(rv(irc)-rc*e)-B*(B+2*l+2) D=-rc*(rv(irc)-rc*Gfirstderiv(Grid,irc,rv))-2*B*C-2*(l+1)*(C-B) ENDIF IF (wavetype==POLY) THEN A0=(wfn(irc)/(rc**(l+1))) B=(rc*Gfirstderiv(Grid,irc,wfn))/(rc**(l+1))-(l+1)*A0 C=rc*(rv(irc)-rc*e)*A0-2*(l+1)*B D=-rc*(rv(irc)-rc*Gfirstderiv(Grid,irc,rv))*A0+2*(l+1)*(B-C)+& rc*(rv(irc)-rc*e)*B ENDIF WRITE(6,*) 'In kerker -- matching parameters',S,A0,B,C,D delta=1.d10 iter=0 Coef0=0 DO WHILE(delta>small.AND.iter<=niter) iter=iter+1 A=A0-Coef0 CALL EvaluateP(m,A,B,C,D,Coef) dum=0 DO i=1,irc x=(r(i)/rc) p(i)=(x**m(1))*Coef(1)+(x**m(2))*Coef(2)+(x**m(3))*Coef(3)+(x**m(4))*Coef(4) IF (wavetype==EXPF)dum(i)=((r(i)**(l+1))*EXP(p(i)))**2 IF (wavetype==POLY)dum(i)=(wfn(i))**2-((r(i)**(l+1))*(p(i)))**2 ENDDO Coef0old=Coef0 IF (wavetype==EXPF) THEN x=integrator(Grid,dum(1:irc),1,irc) Coef0=(LOG(S/x))/2 ENDIF IF (wavetype==POLY) THEN gam=(2*l+3)*integrator(Grid,dum(1:irc),1,irc)/(rc**(2*l+3)) bet=(2*l+3)*(Coef(1)/(2*l+3+m(1))+Coef(2)/(2*l+3+m(2))+& Coef(3)/(2*l+3+m(3))+Coef(4)/(2*l+3+m(4))) WRITE(6,'("VNC: iter -- bet,gam = ",i5,1p4e15.7)') iter,bet,gam x=bet**2+gam Coef0old=Coef0 IF (x<0.d0) THEN WRITE(6,*) 'Warning in Kerker subroutine x = ',x Coef0=Coef0+0.1*A0 ELSE Coef0=SQRT(x)-bet ENDIF ENDIF delta=ABS(Coef0-Coef0old) WRITE(6,*) ' VNC: iter Coef0 delta', iter,Coef0,delta ENDDO WRITE(6,*) ' VNC converged in ', iter,' iterations' WRITE(6,*) ' Coefficients -- ', Coef0,Coef(1:4) ! ! Now calculate VNC OPEN(88,file='NC',form='formatted') ! VNC=0 DO i=1,nr x=(r(i)/rc) p(i)=Coef0+(x**m(1))*Coef(1)+(x**m(2))*Coef(2)+& (x**m(3))*Coef(3)+(x**m(4))*Coef(4) dpp=(m(1)*(x**(m(1)-1))*Coef(1)+m(2)*(x**(m(2)-1))*Coef(2)+& m(3)*(x**(m(3)-1))*Coef(3)+m(4)*(x**(m(4)-1))*Coef(4))/rc ddpp=(m(1)*(m(1)-1)*(x**(m(1)-2))*Coef(1)+& m(2)*(m(2)-1)*(x**(m(2)-2))*Coef(2)+& m(3)*(m(3)-1)*(x**(m(3)-2))*Coef(3)+& m(4)*(m(4)-1)*(x**(m(4)-2))*Coef(4))/(rc**2) dddpp=(m(1)*(m(1)-1)*(m(1)-2)*(x**(m(1)-3))*Coef(1)+& m(2)*(m(2)-1)*(m(2)-2)*(x**(m(2)-3))*Coef(2)+& m(3)*(m(3)-1)*(m(3)-2)*(x**(m(3)-3))*Coef(3)+& m(4)*(m(4)-1)*(m(4)-2)*(x**(m(4)-3))*Coef(4))/(rc**3) IF (i==irc) THEN WRITE(6,*) 'check dp ', dpp, B/rc WRITE(6,*) 'check ddp ', ddpp, C/rc**2 WRITE(6,*) 'check dddp', dddpp, D/rc**3 ENDIF IF (wavetype==EXPF) THEN VNC(i)=e+ddpp+dpp*(dpp+2*(l+1)/r(i)) dum(i)=(r(i)**(l+1))*EXP(p(i)) ENDIF IF (wavetype==POLY) THEN VNC(i)=e+(ddpp+2*(l+1)*dpp/r(i))/p(i) dum(i)=(r(i)**(l+1))*(p(i)) ENDIF WRITE(88,'(1p5e15.7)') r(i),wfn(i),dum(i),VNC(i)*r(i),rv(i) ENDDO CLOSE(88) x=overlap(Grid,dum(1:irc),dum(1:irc),1,irc) WRITE(6,*) 'check norm ',x,S VNC(irc:n)=rv(irc:n)/r(irc:n) PAW%rveff(1:n)=VNC(1:n)*r(1:n) DEALLOCATE(VNC,wfn,p,dum) END SUBROUTINE kerker !*************************************************************** ! SUBROUTINE nonncps(lmax,Grid,Pot) ! Creates screened pseudopotential by inverting Schroedinger ! equation from a pseudized radial wave function of the form: ! Psi(r) = r**(l+1) * exp (a + b*r**2 + c*r**4 + d*r**6) ! No norm-conserving condition is imposed on Psi !*************************************************************** SUBROUTINE nonncps(Grid,Pot,PAW,l,e) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Potentialinfo), INTENT(IN) :: Pot TYPE(Pseudoinfo), INTENT(INOUT) :: PAW INTEGER,INTENT(IN) :: l REAL(8),INTENT(IN) :: e INTEGER :: i,irc,n,nr,ok,nodes,i1,i2,i3,i4 REAL(8) :: rc,x,y1,y2,y3,p0,p1,p2,p3,sgn REAL(8) :: b(4),c(4),d(4),amat(4,4) REAL(8),ALLOCATABLE :: VNC(:),wfn(:) REAL(8),POINTER :: r(:),rv(:) CHARACTER(132) :: line !Polynomial definitions p0(x,y1,y2,y3)=(x-y1)*(x-y2)*(x-y3) p1(x,y1,y2,y3)=(x-y2)*(x-y3)+(x-y1)*(x-y3)+(x-y1)*(x-y2) p2(x,y1,y2,y3)=2.0d0*((x-y1)+(x-y2)+(x-y3)) p3(x,y1,y2,y3)=6.0d0 n=Grid%n r=>Grid%r rv=>Pot%rv nr=min(PAW%irc_vloc+10,n) irc=PAW%irc_vloc rc=PAW%rc_vloc ALLOCATE(VNC(n),wfn(nr),stat=ok) IF (ok/=0) stop 'Error in uspseudo -- allocating arrays' if (scalarrelativistic) then CALL unboundsr(Grid,Pot,nr,l,e,wfn,nodes) else CALL unboundsch(Grid,Pot,nr,l,e,wfn,nodes) endif IF (wfn(irc)<0) wfn=-wfn DO i=2,nr wfn(i)=wfn(i)/r(i)**dble(l+1) ENDDO i1=irc-1;i2=i1+1;i3=i2+1;i4=i3+1 c(1)=wfn(i1)/p0(r(i1),r(i2),r(i3),r(i4)) c(2)=wfn(i2)/p0(r(i2),r(i3),r(i4),r(i1)) c(3)=wfn(i3)/p0(r(i3),r(i4),r(i1),r(i2)) c(4)=wfn(i4)/p0(r(i4),r(i1),r(i2),r(i3)) d(1)=c(1)*p0(rc,r(i2),r(i3),r(i4)) + c(2)*p0(rc,r(i3),r(i4),r(i1)) + & & c(3)*p0(rc,r(i4),r(i1),r(i2)) + c(4)*p0(rc,r(i1),r(i2),r(i3)) d(2)=c(1)*p1(rc,r(i2),r(i3),r(i4)) + c(2)*p1(rc,r(i3),r(i4),r(i1)) + & & c(3)*p1(rc,r(i4),r(i1),r(i2)) + c(4)*p1(rc,r(i1),r(i2),r(i3)) d(3)=c(1)*p2(rc,r(i2),r(i3),r(i4)) + c(2)*p2(rc,r(i3),r(i4),r(i1)) + & & c(3)*p2(rc,r(i4),r(i1),r(i2)) + c(4)*p2(rc,r(i1),r(i2),r(i3)) d(4)=c(1)*p3(rc,r(i2),r(i3),r(i4)) + c(2)*p3(rc,r(i3),r(i4),r(i1)) + & & c(3)*p3(rc,r(i4),r(i1),r(i2)) + c(4)*p3(rc,r(i1),r(i2),r(i3)) sgn=d(1)/abs(d(1));d(1:4)=d(1:4)*sgn b(1)=log(d(1));b(2:4)=d(2:4) amat(1,1)= 1.0d0 amat(2:4,1)= 0.0d0 amat(1,2)= rc**2 amat(2,2)= 2.0d0*d(1)*rc amat(3,2)= 2.0d0*d(1) +2.0d0*d(2)*rc amat(4,2)= 4.0d0*d(2) +2.0d0*d(3)*rc amat(1,3)= rc**4 amat(2,3)= 4.0d0*d(1)*rc**3 amat(3,3)= 12.0d0*d(1)*rc**2+ 4.0d0*d(2)*rc**3 amat(4,3)= 24.0d0*d(1)*rc +24.0d0*d(2)*rc**2+4.0d0*d(3)*rc**3 amat(1,4)= rc**6 amat(2,4)= 6.0d0*d(1)*rc**5 amat(3,4)= 30.0d0*d(1)*rc**4+ 6.0d0*d(2)*rc**5 amat(4,4)= 120.0d0*d(1)*rc**3+60.0d0*d(2)*rc**4+6.0d0*d(3)*rc**5 CALL linsol(amat,b,4) write(6,*) 'Completed linsol with coefficients' write(6,'(1p10e15.7)') (b(i),i=1,4) PAW%rveff(1)=0.d0 DO i=2,irc-1 c(1)=2.0d0*b(2)*r(i)+ 4.0d0*b(3)*r(i)**3+ 6.0d0*b(4)*r(i)**5 c(2)=2.0d0*b(2) +12.0d0*b(3)*r(i)**2+30.0d0*b(4)*r(i)**4 PAW%rveff(i)=r(i)*(e+dble(2*l+2)*c(1)/r(i)+c(1)**2+c(2)) ENDDO PAW%rveff(irc:n)=rv(irc:n) DEALLOCATE(VNC,wfn) END SUBROUTINE nonncps !*************************************************************** ! SUBROUTINE besselps(lmax,Grid,Pot) ! Creates screened pseudopotential by simply pseudizing the ! AE potential with a l=0 spherical Bessel function: ! Vps(r) = a.sin(qr)/r !*************************************************************** SUBROUTINE besselps(Grid,Pot,PAW) TYPE(Gridinfo), INTENT(IN) :: Grid TYPE(Potentialinfo), INTENT(IN) :: Pot TYPE(Pseudoinfo), INTENT(INOUT) :: PAW INTEGER :: i,irc,l,n REAL(8) :: e,rc,alpha,beta,vv,vvp,AA,QQ,xx(1) REAL(8),ALLOCATABLE :: VNC(:),wfn(:) REAL(8),POINTER :: r(:),rv(:) CHARACTER(132) :: line n=Grid%n r=>Grid%r rv=>Pot%rv irc=PAW%irc_vloc rc=PAW%rc_vloc vv=rv(irc);vvp=Gfirstderiv(Grid,irc,rv) alpha=1.D0-rc*vvp/vv;beta=1.D0 call solvbes(xx,alpha,beta,0,1);QQ=xx(1) AA=vv/sin(QQ);QQ=QQ/rc PAW%rveff(1)=0.d0 PAW%rveff(irc+1:n)=rv(irc+1:n) do i=2,irc PAW%rveff(i)=AA*sin(QQ*r(i)) enddo END SUBROUTINE besselps !*************************************************************** ! SUBROUTINE EvaluateP ! Inverts 4x4 matrix used by kerker subroutine !*************************************************************** SUBROUTINE EvaluateP(m,A,B,C,D,coef) INTEGER, INTENT(IN) :: m(4) REAL(8), INTENT(IN) :: A,B,C,D REAL(8), INTENT(OUT) :: coef(4) REAL(8) :: t(4,4) INTEGER :: i,n t=0 Coef(1)=A; Coef(2)=B; Coef(3)=C; Coef(4)=D t(1,1:4)=1 t(2,1:4)=m(1:4) DO i=1,4 t(3,i)=m(i)*(m(i)-1) ENDDO DO i=1,4 t(4,i)=m(i)*(m(i)-1)*(m(i)-2) ENDDO n=4 CALL linsol(t,Coef,n) END SUBROUTINE EvaluateP !*************************************************************** ! SUBROUTINE EvaluateTp ! Inverts 5x5 matrix used by troullier subroutine !*************************************************************** SUBROUTINE EvaluateTp(l,A,B,C,D,F,coef) INTEGER, INTENT(IN) :: l REAL(8), INTENT(IN) :: A,B,C,D,F REAL(8), INTENT(OUT) :: coef(6) REAL(8) :: t(6,6),coef10,old REAL(8), PARAMETER :: small=1.e-10 INTEGER :: i,n,iter INTEGER, PARAMETER :: niter=1000 old=-1.e30; Coef10=-1; iter=-1 DO WHILE (iter < niter .AND. ABS(old-coef10)> small) iter=iter+1 t=0 Coef(1)=A-Coef10; Coef(2)=B-2*Coef10; Coef(3)=C-2*Coef10; Coef(4)=D; Coef(5)=F Coef(6)=-Coef10**2 DO i=1,6 t(1,i)=1 t(2,i)=2*i t(3,i)=2*i*(2*i-1) t(4,i)=2*i*(2*i-1)*(2*i-2) t(5,i)=2*i*(2*i-1)*(2*i-2)*(2*i-3) ENDDO t(6,1)=2*Coef10; t(6,2)=2*l+5 n=6 CALL linsol(t,Coef,n) old=Coef10; Coef10=Coef10+Coef(1) WRITE(6,'("EvaluateTp: iter",i5,1p2e15.7)') iter,Coef(1),Coef10 WRITE(6,'("Coef: ",1p6e15.7)')Coef10,(Coef(i),i=2,6) Coef(1)=Coef10 ENDDO IF (iter >= niter) THEN WRITE(6,*) 'Error in EvaluateTP -- no convergence' STOP ENDIF END SUBROUTINE EvaluateTp SUBROUTINE checkghosts(Grid,Orbit,FC,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(OrbitInfo), INTENT(IN) :: Orbit TYPE(FCInfo), INTENT(IN) :: FC TYPE(PseudoInfo), INTENT(in) :: PAW INTEGER :: l,nr,nodes,i,io REAL(8) :: energy,h REAL(8), POINTER :: r(:) REAL(8), ALLOCATABLE :: wfn(:),VNC(:) TYPE(PotentialInfo) :: Pot h=Grid%h r=>Grid%r nr=min(PAW%irc+5,Grid%n) ALLOCATE(VNC(nr),wfn(nr),POT%rv(nr),stat=i) IF (i /= 0) THEN WRITE(6,*) 'Error in checkghosts allocation',nr,i STOP ENDIF POT%rv(1:nr)=PAW%rveff(1:nr) call zeropot(Grid,POT%rv,POT%v0,POT%v0p) DO l=0,PAW%lmax DO io=1,Orbit%norbit IF((.NOT.FC%iscore(io)).AND.(Orbit%l(io)==l)) THEN energy=Orbit%eig(io) WRITE(6,*) 'Check for ghosts with l', l,energy CALL unboundsch(Grid,Pot,nr,l,energy,wfn,nodes) !DO i=1,nr ! WRITE(l+17,'(1p2e15.7)') Grid%r(i),wfn(i) !ENDDO WRITE(6,*) ' Found # nodes = ', nodes EXIT ENDIF ENDDO ENDDO DEALLOCATE(VNC,wfn,POT%rv) END SUBROUTINE checkghosts SUBROUTINE initpseudopot(Grid,PAW) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER ::n,ok n=Grid%n ALLOCATE(PAW%projshape(n),PAW%hatden(n),PAW%hatpot(n),& PAW%hatshape(n),PAW%vloc(n),PAW%rveff(n),PAW%abinitvloc(n),& PAW%den(n),PAW%tden(n),PAW%tcore(n),stat=ok) IF (ok /= 0) THEN WRITE(6,*) 'Allocation error in initpseudopot',n,ok ENDIF END SUBROUTINE initpseudopot SUBROUTINE sethat(Grid,PAW,gaussparam,besselopt) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER,INTENT(IN), OPTIONAL :: besselopt REAL(8),INTENT(IN), OPTIONAL :: gaussparam INTEGER :: n,irc,irc_shap,i REAL(8), POINTER :: r(:) REAL(8) :: h,con,rc,rc_shap,selfen,d,dd,jbes1,jbes2,qr REAL(8) :: al(2),ql(2) n=Grid%n h=Grid%h irc=PAW%irc rc=PAW%rc irc_shap=PAW%irc_shap rc_shap=PAW%rc_shap r=>Grid%r PAW%hatden=0 PAW%projshape=0 PAW%hatshape=0 PAW%projshape(1)=1 PAW%hatshape(1)=1 DO i=2,irc-1 PAW%projshape(i)=(SIN(pi*r(i)/rc)/(pi*r(i)/rc))**2 ENDDO if(present(gaussparam)) then d=rc_shap/SQRT(LOG(1.d0/gaussparam)) DO i=2,irc PAW%hatshape(i)=EXP(-(r(i)/d)**2) ENDDO PAW%irc_shap=PAW%irc PAW%rc_shap=PAW%rc else if(present(besselopt)) then call shapebes(al,ql,0,rc_shap) DO i=1,irc_shap-1 qr=ql(1)*r(i);CALL jbessel(jbes1,d,dd,0,0,qr) qr=ql(2)*r(i);CALL jbessel(jbes2,d,dd,0,0,qr) PAW%hatshape(i)=al(1)*jbes1+al(2)*jbes2 ENDDO else DO i=2,irc_shap-1 PAW%hatshape(i)=(SIN(pi*r(i)/rc_shap)/(pi*r(i)/rc_shap))**2 ENDDO endif PAW%hatden(1:irc)=PAW%hatshape(1:irc)*(r(1:irc)**2) ! normalize if (.not.besselshapefunction) then con=integrator(Grid,PAW%hatden,1,PAW%irc_shap) WRITE(6,*) ' check hatden normalization', con PAW%hatden=PAW%hatden/con endif CALL poisson(Grid,con,PAW%hatden,PAW%hatpot,selfen) WRITE(6,*) 'Self energy for L=0 hat density ', selfen END SUBROUTINE sethat SUBROUTINE coretailselfenergy(Grid,PAW,ctctse,cthatse) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW REAL(8), INTENT(OUT) :: ctctse,cthatse INTEGER :: i,irc,n REAL(8) :: rc,h,x,y,z REAL(8), allocatable :: d1(:),d2(:) n=Grid%n h=Grid%h irc=PAW%irc allocate(d1(n),d2(n),stat=i) if (i /= 0) then write(6,*) 'coretailselfenergy: allocation error -- ', n,i stop endif x=integrator(Grid,PAW%tcore) write(6,*) 'tcore charge ' , x CALL poisson(Grid,x,PAW%tcore,d1,ctctse) d2(2:n)=PAW%hatden(2:n)*d1(2:n)/Grid%r(2:n) d2(1)=0 cthatse=integrator(Grid,d2(1:irc),1,PAW%irc_shap) write(6,*) 'ctctse,cthatse = ', ctctse,cthatse deallocate(d1,d2) END SUBROUTINE coretailselfenergy SUBROUTINE setcoretail(Grid,coreden,PAW) TYPE(GridInfo), INTENT(IN) :: Grid REAL(8), INTENT(IN) :: coreden(:) TYPE(PseudoInfo), INTENT(INOUT) :: PAW REAL(8) :: rc,h,x,y,z,u0,u2,u4 REAL(8), allocatable :: d1(:),d2(:) INTEGER :: i,j,k,n,irc n=Grid%n h=Grid%h irc=PAW%irc_core rc=PAW%rc_core allocate(d1(n),d2(n),stat=i) if (i /= 0) then write(6,*) 'setcoretail: allocation error -- ', n,i stop endif CALL derivative(Grid,coreden,d1) CALL derivative(Grid,d1,d2) x=coreden(irc) y=d1(irc)*rc z=d2(irc)*(rc*rc) write(6,*) 'setcoretail: x,y,z = ', x,y,z u0=3*x - 9*y/8 + z/8 u2=-3*x + 7*y/4 - z/4 u4=x - 5*y/8 + z/8 write(6,*) 'setcoretail: u0,u2,u4 = ', u0,u2,u4 PAW%tcore=coreden do i=1,irc x=(Grid%r(i)/rc)**2 PAW%tcore(i)= x*(u0+x*(u2+x*u4)) enddo deallocate(d1,d2) END SUBROUTINE setcoretail !************************************************************** ! subroutine hatpotL ! Calculates potential associated with L component ! of unit hat density !************************************************************** SUBROUTINE hatpotL(Grid,PAW,l,vhat) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(IN) :: l REAL(8), INTENT(OUT) :: vhat(:) INTEGER :: n,irc,i REAL(8), POINTER :: r(:) REAL(8), ALLOCATABLE :: den(:),a(:) REAL(8) :: h,con REAL(8) :: qr,jbes1,jbes2,dum1,dum2,al(2),ql(2) n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc ALLOCATE(den(n),a(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in hatpotL allocation',n,i STOP ENDIF if (besselshapefunction) then call shapebes(al,ql,l,PAW%rc_shap) DO i=1,PAW%irc_shap qr=ql(1)*r(i);CALL jbessel(jbes1,dum1,dum2,0,0,qr) qr=ql(2)*r(i);CALL jbessel(jbes2,dum1,dum2,0,0,qr) den(i)=(al(1)*jbes1+al(2)*jbes2)*r(i)**2 ENDDO if (n>PAW%irc_shap) den(PAW%irc_shap+1:n)=0.d0 else DO i=1,n den(i)=(r(i)**l)*PAW%hatden(i) ENDDO a(1:n)=den(1:n)*(r(1:n)**l) con=integrator(Grid,a,1,PAW%irc_shap) den=den/con endif vhat=0 CALL apoisson(Grid,l,n,den,vhat(1:n)) ! apoisson returns vhat*r !DO i=1,n ! WRITE (78+l,'(i5,1p5e15.7)') i,Grid%r(i),den(i),vhat(i) !ENDDO vhat(2:n)=vhat(2:n)/r(2:n) call extrapolate(Grid,vhat) DEALLOCATE(den,a) END SUBROUTINE hatpotL !************************************************************** ! subroutine hatL ! Calculates density associated with L component ! normalized to unity !************************************************************** SUBROUTINE hatL(Grid,PAW,l,dhat) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(IN) :: l REAL(8), INTENT(OUT) :: dhat(:) INTEGER :: n,irc,i REAL(8), POINTER :: r(:) REAL(8), ALLOCATABLE :: den(:),a(:) REAL(8) :: h,con REAL(8) :: qr,jbes1,jbes2,dum1,dum2,al(2),ql(2) n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc ALLOCATE(den(n),a(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in hatL allocation',irc,i STOP ENDIF if (besselshapefunction) then call shapebes(al,ql,l,PAW%rc_shap) DO i=1,PAW%irc_shap qr=ql(1)*r(i);CALL jbessel(jbes1,dum1,dum2,0,0,qr) qr=ql(2)*r(i);CALL jbessel(jbes2,dum1,dum2,0,0,qr) den(i)=(al(1)*jbes1+al(2)*jbes2)*r(i)**2 ENDDO if (n>PAW%irc_shap) den(PAW%irc_shap+1:n)=0.d0 else DO i=1,n den(i)=(r(i)**l)*PAW%hatden(i) ENDDO a(1:n)=den(1:n)*(r(1:n)**l) con=integrator(Grid,a,1,PAW%irc_shap) den=den/con endif dhat=0 dhat(1:n)=den(1:n) DEALLOCATE(den,a) END SUBROUTINE hatL SUBROUTINE selfhatpot(Grid,PAW,l,eself) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(INOUT) :: PAW INTEGER, INTENT(IN) :: l REAL(8), INTENT(OUT) :: eself INTEGER :: n,irc,i REAL(8), POINTER :: r(:) REAL(8), ALLOCATABLE :: den(:),a(:) REAL(8) :: h,con REAL(8) :: qr,jbes1,jbes2,dum1,dum2,al(2),ql(2) n=Grid%n h=Grid%h r=>Grid%r irc=PAW%irc ALLOCATE(den(n),a(n),stat=i) IF (i/=0) THEN WRITE(6,*) 'Error in hatpotL allocation',irc,i STOP ENDIF if (besselshapefunction) then call shapebes(al,ql,l,PAW%rc_shap) DO i=1,PAW%irc_shap qr=ql(1)*r(i);CALL jbessel(jbes1,dum1,dum2,0,0,qr) qr=ql(2)*r(i);CALL jbessel(jbes2,dum1,dum2,0,0,qr) den(i)=(al(1)*jbes1+al(2)*jbes2)*r(i)**2 ENDDO if (n>PAW%irc_shap) den(PAW%irc_shap+1:n)=0.d0 else DO i=1,n den(i)=(r(i)**l)*PAW%hatden(i) ENDDO a(1:n)=den(1:n)*(r(1:n)**l) con=integrator(Grid,a,1,PAW%irc_shap) den=den/con endif a=0 CALL apoisson(Grid,l,n,den,a) ! apoisson returns a*r a(2:n)=a(2:n)/r(2:n) a(1)=0 eself=0.5d0*overlap(Grid,a,den) DEALLOCATE(den,a) END SUBROUTINE selfhatpot !***********************************************************************88 ! on input: f1(i) and f2(i) are radial wfn * r for angular momentum l ! on input: t1(i) and t2(i) are smooth radial wfn * r for angular momentum l ! for r > rc, f1=t1, f2=t2 ! on output: qqqq is difference overlap matrix element ! qqqq=- !***********************************************************************88 SUBROUTINE dqij(Grid,PAW,ib,ic,qqqq) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: ib,ic REAL(8), INTENT(OUT) :: qqqq INTEGER :: n,i,ok,irc REAL(8) :: h REAL(8), ALLOCATABLE :: dum(:) qqqq=0 IF (PAW%l(ib)/=PAW%l(ic)) RETURN n=Grid%n; h=Grid%h; irc=PAW%irc ALLOCATE(dum(n),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in dqij allocation', n,ok STOP ENDIF DO i=1,n dum(i)=PAW%ophi(i,ib)*PAW%ophi(i,ic)-PAW%otphi(i,ib)*PAW%otphi(i,ic) ENDDO qqqq=integrator(Grid,dum,1,irc) DEALLOCATE(dum) END SUBROUTINE dqij !*********************************************************************** ! SUBROUTINE dtij ! on input: f1(i) and f2(i) are radial wfn * r for angular momentum l ! on input: t1(i) and t2(i) are smooth radial wfn * r for angular momentum l ! for r > rc, f1=t1, f2=t2 ! on output: tij is difference kinetic energy matrix element in Rydberg units ! tij =- !************************************************************************ SUBROUTINE dtij(Grid,PAW,ib,ic,tij) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: ib,ic REAL(8), INTENT(OUT) :: tij INTEGER :: n,i,ok,l,irc REAL(8) :: angm REAL(8), POINTER :: r(:) REAL(8), ALLOCATABLE :: dum(:),del1(:),del2(:),tdel1(:),tdel2(:) tij=0 IF (PAW%l(ib)/=PAW%l(ic)) RETURN n=Grid%n; r=>Grid%r; l=PAW%l(ib); irc=PAW%irc ALLOCATE(dum(n),del1(n),tdel1(n),del2(n),tdel2(n),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in dtij allocation', n,ok STOP ENDIF CALL derivative(Grid,PAW%ophi(:,ib),del1) CALL derivative(Grid,PAW%ophi(:,ic),del2) CALL derivative(Grid,PAW%otphi(:,ib),tdel1) CALL derivative(Grid,PAW%otphi(:,ic),tdel2) dum=0 ; angm=l*(l+1) DO i=1,irc dum(i)=del1(i)*del2(i)-tdel1(i)*tdel2(i) ENDDO del1=0;del2=0;tdel1=0;tdel2=0 del1(2:irc)=PAW%ophi(2:irc,ib)/Grid%r(2:irc) del2(2:irc)=PAW%ophi(2:irc,ic)/Grid%r(2:irc) tdel1(2:irc)=PAW%otphi(2:irc,ib)/Grid%r(2:irc) tdel2(2:irc)=PAW%otphi(2:irc,ic)/Grid%r(2:irc) DO i=1,irc dum(i)=dum(i)+angm*(del1(i)*del2(i)-tdel1(i)*tdel2(i)) ENDDO tij=integrator(Grid,dum,1,irc) DEALLOCATE(dum,del1,del2,tdel1,tdel2) END SUBROUTINE dtij !*********************************************************************** ! SUBROUTINE altdtij ! on input: f1(i) and f2(i) are radial wfn * r for angular momentum l ! on input: t1(i) and t2(i) are smooth radial wfn * r for angular momentum l ! for r > rc, f1=t1, f2=t2 ! on output: tij is difference kinetic energy matrix element in Rydberg units ! tij =- !************************************************************************ SUBROUTINE altdtij(Grid,PAW,ib,ic,tij) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: ib,ic REAL(8), INTENT(OUT) :: tij INTEGER :: n,i,ok,l,irc REAL(8) :: angm REAL(8), POINTER :: r(:) REAL(8), ALLOCATABLE :: dum(:),tdel1(:),tdel2(:) tij=0 IF (PAW%l(ib)/=PAW%l(ic)) RETURN n=Grid%n; r=>Grid%r; l=PAW%l(ib); irc=PAW%irc ALLOCATE(dum(n),tdel1(n),tdel2(n),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in dtij allocation', n,ok STOP ENDIF dum=0 do i=2,irc !dum(i)=(PAW%eig(ic)-AEPot%rv(i)/Grid%r(i))*PAW%ophi(i,ib)*PAW%ophi(i,ic) dum(i)=PAW%ophi(i,ib)*PAW%Kop(i,ic) enddo CALL derivative(Grid,PAW%otphi(:,ic),tdel1) CALL derivative(Grid,tdel1,tdel2) angm=l*(l+1) DO i=2,irc dum(i)=dum(i)+PAW%otphi(i,ib)*(tdel2(i)-& angm*PAW%otphi(i,ic)/(Grid%r(i)**2)) ENDDO tij=integrator(Grid,dum,1,irc) DEALLOCATE(dum,tdel1,tdel2) END SUBROUTINE altdtij SUBROUTINE dvij(Grid,PAW,FC,nz,ib,ic,vij) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW TYPE(FCInfo), INTENT(IN) :: FC INTEGER, INTENT(IN) :: nz,ib,ic REAL(8), INTENT(OUT) :: vij INTEGER :: n,i,ok,irc REAL(8) :: h,en,q,qt REAL(8), ALLOCATABLE :: dum(:),d1(:) REAL(8), POINTER :: r(:) vij=0 IF (PAW%l(ib)/=PAW%l(ic)) RETURN n=Grid%n; h=Grid%h; r=>Grid%r; irc=PAW%irc ALLOCATE(dum(n),d1(n),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in dvij allocation', n,ok STOP ENDIF q=integrator(Grid,FC%coreden) WRITE(6,*) 'core electrons ',q,FC%zcore CALL poisson(Grid,q,FC%coreden,dum,en) dum=dum-2*nz qt=integrator(Grid,PAW%tcore) WRITE(6,*) 'coretail electrons ',qt CALL poisson(Grid,qt,PAW%tcore,d1,en) dum(1)=0 DO i=2,irc dum(i)=PAW%ophi(i,ib)*PAW%ophi(i,ic)*dum(i)/r(i)-& PAW%otphi(i,ib)*PAW%otphi(i,ic)*(PAW%vloc(i)+d1(i)/r(i)) ENDDO vij=integrator(Grid,dum,1,irc) DEALLOCATE(dum) END SUBROUTINE dvij !**************************************************************** ! SUBROUTINE avij -- potential part of Dij coefficients for ! estimating logderiv's !**************************************************************** SUBROUTINE avij(Grid,Pot,PAW,ib,ic,vij) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: ib,ic REAL(8), INTENT(OUT) :: vij INTEGER :: n,i,ok,irc REAL(8) :: h,en,q REAL(8), ALLOCATABLE :: dum(:) REAL(8), POINTER :: r(:) vij=0 IF (PAW%l(ib)/=PAW%l(ic)) RETURN n=Grid%n; h=Grid%h; r=>Grid%r; irc=PAW%irc ALLOCATE(dum(n),stat=ok) IF (ok /=0) THEN WRITE(6,*) 'Error in avij allocation', n,ok STOP ENDIF dum=0 DO i=2,n dum(i)=PAW%ophi(i,ib)*PAW%ophi(i,ic)*Pot%rv(i)/r(i)-& PAW%otphi(i,ib)*PAW%otphi(i,ic)*PAW%rveff(i)/r(i) ENDDO vij=integrator(Grid,dum,1,irc) DEALLOCATE(dum) END SUBROUTINE avij !******************************************************** ! SUBROUTINE calcwij ! subroutine to accumulate the wij coefficience for an input ! smooth wavefunction twfn and occupancy and l !******************************************************** SUBROUTINE calcwij(Grid,PAW,l,occ,twfn,wij) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PseudoInfo), INTENT(IN) :: PAW INTEGER, INTENT(IN) :: l REAL(8), INTENT(IN) :: twfn(:),occ REAL(8), INTENT(INOUT) :: wij(:,:) INTEGER :: n,i,ok,irc,ib,ic,nbase REAL(8) :: h REAL(8), ALLOCATABLE :: bm(:) n=Grid%n; h=Grid%h ; irc=PAW%irc nbase=PAW%nbase ALLOCATE(bm(nbase)) bm=0 DO ib=1,nbase IF (l==PAW%l(ib)) bm(ib)=overlap(Grid,PAW%otp(:,ib),twfn,1,irc) !IF (l==PAW%l(ib)) write(6,*) 'accum wij',l,ib,bm(ib) ENDDO DO ib=1,nbase DO ic=1,nbase wij(ib,ic)=wij(ib,ic) + occ*bm(ib)*bm(ic) ENDDO ENDDO DEALLOCATE(bm) END SUBROUTINE calcwij END MODULE pseudo ./src/radialsch.f900000644004704100470410000002550411202701404014073 0ustar natalienatalieMODULE radialsch USE GlobalMath USE gridmod USE atomdata USE calcpotential IMPLICIT NONE CONTAINS !******************************************************************* ! FUNCTION wfninit(nz,l,v0,v0p,energy,r) !******************************************************************* FUNCTION wfninit(nz,l,v0,v0p,energy,r) ! returns the solution of the Schroedinger equation near r=0 ! using power series expansion REAL(8) :: wfninit INTEGER, INTENT(IN) :: nz,l REAL(8), INTENT(IN) :: v0,v0p,energy,r REAL(8) :: c1,c2,c3 c1=-nz/(l+1.d0) c2=((v0-energy)-2*nz*c1)/(4*l+6.d0) c3=(v0p+(v0-energy)*c1-2*nz*c2)/(6*l+12.d0) wfninit=(r**(l+1))*(1+r*(c1+r*(c2+r*c3))) End function wfninit !********************************************************************** ! subroutine unboundsch(Grid,Pot,nr,l,energy,wfn,nodes) ! pgm to solve radial schroedinger equation for unbound states ! at energy 'energy' and at angular momentum l ! ! with potential rv/r, given in uniform mesh of n points ! r=i*h, i=1,...n-1 ;assuming p(r)=C*r**(l+1)*polynomial(r) for r==0; ! p((n+1)*h)=0 ! nz=nuclear charge ! ! uses Noumerov algorithm ! ! For l=0,1 corrections are needed to approximate wfn(r=0) ! These depend upon: ! e0 (current guess of energy eigenvalue) ! l,nz ! v(0) == v0 electronic potential at r=0 ! v'(0) == v0p derivative of electronic potential at r=0 ! ! also returns node == number of nodes for calculated state !************************************************************************ SUBROUTINE unboundsch(Grid,Pot,nr,l,energy,wfn,nodes) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot INTEGER, INTENT(IN) :: nr,l REAL(8), INTENT(IN) :: energy REAL(8), INTENT(INOUT) :: wfn(:) INTEGER, INTENT(INOUT) :: nodes INTEGER :: n,nz,i,j,k,ierr REAL(8) :: zeroval,scale n=Grid%n IF (nr > n) THEN WRITE(6,*) 'Error in unboundsch -- nr > n', nr,n STOP ENDIF ! initialize wfn wfn=0 wfn(2)=wfninit(Pot%nz,l,Pot%v0,Pot%v0p,energy,Grid%r(2)) zeroval=0 if (l==0) zeroval=-2*Pot%nz if (l==1) zeroval=2 call forward_numerov(Grid,l,nr,energy,Pot%rv,zeroval,wfn,nodes) ! ! normalize to unity within integration range ! scale=1.d0/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr) scale=SIGN(SQRT(scale),wfn(nr-2)) wfn(1:nr)=wfn(1:nr)*scale END SUBROUTINE unboundsch !****************************************************************** ! SUBROUTINE boundsch(Grid,Pot,Orbit,l,start,nroot,emin,ierr) !****************************************************************** SUBROUTINE boundsch(Grid,Pot,Orbit,l,start,nroot,emin,ierr) ! pgm to solve radial schroedinger equation for nroot bound state ! energies and wavefunctions for angular momentum l ! with potential rv/r, given in uniform mesh of n points ! r=i*h, i=1,...n-1 ;assuming p(r)=C*r**(l+1)*polynomial(r) for r==0; ! p((n+1)*h)=0 ! nz=nuclear charge ! emin=is estimate of lowest eigenvalue; used if nz=0 ! otherwise, set to the value of -(nz/(l+1))**2 ! ! It is assumed that the wavefunction has np-l-1 nodes, where ! np is the principle quantum number-- np=1,2,..nroot ! ! uses Noumerov algorithm ! ! For l=0,1 corrections are needed to approximate wfn(r=0) ! These depend upon: ! e0 (current guess of energy eigenvalue) ! l,nz ! v(0) == v0 electronic potential at r=0 ! v'(0) == v0p derivative of electronic potential at r=0 ! ! Corrections are also needed for r>n*h, depending on: ! e0 (current guess of energy eigenvalue ! the extrapolated value of rv == r * v ! ! ierr=an nroot digit number indicating status of each root ! a digit of 1 indicates success in converging root ! 2 indicates near success in converging root ! 9 indicates that root not found ! ! first check how many roots expected = ntroot (returned as argument) ! TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(OrbitInfo), INTENT(INOUT) :: Orbit INTEGER, INTENT(IN) :: l,start,nroot INTEGER, INTENT(INOUT) :: ierr REAL(8), INTENT(INOUT) :: emin REAL(8), PARAMETER :: convre=1.d-10,vlrg=1.d30 INTEGER, PARAMETER :: niter=1000 REAL(8), POINTER :: rv(:),eig(:),wfn(:,:) REAL(8), ALLOCATABLE :: p1(:),p2(:),dd(:) INTEGER :: nz,n REAL(8) :: h,v0,v0p REAL(8) :: err,convrez,energy,zeroval REAL(8) :: scale,emax,best,rout,ppp REAL(8) :: arg,r,r2,veff,pppp1,rin,dele,x,rvp1,pnp1,bnp1 INTEGER :: iter,i,j,k,node,match,mxroot,ntroot,ir,iroot INTEGER :: least,many,ifac LOGICAL :: ok n=Grid%n h=Grid%h wfn=>Orbit%wfn eig=>Orbit%eig ALLOCATE(p1(n),p2(n),dd(n),stat=i) IF (i/=0) THEN WRITE(6,*) ' Error in boundsch allocation ',i,n STOP ENDIF nz=Pot%nz v0=Pot%v0 v0p=Pot%v0p rv=>Pot%rv err=n*nz*(h**4) convrez=convre IF (nz.GT.0) convrez=convre*nz ! write(6,*) 'expected error = ',err ierr=0 WRITE(6,*) 'z , l = ',nz,l ! check how many roots expected by integration outward at ! energy = 0 energy = 0 ! ! start outward integration ! correct behavior near r=0 ! initialize wfn p1=0 p1(2)=wfninit(Pot%nz,l,Pot%v0,Pot%v0p,energy,Grid%r(2)) zeroval=0 if (l==0) zeroval=-2*Pot%nz if (l==1) zeroval=2 call forward_numerov(Grid,l,n,energy,Pot%rv,zeroval,p1,node) WRITE(6,*) ' nodes at e=0 ', node mxroot=node+1 ntroot=node IF (mxroot.LT.nroot) THEN WRITE(6,*)'error in boundsch - for l = ',l WRITE(6,*) nroot,' states requested but only',mxroot,' possible' DO ir=mxroot+1,nroot ierr=ierr+9*(10**(ir-1)) ENDDO ENDIF mxroot=min0(mxroot,nroot) ! IF (nz.EQ.0) energy=-ABS(emin) IF (nz.NE.0) energy=-(nz/(l+1.d0))**2 emin=energy-err emax=0.d0 DO iroot=1,mxroot best=1.d10; dele=1.d10 energy=emin+err IF (energy.LT.emin) energy=emin IF (energy.GT.emax) energy=emax ok=.FALSE. !write(6,*) 'iter,iroot,energy',iter,iroot,energy !write(6,*) 'emin,max',emin,emax BigIter: DO iter=1,niter !write(6,*) 'In iter with energy', iter,energy,niter,l,iroot ! start inward integration ! start integration at n ! find classical turning point call ClassicalTurningPoint(Grid,Pot,l,energy,match) match=max(5,match) match=min(n-15,match) x=0.5d0*(rv(n)/Grid%r(n)+rv(n-1)/Grid%r(n-1))+l*(l+1)/(Grid%r(n)**2) ppp=SQRT(ABS(x-energy)) p2=0 p2(n)=1 p2(n-1)=exp(-ppp*(Grid%r(n-1)-Grid%r(n))) call backward_numerov(Grid,l,match,energy,rv,p2) match=match+6 call derivative(Grid,p2,dd,match-5,match+5) rin=dd(match)/p2(match) ! write(6,*) ' match point = ',match,rin,p2(match) ! start outward integration ! correct behavior near r=0 ! initialize p1 p1=0 p1(2)=wfninit(Pot%nz,l,Pot%v0,Pot%v0p,energy,Grid%r(2)) zeroval=0 if (l==0) zeroval=-2*Pot%nz if (l==1) zeroval=2 call forward_numerov(Grid,l,match+6,energy,Pot%rv,zeroval,p1,node) call derivative(Grid,p1,dd,match-5,match+5) rout=dd(match)/p1(match) !write(6,*) 'node,match,rin,rout',node,(iroot-1),match,rin,rout ! check whether node = (iroot-1) ! not enough nodes -- raise energy IF (node.LT.iroot-1) THEN emin=MAX(emin,energy)-err energy=emax-(emax-energy)*ranx() ifac=9 ! too many nodes -- lower energy ELSEIF (node.GT.iroot-1) THEN IF (energy.LE.emin) THEN ierr=ierr+9*(10**(iroot-1)) WRITE(6,*) 'boundsch error -- emin too high',l,nz,emin,energy STOP ENDIF emax=MIN(emax,energy+err) energy=emin+(energy-emin)*ranx() ! correct number of nodes -- estimate correction ELSEIF (node.EQ.iroot-1) THEN DO j=1,match p1(j)=p1(j)/p1(match) !write(6,*) 'j,p1',j,p1(j) ENDDO DO j=match,n p1(j)=p2(j)/p2(match) !write(6,*) 'j,p2',j,p1(j) ENDDO scale=1.d0/overlap(Grid,p1,p1) dele=(rout-rin)*scale !write(6,*) 'energy,dele,scale',energy,dele,scale x=ABS(dele) IF (x.LT.best) THEN scale=SQRT(scale) p1(1:n)=p1(1:n)*scale k=start+iroot-1 wfn(1:n,k)=p1(1:n) eig(k)=energy !write(6,*) 'root',l,iroot,eig(k),emin,emax best=x ENDIF IF (ABS(dele).LE.convrez) THEN write(6,*) 'iter with dele' , iter,dele ok=.TRUE. ! eigenvalue found ierr=ierr+10**(iroot-1) IF (iroot+1.LE.mxroot) THEN emin=energy+err emax=0 energy=(emin+emax)/2 IF (energy.LT.emin) energy=emin IF (energy.GT.emax) energy=emax best=1.d10 ENDIF EXIT BigIter ENDIF IF (ABS(dele).GT.convrez) THEN !write(6,*) 'iter with dele' , iter,dele energy=energy+dele ! if energy is out of range, pick random energy in correct range IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) & energy=emin+(emax-emin)*ranx() ifac=2 !write(6,*) 'continuing with iter dele', iter,dele ENDIF ENDIF ENDDO BigIter !iter IF (.NOT.ok) THEN ierr=ierr+ifac*(10**(iroot-1)) WRITE(6,*) 'no convergence in boundsch',iroot,l,dele,energy WRITE(6,*) ' best guess of eig, dele = ',eig(start+iroot-1),best IF (iroot.LT.mxroot) THEN DO ir=iroot+1,mxroot ierr=ierr+9*(10**(ir-1)) ENDDO ENDIF ! reset wfn with hydrogenic form k=start+iroot-1; j=iroot+l+1 wfn(:,k)=0 ppp=(j)*sqrt(abs(eig(start+iroot-1))) do i=2,n wfn(i,k)=hwfn(ppp,j,l,Grid%r(i)) enddo ENDIF ENDDO !iroot DEALLOCATE(p1,p2,dd) write(6,*) 'returning from boundsch -- ierr=',ierr END SUBROUTINE Boundsch END MODULE radialsch ./src/radialsr.f900000644004704100470410000004332611202701404013744 0ustar natalienatalie!***************************************************************** ! Module for solving scalar relativistic radial equations ! Uses program adapted by Marc Torrent and Francois Jollet from ! USPS pgm of David Vanderbilt based on two coupled first order ! differential equations ! Previous version, based on second order differential equation ! from formalism of Shadwick, Talman, and Norman, Comp. Phys. Comm. ! 54, 95-102 (1989) found to be unstable ! 09-16-06 NAWH !***************************************************************** MODULE radialsr USE GlobalMath USE gridmod USE atomdata USE calcpotential IMPLICIT NONE REAL(8), parameter :: inverse_fine_structure=137.03599911d0 Real(8), private :: gamma,c1,c2,MA,MB Real(8), private, allocatable :: ww(:),jj(:) ! jj stores (r+(alpha/2)**2*(E*r-rv) == r*M(r) ! ww stores kappa*(kappa+1)/(r**2*M(r)) - (E - V(r)) CONTAINS !****************************************************************** ! Allocate_scalar_relativistic !****************************************************************** Subroutine Allocate_scalar_relativistic(Grid) Type(GridInfo), INTENT(IN) :: Grid INTEGER :: n,i n=Grid%n allocate(ww(n),jj(n), stat=i) if (i/=0) then write(6,*) 'Allocate_scalar_relativistic: error in allocation ',& i,n stop endif End subroutine Allocate_scalar_relativistic !****************************************************************** ! Deallocate_scalar_relativistic !****************************************************************** Subroutine deallocate_scalar_relativistic deallocate(ww,jj) end subroutine deallocate_scalar_relativistic !******************************************************************* ! Subroutine Azeroexpand(Grid,Pot,l,energy) ! If finitenucleus==.true. assumes potential for r--> has form ! -2*Z*erf(r/RR)/r, where RR is a nuclear size parameter ! Otherwise, assumes nuclear potential is -2*Z/r !******************************************************************* Subroutine Azeroexpand(Grid,Pot,l,energy,nr) Type(GridInfo), INTENT(IN) :: Grid Type(PotentialInfo), INTENT(IN) :: Pot Integer, INTENT(IN) :: l Real(8), INTENT(IN) :: energy Integer, optional, INTENT(IN) :: nr Integer :: i,j,k,n,nz Real(8) :: xx,yy,angm,alpha2,balpha2 n=Grid%n if (present(nr)) n=min(n,nr) nz=Pot%nz ww=0; jj=0; balpha2=inverse_fine_structure**2 alpha2=1.d0/balpha2 !write(6,*) 'in Azeroexpand', alpha2,nz,n jj(1:n)=(Grid%r(1:n) + & 0.25d0*alpha2*(energy*Grid%r(1:n)-Pot%rv(1:n))) angm=l*(l+1) ww(2:n)=(Pot%rv(2:n)/Grid%r(2:n)-energy) & + angm/(Grid%r(2:n)*jj(2:n)) ww(1)=0 !do i=1,n !write(101,'(i5,1p8e15.7)') i,Grid%r(i),jj(i),ww(i) !enddo !stop if (.not.finitenucleus) then gamma=sqrt(angm+1.d0-alpha2*nz**2) c1=-((2.d0*balpha2)/(nz*(2*gamma+1)))*((1-gamma)*& (1+0.25d0*alpha2*(energy-Pot%v0))+alpha2*nz**2+& 0.5d0*((nz*alpha2)**2)*(energy-Pot%v0)) xx=2*nz*(1+alpha2*(energy-Pot%v0)+3*(0.25*alpha2*(energy-Pot%v0))**2)& +0.25d0*alpha2*Pot%v0p*(alpha2*nz*nz+2*(gamma-1)) yy=(1+gamma)*(1+0.25d0*alpha2*(energy-Pot%v0))+alpha2*nz*nz+& 0.5d0*((alpha2*nz)**2)*(energy-Pot%v0) c2=-(xx+yy*c1)/(2*(gamma+1)*alpha2*nz) !write(6,*) 'Azeroexpand: ', gamma,c1,c2 MA=0; MB=0 else ! version for finite nuclear size gamma=0 MA=1.d0+0.25d0*alpha2*(energy-Pot%v0) MB=0.25d0*alpha2*Pot%v0p c1=-MB*l/(2*MA*(l+1)) c2=(-MA*MA*(energy-Pot%v0)*MB*c1*(l+1))/(MA*(4*l+6)) endif ! do i=2,n ! write(97,'(1p5e15.7)') Grid%r(i),Pot%rv(i)/Grid%r(i),ww(i),jj(i)/Grid%r(i) ! enddo end subroutine Azeroexpand !******************************************************************* ! SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart) !******************************************************************* SUBROUTINE wfnsrinit(Grid,l,wfn,lwfn,istart) ! returns the solution of the scalar relativistic equations near r=0 ! using power series expansion Type(GridInfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: l REAL(8),INTENT(INOUT) :: wfn(:),lwfn(:) INTEGER, INTENT(OUT) :: istart REAL(8) :: rr,M INTEGER :: i,j,n wfn=0; lwfn=0 istart=6 do i=1,istart rr=Grid%r(i+1) if (.not.finitenucleus) then wfn(i+1)=1+rr*(c1+rr*c2) lwfn(i+1)=(gamma-1)+rr*(c1*gamma+rr*c2*(gamma+1)) wfn(i+1)=wfn(i+1)*(rr**gamma) lwfn(i+1)=lwfn(i+1)*(rr**gamma)/jj(i+1) else ! finite nucleus case M=MA-MB*rr wfn(i+1)=(1+rr*(c1+rr*c2))*(rr**(l+1)) lwfn(i+1)=(l+rr*((l+1)*c1+rr*(l+2)*c2))*(rr**(l+1))/M endif !write(6,'(i5,1p3e15.7)') i+1,rr,wfn(i+1),lwfn(i+1) enddo End SUBROUTINE wfnsrinit subroutine wfnsrasym(Grid,wfn,lwfn,energy,iend) ! returns the solution of the scalar relativistic equations near r=inf ! using exp(-x*r) for upper component Type(GridInfo), INTENT(IN) :: Grid REAL(8),INTENT(INOUT) :: wfn(:),lwfn(:) REAL(8), INTENT(IN) :: energy INTEGER, INTENT(OUT) :: iend REAL(8) :: rr,x,m INTEGER :: i,j,n if (energy>0.d0) then write(6,*) 'Error in wfnsrasym -- energy > 0', energy stop endif wfn=0; lwfn=0 n=Grid%n m=1+0.25d0*energy/(inverse_fine_structure**2) x=sqrt(-m*energy) !write(6,*) ' in wfnsrasym with x = ',x iend=5 do i=n-iend,n wfn(i)=exp(-x*(Grid%r(i)-Grid%r(n-iend))) lwfn(i)=-wfn(i)*(x+1.d0/Grid%r(i))/m enddo end subroutine wfnsrasym !********************************************************************** ! subroutine unboundsr(Grid,Pot,nr,l,energy,wfn,nodes) ! pgm to solve radial scalar relativistic equation for unbound states ! at energy 'energy' and at angular momentum l ! ! with potential rv/r, given in uniform linear or log mesh of n points ! assuming p(r)=C*r**(l+1)*polynomial(r) for r==0; ! ! nz=nuclear charge ! ! Does not use Noumerov algorithm -- but uses coupled first-order ! equations from David Vanderbilt, Marc Torrent, and Francois Jollet ! ! also returns node == number of nodes for calculated state !************************************************************************ SUBROUTINE unboundsr(Grid,Pot,nr,l,energy,wfn,nodes) TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot INTEGER, INTENT(IN) :: nr,l REAL(8), INTENT(IN) :: energy REAL(8), INTENT(INOUT) :: wfn(:) INTEGER, INTENT(INOUT) :: nodes INTEGER :: n,nz,i,j,k,ierr,istart REAL(8) :: scale REAL(8), allocatable :: lwfn(:),zz(:,:,:),yy(:,:) n=Grid%n IF (nr > n) THEN WRITE(6,*) 'Error in unboundsr -- nr > n', nr,n STOP ENDIF call Azeroexpand(Grid,Pot,l,energy,nr) allocate(lwfn(nr),zz(2,2,nr),yy(2,nr),stat=ierr) if (ierr/=0) then write(6,*) ' allocation error in unboundsr ', nr,ierr stop endif lwfn=0;zz=0;yy=0; call wfnsrinit(Grid,l,wfn,lwfn,istart) call prepareforcfdsol(Grid,1,istart,nr,wfn,lwfn,yy,zz) call cfdsol(Grid,zz,yy,istart,nr) call getwfnfromcfdsol(1,nr,yy,wfn) call countnodes(1,nr,wfn,nodes) ! ! normalize to unity within integration range ! call filter(nr,wfn,machine_zero) scale=1.d0/overlap(Grid,wfn(1:nr),wfn(1:nr),1,nr) scale=SIGN(SQRT(scale),wfn(nr-2)) wfn(1:nr)=wfn(1:nr)*scale deallocate(lwfn,yy,zz) END SUBROUTINE unboundsr !****************************************************************** ! SUBROUTINE boundsr(Grid,Pot,Orbit,l,start,nroot,emin,ierr) !****************************************************************** SUBROUTINE boundsr(Grid,Pot,Orbit,l,start,nroot,emin,ierr) ! pgm to solve radial scalar relativistic equation for nroot bound state ! energies and wavefunctions for angular momentum l ! with potential rv/r, given in uniform linear or log mesh of n points ! nz=nuclear charge ! emin=is estimate of lowest eigenvalue; used if nz=0 ! otherwise, set to the value of -(nz/(l+1))**2 ! ! It is assumed that the wavefunction has np-l-1 nodes, where ! np is the principle quantum number-- np=1,2,..nroot ! ! Does not use Noumerov algorithm -- but uses coupled first-order ! equations from David Vanderbilt, Marc Torrent, and Francois Jollet ! ! Corrections are also needed for r>n*h, depending on: ! e0 (current guess of energy eigenvalue ! the extrapolated value of rv == r * v ! ! ierr=an nroot digit number indicating status of each root ! a digit of 1 indicates success in converging root ! 2 indicates near success in converging root ! 9 indicates that root not found ! ! first check how many roots expected = ntroot (returned as argument) ! TYPE(GridInfo), INTENT(IN) :: Grid TYPE(PotentialInfo), INTENT(IN) :: Pot TYPE(OrbitInfo), INTENT(INOUT) :: Orbit INTEGER, INTENT(IN) :: l,start,nroot INTEGER, INTENT(INOUT) :: ierr REAL(8), INTENT(INOUT) :: emin REAL(8), PARAMETER :: convre=1.d-10,vlrg=1.d30 INTEGER, PARAMETER :: niter=1000 REAL(8), POINTER :: rv(:),eig(:),wfn(:,:) REAL(8), ALLOCATABLE :: p1(:),p2(:),dd(:) INTEGER :: nz,n REAL(8) :: h,v0,v0p REAL(8) :: err,convrez,energy,zeroval REAL(8) :: scale,emax,best,rout REAL(8) :: arg,r,r2,veff,pppp1,rin,dele,x,rvp1,pnp1,bnp1 INTEGER :: iter,i,j,k,node,match,mxroot,ntroot,ir,iroot INTEGER :: least,many,ifac,istart,iend LOGICAL :: ok REAL(8), allocatable :: lwfn(:),zz(:,:,:),yy(:,:) ! integer :: icount=0 n=Grid%n h=Grid%h wfn=>Orbit%wfn eig=>Orbit%eig ALLOCATE(p1(n),p2(n),dd(n),stat=i) IF (i/=0) THEN WRITE(6,*) ' Error in boundsr allocation ',i,n STOP ENDIF allocate(lwfn(n),zz(2,2,n),yy(2,n),stat=i) if (i/=0) then write(6,*) ' allocation error in boundsr ', n,i stop endif nz=Pot%nz v0=Pot%v0 v0p=Pot%v0p rv=>Pot%rv err=n*nz*(h**4) convrez=convre IF (nz.GT.0) convrez=convre*nz ! write(6,*) 'expected error = ',err ierr=0 WRITE(6,*) 'z , l = ',nz,l ! check how many roots expected by integration outward at ! energy = 0 energy = 0 call Azeroexpand(Grid,Pot,l,energy) lwfn=0;zz=0;yy=0; call wfnsrinit(Grid,l,p1,lwfn,istart) !do i=1,istart ! write(6,'(1p2e15.7)') Grid%r(i),p1(i) !enddo ! ! start outward integration call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz) call cfdsol(Grid,zz,yy,istart,n) call getwfnfromcfdsol(1,n,yy,p1) call countnodes(1,n,p1,node) WRITE(6,*) ' nodes at e=0 ', node !do i=1,n ! write(6,'(1p4e15.7)') Grid%r(i),p1(i),jj(i),ww(i) !enddo mxroot=node+1 ntroot=node IF (mxroot.LT.nroot) THEN WRITE(6,*)'error in boundsr - for l = ',l WRITE(6,*) nroot,' states requested but only',mxroot,' possible' DO ir=mxroot+1,nroot ierr=ierr+9*(10**(ir-1)) ENDDO ENDIF mxroot=min0(mxroot,nroot) ! IF (nz.EQ.0) energy=-ABS(emin) IF (nz.NE.0) energy=-1.1d0*(nz/(l+1.d0))**2 emin=energy-err emax=0.d0 DO iroot=1,mxroot best=1.d10; dele=1.d10 energy=emin+err IF (energy.LT.emin) energy=emin IF (energy.GT.emax) energy=emax ok=.FALSE. !write(6,*) 'iter,iroot,energy',iter,iroot,energy !write(6,*) 'emin,max',emin,emax BigIter: DO iter=1,niter !write(6,*) 'In iter with energy', iter,energy,niter,l,iroot ! start inward integration ! start integration at n call Azeroexpand(Grid,Pot,l,energy) ! find classical turning point call ClassicalTurningPoint(Grid,Pot,l,energy,match) match=max(match,10); match=min(match,n-20) call wfnsrasym(Grid,p2,lwfn,energy,iend) call prepareforcfdsol(Grid,n-iend,n,n,p2,lwfn,yy,zz) call cfdsol(Grid,zz,yy,n-iend,match) call getwfnfromcfdsol(match,n,yy,p2) match=match+6 rin=Gfirstderiv(Grid,match,p2)/p2(match) call wfnsrinit(Grid,l,p1,lwfn,istart) call prepareforcfdsol(Grid,1,istart,n,p1,lwfn,yy,zz) call cfdsol(Grid,zz,yy,istart,match+6) call getwfnfromcfdsol(1,match+6,yy,p1) call countnodes(1,match+6,p1,node) !icount=icount+1 ! do i=1,match+6 ! write(100+icount,'(1P2e15.7)') Grid%r(i),p1(i) ! enddo rout=Gfirstderiv(Grid,match,p1)/p1(match) ! write(6,*) 'node,match,rin,rout',node,(iroot-1),match,rin,rout ! check whether node = (iroot-1) ! not enough nodes -- raise energy IF (node.LT.iroot-1) THEN emin=MAX(emin,energy)-err energy=emax-(emax-energy)*ranx() ifac=9 ! too many nodes -- lower energy ELSEIF (node.GT.iroot-1) THEN IF (energy.LE.emin) THEN ierr=ierr+9*(10**(iroot-1)) WRITE(6,*) 'boundsr error -- emin too high',l,nz,emin,energy do i=2,n write(999,'(1p4e15.7)') Grid%r(i),jj(i)/Grid%r(i),ww(i),Pot%rv(i) enddo STOP ENDIF emax=MIN(emax,energy+err) energy=emin+(energy-emin)*ranx() ! correct number of nodes -- estimate correction ELSEIF (node.EQ.iroot-1) THEN DO j=1,match p1(j)=p1(j)/p1(match) !write(6,*) 'j,p1',j,p1(j) ENDDO DO j=match,n p1(j)=p2(j)/p2(match) !write(6,*) 'j,p2',j,p1(j) ENDDO scale=1.d0/overlap(Grid,p1,p1) dele=(rout-rin)*scale !write(6,*) 'energy,dele,scale',energy,dele,scale x=ABS(dele) IF (x.LT.best) THEN scale=SQRT(scale) p1(1:n)=p1(1:n)*scale k=start+iroot-1 call filter(n,p1,machine_zero) wfn(1:n,k)=p1(1:n) eig(k)=energy !write(6,*) 'root',l,iroot,eig(k),emin,emax best=x ENDIF IF (ABS(dele).LE.convrez) THEN !write(6,*) 'iter with dele' , iter,dele ok=.TRUE. ! eigenvalue found ierr=ierr+10**(iroot-1) IF (iroot+1.LE.mxroot) THEN emin=energy+err emax=0 energy=(emin+emax)/2 IF (energy.LT.emin) energy=emin IF (energy.GT.emax) energy=emax best=1.d10 ENDIF EXIT BigIter ENDIF IF (ABS(dele).GT.convrez) THEN !write(6,*) 'iter with dele' , iter,dele energy=energy+dele ! if energy is out of range, pick random energy in correct range IF (emin-energy.GT.convrez.OR.energy-emax.GT.convrez) & energy=emin+(emax-emin)*ranx() ifac=2 !write(6,*) 'continuing with iter dele', iter,dele ENDIF ENDIF ENDDO BigIter !iter IF (.NOT.ok) THEN ierr=ierr+ifac*(10**(iroot-1)) WRITE(6,*) 'no convergence in boundsr',iroot,l,dele,energy WRITE(6,*) ' best guess of eig, dele = ',eig(start+iroot-1),best IF (iroot.LT.mxroot) THEN DO ir=iroot+1,mxroot ierr=ierr+9*(10**(ir-1)) ENDDO ENDIF ! reset wfn with hydrogenic form k=start+iroot-1; j=iroot+l+1 wfn(:,k)=0 x=(j)*sqrt(abs(eig(start+iroot-1))) do i=2,n wfn(i,k)=hwfn(x,j,l,Grid%r(i)) enddo ENDIF ENDDO !iroot ! icount=icount+1 ! do i=1,n ! write(100+icount,'(1p25e15.6)') Grid%r(i),(wfn(i,j),j=start,start+nroot) ! enddo DEALLOCATE(p1,p2,dd,lwfn,yy,zz) write(6,*) 'returning from boundsr -- ierr=',ierr END SUBROUTINE Boundsr subroutine scalarrelativisticturningpt(Grid,least,turningpoint) Type(GridInfo), INTENT(IN) :: Grid Integer, INTENT(IN) :: least Integer, INTENT(OUT) :: turningpoint integer :: i,n n=Grid%n turningpoint=n do i=n,least,-1 if (ww(i)<0.d0) exit enddo turningpoint=i !write(6,*) 'Found turning point at ', turningpoint, Grid%r(turningpoint) End subroutine scalarrelativisticturningpt subroutine prepareforcfdsol(Grid,i1,i2,n,wfn,lwfn,yy,zz) Type(gridinfo), INTENT(IN) :: Grid INTEGER, INTENT(IN) :: i1,i2,n REAL(8), INTENT(IN) :: wfn(:),lwfn(:) REAL(8), INTENT(OUT) :: yy(:,:),zz(:,:,:) INTEGER :: i yy=0;zz=0 yy(1,i1:i2)=wfn(i1:i2) yy(2,i1:i2)=lwfn(i1:i2) do i=2,n zz(1,1,i)=1.d0/Grid%r(i) zz(1,2,i)=jj(i)/Grid%r(i) zz(2,2,i)=-1.d0/Grid%r(i) zz(2,1,i)=ww(i) enddo end subroutine prepareforcfdsol subroutine countnodes(start,finish,wfn,nodes) INTEGER, INTENT(IN) :: start,finish REAL(8), INTENT(IN) :: wfn(:) INTEGER, INTENT(OUT) :: nodes INTEGER :: i nodes=0 do i=start+1,finish if (wfn(i)*wfn(i-1)<0.d0) nodes=nodes+1 enddo end subroutine countnodes subroutine getwfnfromcfdsol(start,finish,yy,wfn) INTEGER, INTENT(IN) :: start,finish REAL(8), INTENT(IN) :: yy(:,:) REAL(8), INTENT(INOUT) :: wfn(:) INTEGER :: i wfn=0 do i=start,finish wfn(i)=yy(1,i) enddo end subroutine getwfnfromcfdsol END MODULE radialsr ./src/README0000644004704100470410000004042511202701404012500 0ustar natalienatalie04-30-04 Revised atompaw to use modern Fortran 90 structures and to allow for new scheme for constructing Vloc (see NewatompawNotes.tex, NewatompawNotes.pdf) To compile: makescript [compiler] atompaw where [compiler] references a make.[compiler] file that you can construct for your system. Sample files are given for make.intel, make.absort, make.sun, etc. To run: input is now more amenable to interactive input. Two examples are given below --------------------C using old Vloc form-----------------------start--- C 6 Atomic symbol and # 'LDA-PW' Exchange correlation type 2 2 0 0 0 0 max n for s p d f g h 2 1 2 n l occ for corrected shell 0 0 0 end of shell corrections c core v valence v valence 2 maximum l for projectors 1.3 rc (+0.01 will be added) n no new s projectors and basis functions n no new p projectors and basis functions y new d projector and basis function 0.0 energy of d projector and basis function n no new d projectors and basis functions VSHAPE use VSHAPE 1 use function #1 (2s in this case) for Vloc --------------------C using old Vloc form-----------------------end----- --------------------C using new Vloc from norm-conserving form--start--- C 6 Atomic symbol and # 'LDA-PW' Exchange correlation type 2 2 0 0 0 0 max n for s p d f g h 2 1 2 n l occ for corrected shell 0 0 0 end of shell corrections c core v valence v valence 1 maximum l for projectors 1.3 rc (+0.01 will be added) n no new s projectors and basis functions n no new p projectors and basis functions VNCF use VNCF EXPF use exponential form 2 0.0 l and energy for norm-conserving potential 4 5 6 7 powers of polynomial --------------------C using new Vloc from norm-conserving form--end----- -----------------Older history--------------------------------------- Modifications 8-25-01 -- Changed the Broyden iteration scheme with an Anderson Mixing module similar to that used in pwpaw. 8-25-01 -- Replaced the exchange-correlation module with one that can either calculate the LDA (Perdew-Wang) or GGA (Perdew-Burke-Ernzerhof) as contolled by the keywords 'LDA-PW' or 'GGA-PBE', respectively. Currently, only those keywords work properly. Other LDA or GGA forms could easily be added. An an example new input file for C is given by: -------------------C.input------------------------------------------ C Atom summary file name 6 'GGA-PBE' Z 2 2 0 0 0 maximum n for s, p, d, f, g shells 2 1 2 correction to maximum occupancy (n l occ) 0 0 0 end corrections c core state v valence state v valence state vloc0 Specify non-zero vloc amplitude 9.7874329E+00 value of vloc amplitude ipass use default parameters 1 lmax 1.3 rc n no new l=0 bases functions n no new l=1 basis functions C Atom symbol c continue 2 new valence occupancy 2 new valence occupancy c continue 1 new valence occupancy 3 new valence occupancy e exit -----------------end------------------------------------------------- 8-25-01 -- Version tested in ~/pgmwork/atompawwithatompaw 11-05-01 -- Corrected Cp solver in bsolvtphi -- converges for more cases 12-12-01 -- Corrected infinite loop problem in fcsepatom 12-13-01 -- Replaced density convergence test with criterion based on onset of fluctuations 01-08-02 -- corrected small error in fcsepatom.f90 05-09-02 -- Made minor change to excorpbe.f90 in order to make the gradient term more stable following suggestion of Ryan Hatcher and also added symmetrization of VHartree terms following email discussion with Francois Jollet 08-03-02 -- Made minor change to frozencore pgm; simplified output to report only total energies and differences between total energies; fixed bug to allow calculation of configurations with zero valence electrons 10-27-02 -- Changed TPHI output for LCAO functions to ensure finite range. Each TPHI is modified within the range 6 < r < 10 bohr according to ( sin(Pi*(r-rstart)/delta) )^2 TPHI(r)*(--------------------------) ( (Pi*(r-rstart)/delta) ) where rstart=6, delta=rend-rstart, rend=10. Note that the TPHI functions are not normalized. 01-10-03 -- Changed ftprod.f90 to reflect TPHI truncation. Also introduced slight changes to make code compatible with absoft compiler. 07-09-03 -- Changes by Francois Jollet and Marc Torrent for compatibility with Abinit code. Also made the calculation of vlocfac automatic for setting it for aligning the valence s orbital as the local potential. (If input sets |vlocfac| > 10^-7, the set value is kept.) Additional programing changes to gradually "modernize" the code were made, but since this is a very daunting task, we quit before breaking something..... 08-05-03 -- Tested code with intel 7.1 compiler, using ATLAS http://math-atlas.sourceforge.net/ library for blas. Compilation with intel or absoft facilitated with script: makescript (intel or absoft) (atompaw or frozencore or clean) Need to edit make.intel or make.absoft files for proper library locations and compiler flags. 07-13-04 -- "Modernized" program structure and introduced new options for vloc based on norm-conserving pseudopotential for l > lmax (largest l for projectors). 10-20-04 -- minor improvement to GGA algorithm 12-31-04 -- introduced core tail function to take into account frozen core density which extends beyond rc 01-03-05 -- implemented PAW-XML output according to the fsatom-pp@tddft.org project http://www.fysik.dtu.dk/campos/atomic_setup/paw_setup.html 01-08-05 -- using Alan Tackett's xmlword.f90 and xmlstrings.f90 wrote xmlpaw.f90 to scan [atom].xml file and create [atom].atomicdata.fromxml file which compares very closely to original [atom].atomicdata file 09-13-05 -- Found slight error in pseudo.f90 in character length of PAW%Vloc_description (should be 256). Also note that some compilers differ enough to change the the value of PAW%irc by +- 2, which seems not to make a significant difference in the end results. 12-20-05 -- Implemented option to construct basis and projector functions based on David Vanderbilt's ultra-soft pseudopotential paper PRB 41, 7892 (1990) Requires input of r_i < r_c for each basis function. 01-17-06 -- Corrected XLM output for kinetic energy to be Hartree Units (Thanks to Marc Torrent) 01-22-06 -- Added VLOCION output to atomicdata file -- form of ionic local potential needed by abinit, not used by pwpaw 01-23-06 -- Added INITOCC output to atomicdata file -- used by abinit, perhaps could be used by pwpaw; indicates initial occupancies of valence basis functions 04-21-06 -- Noticed that atomicdata file contains spurious values of Hartree matrix elements; these have now been removed. 05-22-06 -- Revised pgm to accept either linear grid (default) or logarithmic grid (need to add keyword to second input line in quotes for example: 'PW-LDA loggrid' or 'PBE-GGA loggrid') Grid parameters are hard coded -- may need to be adjusted. 06-10-06 -- worked with Marc Torrent to validate Atompaw2abinit interface and allowed for optional input of number of grid points. Thus the second line of the code can read PW-LDA loggrid 1001 for example if 1001 loggrid points are desired. For a linear grid, the input is as before and the number of points is fixed. 06-14-06 -- Corrected xml portion to be consistent with FSATOM standard on website http://dcwww.camp.dtu.dk/campos//pawxml/pawxml.xhtml Note: consequent line lengths too long for absoft compiler Also note that in order to output input data to xml file, pgm takes an input argument of the input file name. For example if the input file is called Fe.input, the call would be atompaw Fe.input&output& Note: the xml reading routines have not be updated. 06-29-06 -- Implemented possibility of scalarrelativistic treatment, following the second order form the Dirac equation given by Shadwick, Talman, and Normand, Comp. Phys. Comm. 54 95-102 (1989), averaging over kappa for a given l. In this case the second input line would read PW-LDA loggrid 1001 scalarrelativistic It is not advisable to use a linear grid for the scalarrelativistic case. Also note that at the moment, there is no adjustment to the exchange functional for relativistic effects. 07-05-06 -- Corrected several bugs thanks to Marc Torrent 07-07-06 -- Several corrections from Jens jorgen Mortensen and Marc Torrent; added capability to use Gaussian shape for compensation charge as suggested by Peter Bloechl (see comments at the beginning of atompaw.f90). Simplified keywords and options according to preferred schemes, however, old keywords still work. 08-30-06 -- Added new code for additional options written by Marc Torrent. 09-04-06 -- With Xiao Xu's help, found error in scalarrelativistic mode with GGA, although LDA gives reasonable results. Because of the sensitivity of the GGA to gradients of the density, the GGA option is currently disabled for the scalarrelativistic mode. 09-05-06 -- Introduced output for single-center self-energy estimate to be used in pwpaw from [atom].scself 09-18-06 -- Corrected BUG in GGA equations for vxc found by Marc Torrent. Also replaced scalar-relativistic solver with program adapted by Marc Torrent and Francois Jollet from USPS pgm of David Vanderbilt based on two coupled first order differential equations. Previous version, based on second order differential equation from formalism of Shadwick, Talman, and Norman, Comp. Phys. Comm. 54, 95-102 (1989) found to be unstable. Even with the new code, we find it necessary to use a low-order derivative formula -- "simplederiv" to evaluate the gradients for GGA in the scalarrelativistic mode. 09-26-06 -- Introduced option for scalar-relativistic mode for replacing point nucleus with a Gaussian. Effectively replacing the nuclear potential of 2*Z/r with 2*Z*erf(r/R)/r, where the size parameter R in bohr units is given by 2.9*10^(-5)*Z^(1/3), as given by a simple nuclear model in old texts. This option is activated with "finite-nucleus" keyword. For this to work, it is necessary to choose an adequate number of grid points within the finite nucleus. 10-14-06 -- Improved stability of boundsch and boundsr following problem identified by Ping Tang. When solver fails wavefunction is replaced by a suitable hydrogen-like solution. This does not always help. For the case of Mn in the 3d7 4s0 configuration, the calculation fails with a linear grid, but works well with the logarithmic grid. 11-30-06 -- Many new options introduced by Marc Torrent. 12-13-06 -- NAWH corrected bug found by Marc Torrent which effects charged ions. Pgm should now work for charged ions. 12-21-06 -- Marc Torrent & NAWH completed testing (of course there always may be more bugs). This version is designated as version 2.0. 02-16-07 -- Corrected problem for Vanderbilt-style projectors with pseudowavefunction rcl