- makefile update after yesterday changes

- variable "ishybrid" added to Modules/funct.f90 to manage hybrid functionals
- duplicated subroutines in upftools/nclib.f90 removed


git-svn-id: http://qeforge.qe-forge.org/svn/q-e/trunk/espresso@2095 c92efa57-630b-4861-b058-cf58834340f0

CPV/read_pseudo.f90

@@ -185,7 +185,7 @@ END FUNCTION calculate_dx
       use ions_base, only: nsp
       use read_pseudo_module, only: read_pseudo_upf
       use control_flags, only: program_name, tuspp
-      use funct, only: iexch, icorr, igcx, igcc, dft, which_dft
+      use funct, only: iexch, icorr, igcx, igcc, dft, which_dft, ishybrid
 
       IMPLICIT NONE
 
@@ -360,6 +360,9 @@ END FUNCTION calculate_dx
           !
           dft = TRIM( xc_type )
           CALL which_dft( dft )
+          IF ( ishybrid ) &
+             CALL errore( 'readpp', 'HYBRID XC not implemented in CPV', 1 )
+
           WRITE( stdout, fmt="(/,3X,'Warning XC functionals forced to be: ',A)" ) dft
           !
         else
@@ -750,7 +753,7 @@ subroutine upf2internal ( upf, is, ierr )
                    lll, nbeta, kkbeta,  nqlc, nqf, betar, dion, tvanp
   use atom, only: chi, lchi, nchi, rho_atc, r, rab, mesh, nlcc, numeric
   use ions_base, only: zv
-  use funct, only: dft, which_dft
+  use funct, only: dft, which_dft, ishybrid
   !
   use pseudo_types
   !
@@ -772,6 +775,9 @@ subroutine upf2internal ( upf, is, ierr )
   !
   dft = upf%dft
   call which_dft( upf%dft )
+  IF ( ishybrid ) &
+     CALL errore( 'read_pseudo', 'HYBRID XC not implemented in CPV', 1 )
+
   !
   mesh(is) = upf%mesh
   if (mesh(is) > ndmx ) call errore('read_pseudo','increase mmaxx',mesh(is))
@@ -840,7 +846,7 @@ subroutine ncpp2internal ( ap, is, xc_type, ierr )
                    lll, nbeta, kkbeta,  nqlc, nqf, betar, dion, tvanp
   use atom, only: chi, lchi, nchi, rho_atc, r, rab, mesh, nlcc, numeric
   use ions_base, only: zv
-  use funct, only: dft, which_dft
+  use funct, only: dft, which_dft, ishybrid
   !
   use pseudo_types
   !
@@ -869,6 +875,9 @@ subroutine ncpp2internal ( ap, is, xc_type, ierr )
   !
   dft = TRIM( xc_type )
   call which_dft( TRIM( xc_type ) )
+  IF ( ishybrid ) &
+     CALL errore( 'read_pseudo', 'HYBRID XC not implemented in CPV', 1 )
+
   !
   !
   lchi( 1 : ap%nrps, is ) = ap%lrps( 1 : ap%nrps )
@@ -1195,7 +1204,7 @@ END SUBROUTINE read_atomic_cc
       use uspp_param, only: betar, dion, vloc_at, lll, nbeta, kkbeta
       use qrl_mod, only: cmesh
       use bhs, only: rcl, rc2, bl, al, wrc1, lloc, wrc2, rc1
-      use funct, only: dft, which_dft
+      use funct, only: dft, which_dft, ishybrid
       use ions_base, only: zv
       use io_global, only: stdout
 
@@ -1219,6 +1228,9 @@ END SUBROUTINE read_atomic_cc
 
       call dftname_cp (nint(exfact), dft)
       call which_dft( dft )
+      IF ( ishybrid ) &
+         CALL errore( 'readpp', 'HYBRID XC not implemented in CPV', 1 )
+
 !
       if(lloc(is).eq.2)then 
          lll(1,is)=0
@@ -1632,7 +1644,7 @@ END SUBROUTINE read_atomic_cc
       use uspp_param, only: qfunc, qfcoef, qqq, betar, dion, vloc_at, &
            rinner, kkbeta, lll, nbeta, nqf, nqlc, tvanp
       use qrl_mod, only: cmesh, qrl
-      use funct, only: dft, which_dft
+      use funct, only: dft, which_dft, ishybrid
       use atom, only: nchi, chi, lchi, r, rab, mesh, nlcc, rho_atc
       use cvan, only: oldvan
       use ions_base, only: zv
@@ -1716,6 +1728,9 @@ END SUBROUTINE read_atomic_cc
 
       call dftname_cp (nint(exfact), dft)
       call which_dft( dft )
+      IF ( ishybrid ) &
+         CALL errore( 'readvan', 'HYBRID XC not implemented in CPV', 1 )
+
 !
       read( iunps, '(2i5,1pe19.11)', err=100, iostat=ios )              &
      &     nchi(is), mesh(is), etotpseu

D3/Makefile

@@ -174,7 +174,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \
@@ -206,7 +205,6 @@ PWOBJS = \
 ../PW/atomic_rho.o \
 ../PW/atomic_wfc.o \
 ../PW/atomic_wfc_nc.o \
-../PW/bachel.o \
 ../PW/becmod.o \
 ../PW/c_gemm.o \
 ../PW/ccalbec.o \

Gamma/Makefile

@@ -17,7 +17,6 @@ PWOBJS = \
 ../PW/atomic_rho.o \
 ../PW/atomic_wfc.o \
 ../PW/atomic_wfc_nc.o \
-../PW/bachel.o \
 ../PW/becmod.o \
 ../PW/bp_calc_btq.o \
 ../PW/bp_c_phase.o \
@@ -257,7 +256,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \

Modules/Makefile

@@ -28,7 +28,6 @@ ions_base.o \
 kind.o \
 coarsegrained_vars.o \
 mp.o \
-metagga.o \
 mp_global.o \
 mp_wave.o \
 mp_buffers.o \

Modules/functionals.f90

@@ -12,7 +12,7 @@ module funct
   IMPLICIT NONE
   PRIVATE
   SAVE
-  PUBLIC :: dft, iexch, icorr, igcx, igcc, which_dft, ismeta
+  PUBLIC :: dft, iexch, icorr, igcx, igcc, which_dft, ismeta, ishybrid
   !
   character (len=20) :: dft = ' '
   !
@@ -84,6 +84,7 @@ module funct
   integer :: igcx  = notset
   integer :: igcc  = notset
   logical :: ismeta = .false.
+  logical :: ishybrid = .false.
   !
   ! internal indices for exchange-correlation
   !    iexch: type of exchange
@@ -92,6 +93,8 @@ module funct
   !    igcc:  type of gradient correction on correlations
   !
   !    ismeta: .TRUE. if gradient correction is of meta-gga type
+  !    ishybrid: .TRUE. if the xc finctional is an HF+DFT hybrid like
+  !              PBE0 or B3LYP
   !
   ! see comments above and routine "which_dft" below 
   !

Nmr/Makefile

@@ -123,7 +123,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \

PH/Makefile

@@ -131,7 +131,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \
@@ -168,7 +167,6 @@ PWOBJS = \
 ../PW/atomic_rho.o \
 ../PW/atomic_wfc.o \
 ../PW/atomic_wfc_nc.o \
-../PW/bachel.o \
 ../PW/becmod.o \
 ../PW/bp_c_phase.o \
 ../PW/bp_calc_btq.o \

PP/Makefile

@@ -44,7 +44,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \
@@ -76,7 +75,6 @@ PWOBJS = \
 ../PW/atomic_rho.o \
 ../PW/atomic_wfc.o \
 ../PW/atomic_wfc_nc.o \
-../PW/bachel.o \
 ../PW/becmod.o \
 ../PW/bp_c_phase.o \
 ../PW/bp_calc_btq.o \

PW/Makefile

@@ -17,7 +17,6 @@ allocate_wfc.o \
 atomic_rho.o \
 atomic_wfc.o \
 atomic_wfc_nc.o \
-bachel.o \
 becmod.o \
 bfgs.o \
 bp_c_phase.o \
@@ -285,7 +284,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \

PW/read_ncpp.f90

@@ -17,7 +17,7 @@ subroutine read_ncpp (np, iunps)
   use pseud, only: cc, alpc, zp, aps, alps, nlc, nnl, lmax, lloc, &
        a_nlcc, b_nlcc, alpha_nlcc
   use uspp_param, only: vloc_at, betar, kkbeta, nbeta, lll, dion, psd
-  use funct, only: dft, which_dft, ismeta
+  use funct, only: dft, which_dft, ismeta, ishybrid
   implicit none
   !
   integer :: iunps, np
@@ -116,6 +116,11 @@ subroutine read_ncpp (np, iunps)
   !
   IF ( ismeta ) &
     CALL errore( 'read_ncpp ', 'META-GGA not implemented in PWscf', 1 )
+#if defined (EXX)
+#else
+  IF ( ishybrid ) &
+    CALL errore( 'read_ncpp ', 'HYBRID XC not implemented in PWscf', 1 )
+#endif
   !
   !    compute the radial mesh
   !

PW/readvan.f90

@@ -24,7 +24,7 @@ subroutine readvan (is, iunps)
   use pseud, only: zp, lmax, lloc
   use uspp_param, only: vloc_at, dion, betar, qqq, qfcoef, qfunc, nqf, nqlc, &
        rinner, nbeta, kkbeta, lll, iver, ifqopt, psd, tvanp
-  use funct, only: dft, which_dft, ismeta
+  use funct, only: dft, which_dft, ismeta, ishybrid
   implicit none
 
   !
@@ -106,6 +106,12 @@ subroutine readvan (is, iunps)
   !
   IF ( ismeta ) &
     CALL errore( 'readvan ', 'META-GGA not implemented in PWscf', 1 )
+#if defined (EXX)
+#else
+  IF ( ishybrid ) &
+    CALL errore( 'readvan ', 'HYBRID XC not implemented in PWscf', 1 )
+#endif
+
   !
   read (iunps, '(2i5,1pe19.11)', err = 100, iostat = ios) nchi (is) &
        , mesh (is) , etotpseu

PW/upf_to_internal.f90

@@ -35,7 +35,7 @@ subroutine set_pseudo_upf (is, upf)
   USE pseud, ONLY: lloc, lmax, zp
   USE uspp_param, ONLY: vloc_at, dion, betar, qqq, qfcoef, qfunc, nqf, nqlc, &
        rinner, nbeta, kkbeta, lll, jjj, psd, tvanp
-  USE funct, ONLY: dft, which_dft, ismeta
+  USE funct, ONLY: dft, which_dft, ismeta, ishybrid
   !
   USE ions_base, ONLY: zv
   USE spin_orb, ONLY: lspinorb
@@ -61,6 +61,11 @@ subroutine set_pseudo_upf (is, upf)
   !
   IF ( ismeta ) &
     CALL errore( 'upf_to_internals ', 'META-GGA not implemented in PWscf', 1 )
+#if defined (EXX)
+#else
+  IF ( ishybrid ) &
+    CALL errore( 'upf_to_internals ', 'HYBRID XC not implemented in PWscf', 1 )
+#endif
   !
   mesh(is) = upf%mesh
   IF ( mesh(is) > ndmx ) &

PWCOND/Makefile

@@ -62,7 +62,6 @@ MODULES = \
 ../Modules/io_global.o \
 ../Modules/ions_base.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/mp_buffers.o \
 ../Modules/mp_global.o \
 ../Modules/mp_wave.o \
@@ -95,7 +94,6 @@ PWOBJS = \
 ../PW/atomic_rho.o \
 ../PW/atomic_wfc.o \
 ../PW/atomic_wfc_nc.o \
-../PW/bachel.o \
 ../PW/becmod.o \
 ../PW/c_gemm.o \
 ../PW/ccalbec.o \

atomic/Makefile

@@ -83,11 +83,9 @@ MODULES = \
 ../Modules/functionals.o \
 ../Modules/io_global.o \
 ../Modules/kind.o \
-../Modules/metagga.o \
 ../Modules/io_files.o \
 ../Modules/pseudo_types.o \
 ../Modules/readpseudo.o \
-../PW/bachel.o 
 
 TLDEPS= bindir mods libs pw
 

flib/Makefile

@@ -5,6 +5,7 @@ include ../make.sys
 OBJS = \
 avrec.o \
 atomic_number.o \
+bachel.o \
 capital.o \
 dost.o \
 erf.o \

flib/bachel.f90

@@ -13,9 +13,8 @@ subroutine bachel (alps, aps, npseu, lmax)
   USE kinds
   implicit none
   !
-  !   First dummy variables
+  !   First I/O variables
   !
-
   integer :: npseu, lmax (npseu)
   ! input:  number of pseudopotential
   ! input:  max. angul. momentum of the ps
@@ -25,20 +24,13 @@ subroutine bachel (alps, aps, npseu, lmax)
   !
   !   Here local variables
   !
-
   integer :: np, lmx, l, i, j, k, ia, ka, nik
   ! counter on number of pseudopot.
   ! aux. var. (max. ang. mom. of a fix. ps
   ! counter on angular momentum
   !
-  !
-  !  auxiliary
-  !  variables
-  !
-  !
   real(kind=DP) :: pi
   ! pi constant
-
   parameter (pi = 3.141592653589793d0)
 
   real(kind=DP) :: s (6, 6), alpl, alpi, ail
@@ -46,6 +38,7 @@ subroutine bachel (alps, aps, npseu, lmax)
   ! first real aux. var. (fix. value of al
   ! second real aux. var. (fix. value of a
   ! third real aux. var.
+  !
   do np = 1, npseu
      lmx = lmax (np)
      do l = 0, lmx

flib/simpsn.f90

@@ -26,8 +26,8 @@ subroutine simpson (mesh, func, rab, asum)
   !     endif
   asum = 0.0d0
   r12 = 1.0d0 / 12.0d0
-
   f3 = func (1) * rab (1) * r12
+
   do i = 2, mesh - 1, 2
      f1 = f3
      f2 = func (i) * rab (i) * r12

upftools/Makefile

@@ -5,27 +5,28 @@ include ../make.sys
 OBJS = write_upf.o errore.o
 MODS = ../Modules/kind.o ../Modules/parameters.o ../Modules/pseudo_types.o \
        ../Modules/parser.o ../Modules/io_global.o ../Modules/mp_global.o \
-       ../Modules/mp.o  ../Modules/parallel_include.o
+       ../Modules/mp.o ../Modules/parallel_include.o 
 SPLINE = ../Modules/splinelib.o
+FUNCT = ../Modules/functionals.o
 TLDEPS = mods libs libiotk
 
 all : tldeps cpmd2upf.x fhi2upf.x fpmd2upf.x ncpp2upf.x oldcp2upf.x \
       rrkj2upf.x uspp2upf.x vdb2upf.x virtual.x
 
-cpmd2upf.x : cpmd2upf.o nclib.o $(OBJS) $(LIBOBJS)
+cpmd2upf.x : cpmd2upf.o $(OBJS) $(LIBOBJS)
-	$(LD) -o $@ cpmd2upf.o nclib.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
+	$(LD) -o $@ cpmd2upf.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
 
-fhi2upf.x : fhi2upf.o nclib.o $(OBJS) $(LIBOBJS)
+fhi2upf.x : fhi2upf.o $(OBJS) $(FUNCT) $(LIBOBJS)
-	$(LD) -o $@ fhi2upf.o nclib.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
+	$(LD) -o $@ fhi2upf.o $(OBJS) $(FUNCT) $(LIBOBJS) $(LDFLAGS)
 
 fpmd2upf.x : fpmd2upf.o $(OBJS) $(LIBOBJS)
 	$(LD) -o $@ fpmd2upf.o $(OBJS) $(LIBOBJS) $(MODS) $(LDFLAGS)
 
-ncpp2upf.x : ncpp2upf.o nclib.o $(OBJS) $(LIBOBJS)
+ncpp2upf.x : ncpp2upf.o $(OBJS) $(FUNCT) $(LIBOBJS) 
-	$(LD) -o $@ ncpp2upf.o nclib.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
+	$(LD) -o $@ ncpp2upf.o $(OBJS) $(FUNCT) $(LIBOBJS) $(LDFLAGS)
 
-oldcp2upf.x : oldcp2upf.o nclib.o $(OBJS) $(LIBOBJS)
+oldcp2upf.x : oldcp2upf.o $(OBJS) $(LIBOBJS)
-	$(LD) -o $@ oldcp2upf.o nclib.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
+	$(LD) -o $@ oldcp2upf.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
 
 read_upf.x : read_upf.o
 	$(LD) -o $@ read_upf.o $(LDFLAGS)
@@ -39,8 +40,8 @@ uspp2upf.x : uspp2upf.o vanderbilt.o $(OBJS) $(LIBOBJS)
 vdb2upf.x : vdb2upf.o vanderbilt.o $(OBJS) $(LIBOBJS)
 	$(LD) -o $@ vdb2upf.o vanderbilt.o $(OBJS) $(LIBOBJS) $(LDFLAGS)
 
-virtual.x : virtual.o nclib.o $(OBJS) $(LIBOBJS) $(SPLINE)
+virtual.x : virtual.o $(OBJS) $(SPLINE) $(FUNCT) $(LIBOBJS)
-	$(LD) -o $@ virtual.o nclib.o $(OBJS) $(SPLINE) $(LIBOBJS) $(LDFLAGS)
+	$(LD) -o $@ virtual.o $(OBJS) $(SPLINE) $(FUNCT) $(LIBOBJS) $(LDFLAGS)
 
 tldeps:
 	test -n "$(TLDEPS)" && ( cd .. ; $(MAKE) $(MFLAGS) $(TLDEPS) || exit 1) || :

upftools/fhi2upf.f90

@@ -152,6 +152,11 @@ subroutine convert_fhi
   !
   use fhi
   use upf
+  use funct, ONLY : which_dft, &
+                    funct_iexch => iexch, &
+                    funct_icorr => icorr, &
+                    funct_igcx => igcx, &
+                    funct_igcc => igcc
   implicit none
   real(kind=8), parameter :: rmax = 10.0
   real(kind=8), allocatable :: aux(:)
@@ -207,7 +212,11 @@ subroutine convert_fhi
      ocw(i)   = oc(i)
      elsw(i)  = els(i)
   end do
-  call which_dft(dft, iexch, icorr, igcx, igcc)
+  call which_dft(dft)
+  iexch = funct_iexch
+  icorr = funct_icorr
+  igcx  = funct_igcx
+  igcc  = funct_igcc
 
   allocate(rab(mesh))
   allocate(  r(mesh))

upftools/nclib.f90

@@ -1,344 +0,0 @@
-!
-! Copyright (C) 2001 PWSCF group
-! This file is distributed under the terms of the
-! GNU General Public License. See the file 'License'
-! in the root directory of the present distribution,
-! or http://www.gnu.org/copyleft/gpl.txt .
-!
-!----------------------------------------------------------------------
-subroutine simpson(mesh,func,rab,asum)
-  !-----------------------------------------------------------------------
-!
-  !     simpson's rule integrator for function stored on the
-  !     radial logarithmic mesh
-  !
-  
-  implicit none
-  
-  integer :: i, mesh
-  real(kind=8) ::  rab(mesh), func(mesh), f1, f2, f3, r12, asum
-      
-      !     routine assumes that mesh is an odd number so run check
-      !     if ( mesh+1 - ( (mesh+1) / 2 ) * 2 .ne. 1 ) then
-      !       write(*,*) '***error in subroutine radlg'
-!       write(*,*) 'routine assumes mesh is odd but mesh =',mesh+1
-!       stop
-!     endif
-
-  asum = 0.0d0
-  r12 = 1.0d0 / 12.0d0
-  f3  = func(1) * rab(1) * r12
-  
-  do i = 2,mesh-1,2
-     f1 = f3
-     f2 = func(i) * rab(i) * r12
-     f3 = func(i+1) * rab(i+1) * r12
-     asum = asum + 4.0d0*f1 + 16.0d0*f2 + 4.0d0*f3
-  enddo
-  
-  return
-end subroutine simpson
-
-!---------------------------------------------------------------------
-real(kind=8) function erf (x)  
-  !---------------------------------------------------------------------
-  !
-  !     Error function - computed from the rational approximations of
-  !     W. J. Cody, Math. Comp. 22 (1969), pages 631-637.
-  !
-  !     for abs(x) le 0.47 erf is calculated directly
-  !     for abs(x) gt 0.47 erf is calculated via erf(x)=1-erfc(x)
-  !
-  implicit none  
-  real(kind=8) :: x, x2, p1 (4), q1 (4), erfc  
-  external erfc  
-  data p1 / 2.42667955230532d2, 2.19792616182942d1, &
-       6.99638348861914d0, -3.56098437018154d-2 /
-  data q1 / 2.15058875869861d2, 9.11649054045149d1, &
-       1.50827976304078d1, 1.00000000000000d0 /
-  !
-  if (abs (x) .gt.6.d0) then  
-     !
-     !  erf(6)=1-10^(-17) cannot be distinguished from 1 with 16-byte words
-     !
-     erf = sign (1.d0, x)  
-  else  
-     if (abs (x) .le.0.47d0) then  
-        x2 = x**2  
-        erf = x * (p1 (1) + x2 * (p1 (2) + x2 * (p1 (3) + x2 * p1 ( &
-             4) ) ) ) / (q1 (1) + x2 * (q1 (2) + x2 * (q1 (3) + x2 * q1 ( &
-             4) ) ) )
-     else  
-        erf = 1.d0 - erfc (x)  
-     endif
-  endif
-  !
-  return  
-end function erf
-!
-!---------------------------------------------------------------------
-real(kind=8) function erfc (x)  
-  !---------------------------------------------------------------------
-  !
-  !     erfc(x) = 1-erf(x)  - See comments in erf
-  !
-  implicit none  
-  real(kind=8) :: x, ax, x2, xm2, erf, p2 (8), q2 (8), p3 (5), q3 (5), &
-       pim1
-  external erf  
-  data p2 / 3.00459261020162d2, 4.51918953711873d2, &
-       3.39320816734344d2, 1.52989285046940d2, 4.31622272220567d1, &
-       7.21175825088309d0, 5.64195517478974d-1, -1.36864857382717d-7 /
-  data q2 / 3.00459260956983d2, 7.90950925327898d2, &
-       9.31354094850610d2, 6.38980264465631d2, 2.77585444743988d2, &
-       7.70001529352295d1, 1.27827273196294d1, 1.00000000000000d0 /
-  data p3 / -2.99610707703542d-3, -4.94730910623251d-2, &
-       -2.26956593539687d-1, -2.78661308609648d-1, -2.23192459734185d-2 &
-       /
-  data q3 / 1.06209230528468d-2, 1.91308926107830d-1, &
-       1.05167510706793d0, 1.98733201817135d0, 1.00000000000000d0 /
-  data pim1 / 0.564189583547756d0 /  
-  !        ( pim1= sqrt(1/pi) )
-  ax = abs (x)  
-  if (ax.gt.26.d0) then  
-     !
-     !  erfc(26.0)=10^(-296); erfc( 9.0)=10^(-37);
-     !
-     erfc = 0.d0  
-  elseif (ax.gt.4.d0) then  
-     x2 = x**2  
-     xm2 = (1.d0 / ax) **2  
-     erfc = (1.d0 / ax) * exp ( - x2) * (pim1 + xm2 * (p3 (1) &
-          + xm2 * (p3 (2) + xm2 * (p3 (3) + xm2 * (p3 (4) + xm2 * p3 (5) &
-          ) ) ) ) / (q3 (1) + xm2 * (q3 (2) + xm2 * (q3 (3) + xm2 * &
-          (q3 (4) + xm2 * q3 (5) ) ) ) ) )
-  elseif (ax.gt.0.47d0) then  
-     x2 = x**2 
-     erfc = exp ( - x2) * (p2 (1) + ax * (p2 (2) + ax * (p2 (3) &
-          + ax * (p2 (4) + ax * (p2 (5) + ax * (p2 (6) + ax * (p2 (7) &
-          + ax * p2 (8) ) ) ) ) ) ) ) / (q2 (1) + ax * (q2 (2) + ax * &
-          (q2 (3) + ax * (q2 (4) + ax * (q2 (5) + ax * (q2 (6) + ax * &
-          (q2 (7) + ax * q2 (8) ) ) ) ) ) ) )
-  else  
-     erfc = 1.d0 - erf (ax)  
-  endif
-  !
-  ! erf(-x)=-erf(x)  =>  erfc(-x) = 2-erfc(x)
-  !
-  if (x.lt.0.d0) erfc = 2.d0 - erfc  
-  !
-  return  
-end function erfc
-
-subroutine bachel(alps,aps,npseu,lmax)
-
-  implicit none
-
-  integer  npseu, lmax(npseu)
-  real(kind=8)   alps(3,0:3,npseu), aps(6,0:3,npseu)
-
-  integer  np, lmx, l, i, j, k, ia, ka, nik
-  real(kind=8), parameter:: pi=3.141592653589793d0
-  real(kind=8)    s(6,6), alpl, alpi, ail
-
-  do np=1,npseu
-     lmx=lmax(np)
-     do l=0,lmx
-        do k=1,6
-           ka= mod(k-1,3)+1
-           alpl= alps(ka,l,np)
-           do i=1,k
-              ia= mod(i-1,3)+1
-              alpi= alps(ia,l,np)
-              ail=alpi+alpl
-              s(i,k)= sqrt(pi/ail)/4.d0/ail
-              nik=int((k-1)/3)+int((i-1)/3)+1
-              do j=2, nik
-                 s(i,k)= s(i,k)/2.d0/ail*(2*j-1)
-              end do
-           end do
-        end do
-
-        do i=1,6
-           do j=i,6
-              do k=1,i-1
-                 s(i,j)=s(i,j)-s(k,i)*s(k,j)
-              end do
-              if(i.eq.j) then
-                 s(i,i)=sqrt(s(i,i))
-              else
-                 s(i,j)=s(i,j)/s(i,i)
-              end if
-           end do
-        end do
-
-        aps(6,l,np)=-aps(6,l,np)/s(6,6)
-        do i=5,1,-1
-           aps(i,l,np)=-aps(i,l,np)
-           do k=i+1,6
-              aps(i,l,np)=aps(i,l,np)-aps(k,l,np)*s(i,k)
-           end do
-           aps(i,l,np)=aps(i,l,np)/s(i,i)
-        end do
-     end do
-  end do
-
-  return
-end subroutine bachel
-!
-!-----------------------------------------------------------------------
-subroutine which_dft (dft, iexch, icorr, igcx, igcc)  
-  !-----------------------------------------------------------------------
-  !
-  implicit none  
-  ! input
-  character (len=*) :: dft  
-  ! output
-  integer :: iexch, icorr, igcx, igcc  
-  ! data
-  integer :: nxc, ncc, ngcx, ngcc  
-  parameter (nxc = 1, ncc = 9, ngcx = 4, ngcc = 5)  
-  character (len=3) :: exc, corr
-  character (len=4) :: gradx, gradc
-  dimension exc (0:nxc), corr (0:ncc), gradx (0:ngcx), gradc (0: ngcc)
-  ! local
-  integer :: len, l, i, notset  
-  character (len=50):: dftout * 50  
-  character (len=1), external :: capital
-  logical, external :: matches  
-  data notset / -1 /  
-  data exc / 'NOX', 'SLA' /  
-  data corr / 'NOC', 'PZ', 'VWN', 'LYP', 'PW', 'WIG', 'HL', 'OBZ', &
-       'OBW', 'GL'  /
-  data gradx / 'NOGX', 'B88', 'GGX', 'PBE' ,'TPSS'/  
-  data gradc / 'NOGC', 'P86', 'GGC', 'BLYP', 'PBE','TPSS' /  
-
-  ! convert to uppercase
-  len = len_trim(dft)  
-  dftout = ' '  
-  do l = 1, len  
-     dftout (l:l) = capital (dft (l:l) )  
-  enddo
-  !  exchange
-
-  iexch = notset  
-  do i = 0, nxc  
-     if (matches (exc (i), dftout) ) call set_dft_value (iexch, i)  
-  enddo
-  !  correlation
-
-  icorr = notset  
-  do i = 0, ncc  
-     if (matches (corr (i), dftout) ) call set_dft_value (icorr, i)  
-  enddo
-  !  gradient correction, exchange
-
-  igcx = notset  
-  do i = 0, ngcx  
-     if (matches (gradx (i), dftout) ) call set_dft_value (igcx, i)  
-  enddo
-  !  gradient correction, correlation
-
-  igcc = notset  
-  do i = 0, ngcc  
-     if (matches (gradc (i), dftout) ) call set_dft_value (igcc, i)  
-  enddo
-  ! special case : BLYP => B88 for gradient correction on exchange
-
-
-  if (matches ('BLYP', dftout) ) call set_dft_value (igcx, 1)  
-  ! special case : PBE
-  if (matches ('PBE', dftout) ) then  
-     call set_dft_value (iexch, 1)  
-     call set_dft_value (icorr, 4)  
-  endif
-  ! special case : BP = B88 + P86
-  if (matches ('BP', dftout) ) then  
-     call set_dft_value (igcx, 1)  
-     call set_dft_value (igcc, 1)  
-  endif
-  ! special case : PW91 = GGX + GGC
-  if (matches ('PW91', dftout) ) then  
-     call set_dft_value (igcx, 2)  
-     call set_dft_value (igcc, 2)  
-  endif
-  !special case : META = tpss metaGGA Exc  !Begin METAGGA
-  if (matches('TPSS',dftout)) then
-     call set_dft_value(iexch,1)!1
-     call set_dft_value(icorr,4)!4
-  end if    !End METAGGA
-
-  ! Default value: Slater exchange
-
-
-  if (iexch.eq.notset) call set_dft_value (iexch, 1)  
-  ! Default value: Perdew-Zunger correlation
-
-  if (icorr.eq.notset) call set_dft_value (icorr, 1)  
-  ! Default value: no gradient correction on exchange
-
-  if (igcx.eq.notset) call set_dft_value (igcx, 0)  
-  ! Default value: no gradient correction on correlation
-
-  if (igcc.eq.notset) call set_dft_value (igcc, 0)  
-  !
-
-  dftout = exc (iexch) //'-'//corr (icorr) //'-'//gradx (igcx) //'-' &
-       &//gradc (igcc)
-  !cc      write (6,'(a)') dftout
-  return  
-end subroutine which_dft
-!
-!-----------------------------------------------------------------------
-subroutine set_dft_value (m, i)  
-  !-----------------------------------------------------------------------
-  !
-  implicit none  
-  ! input / output
-  integer :: m, i  
-  ! local
-  integer :: notset  
-
-  parameter (notset = -1)  
-
-  if (m.ne.notset.and.m.ne.i) call errore ('set_dft_value', &
-       'two conflicting matching values', 1)
-
-  m = i  
-  return  
-
-end subroutine set_dft_value
-!
-! ------------------------------------------------------------------
-function atom_name(atomic_number)
-! ------------------------------------------------------------------
-  !
-  integer :: atomic_number
-  character(len=2) :: atom_name
-  !
-  character(len=2), dimension (94) :: elements
-  data elements/' H',                              'He', &
-                'Li','Be',' B',' C',' N',' O',' F','Ne', &  
-                'Na','Mg','Al','Si',' P',' S','Cl','Ar', &
-                ' K','Ca','Sc','Ti',' V','Cr','Mn',      &
-                          'Fe','Co','Ni','Cu','Zn',      &
-                          'Ga','Ge','As','Se','Br','Kr', &
-                'Rb','Sr',' Y','Zr','Nb','Mo','Tc',      &
-                          'Ru','Rh','Pd','Ag','Cd',      &
-                          'In','Sn','Sb','Te',' I','Xe', &
-                'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd', &
-                               'Tb','Dy','Ho','Er','Tm','Yb','Lu', &
-                          'Hf','Ta',' W','Re','Os', &
-                               'Ir','Pt','Au','Hg', &
-                          'Tl','Pb','Bi','Po','At','Rn', &
-                'Fr','Ra','Ac','Th','Pa',' U','Np','Pu' /
-  !
-  if (atomic_number.lt.1.or.atomic_number.gt.94) then
-     call errore('atom_name','invalid atomic number', &
-          1000+atomic_number)
-  else
-     atom_name=elements(atomic_number)
-  end if
-  return
-
-end function atom_name

upftools/ncpp2upf.f90

@@ -254,6 +254,11 @@ subroutine convert_ncpp
   !     ----------------------------------------------------------
   use ncpp
   use upf
+  use funct, ONLY : which_dft, &
+                    funct_iexch => iexch, &
+                    funct_icorr => icorr, &
+                    funct_igcx => igcx, &
+                    funct_igcc => igcc
   implicit none
   real(kind=8), parameter :: rmax = 10.0
   real(kind=8), allocatable :: aux(:)
@@ -305,7 +310,11 @@ subroutine convert_ncpp
      ocw(i)   = oc(i)
      elsw(i)  = els(i)
   end do
-  call which_dft(dft_, iexch, icorr, igcx, igcc)
+  call which_dft(dft_)
+  iexch = funct_iexch
+  icorr = funct_icorr
+  igcx  = funct_igcx
+  igcc  = funct_igcc
 
   allocate(rab(mesh))
   allocate(  r(mesh))

upftools/virtual.f90

@@ -114,7 +114,10 @@ subroutine compute_virtual(x,filein)
            upf_generated => generated, upf_date_author => date_author, &
            upf_comment => comment, &
            upf_psd => psd, upf_pseudotype => pseudotype, &
-           iexch, icorr, igcx, igcc, &
+           upf_iexch => iexch, &
+           upf_icorr => icorr, &
+           upf_igcx  => igcx, &
+           upf_igcc => igcc, &
            upf_lmax => lmax, upf_mesh => mesh, &
            upf_nbeta => nbeta, upf_ntwfc => ntwfc, upf_nlcc => nlcc, &
            upf_zp => zp, upf_ecutrho => ecutrho, upf_ecutwfc => ecutwfc, &
@@ -131,6 +134,7 @@ subroutine compute_virtual(x,filein)
            upf_chi => chi, &
            upf_rho_at  => rho_at
   use splinelib
+  use funct, ONLY : which_dft, iexch, icorr, igcx, igcc
   implicit none
   integer :: i, j, ib, iexch_, icorr_, igcx_, igcc_
   character (len=256) :: filein(2)
@@ -154,10 +158,14 @@ subroutine compute_virtual(x,filein)
   upf_psd = "Xx"
   upf_pseudotype = "NC"
   if (isus(1) .or. isus(2)) upf_pseudotype = "US"
-  call which_dft(dft(1), iexch, icorr, igcx, igcc)
+  call which_dft(dft(1))
-  call which_dft(dft(2), iexch_, icorr_, igcx_, igcc_)
+  upf_iexch = iexch
-  if (iexch.ne.iexch_ .or. icorr.ne.icorr_ .or. igcx.ne.igcx_ .or. &
+  upf_icorr = icorr
-      igcc.ne.igcc_) call errore ('virtual','conflicting DFT functionals',1)
+  upf_igcx  = igcx
+  upf_igcc  = igcc
+  call which_dft(dft(2))
+  if (iexch.ne.upf_iexch .or. icorr.ne.upf_icorr .or. igcx.ne.upf_igcx .or. &
+      igcc.ne.upf_igcc) call errore ('virtual','conflicting DFT functionals',1)
   upf_lmax = max(lmax(1), lmax(2))
   if (mesh(1).ne.mesh(2) ) then
      write (*,*) " pseudopotentials have different mesh "