diff --git a/Modules/Makefile b/Modules/Makefile
index 1970bed..438f210 100644
--- a/Modules/Makefile
+++ b/Modules/Makefile
@@ -160,7 +160,8 @@ ylmr2.o \
wgauss.o \
w0gauss.o \
w1gauss.o \
-deviatoric.o
+deviatoric.o \
+read_upf.o
TLDEPS=libiotk libfox libutil libla libfft
diff --git a/Modules/make.depend b/Modules/make.depend
index db821b2..95457bd 100644
--- a/Modules/make.depend
+++ b/Modules/make.depend
@@ -320,10 +320,14 @@ read_pseudo.o : mp_images.o
read_pseudo.o : pseudo_types.o
read_pseudo.o : radial_grids.o
read_pseudo.o : read_uspp.o
-read_pseudo.o : upf.o
read_pseudo.o : upf_to_internal.o
read_pseudo.o : uspp.o
read_pseudo.o : wrappers.o
+read_upf.o : pseudo_types.o
+read_upf.o : radial_grids.o
+read_upf.o : read_upf_schema.o
+read_upf.o : read_upf_v1.o
+read_upf.o : read_upf_v2.o
read_upf_schema.o : kind.o
read_upf_schema.o : parser.o
read_upf_schema.o : pseudo_types.o
diff --git a/Modules/qexsd.f90 b/Modules/qexsd.f90
index 07f68c8..35a76b5 100644
--- a/Modules/qexsd.f90
+++ b/Modules/qexsd.f90
@@ -707,13 +707,27 @@ CONTAINS
CALL set_labels ()
IF ( PRESENT(noncolin)) noncolin_ = noncolin
!
- IF (PRESENT(U)) CALL init_hubbard_commons(U, U_, label, "Hubbard_U")
- IF (PRESENT(J0)) CALL init_hubbard_commons(J0, J0_, label, "Hubbard_J0" )
- IF (PRESENT(alpha)) CALL init_hubbard_commons(alpha, alpha_,label, "Hubbard_alpha")
- IF (PRESENT(beta)) CALL init_hubbard_commons(beta, beta_, label, "Hubbard_beta")
- IF (PRESENT(J)) CALL init_hubbard_J (J, J_, label, "Hubbard_J" )
- IF (PRESENT(starting_ns)) CALL init_starting_ns(starting_ns_ , label)
- IF (PRESENT(Hub_ns)) CALL init_Hubbard_ns(Hubbard_ns_ , label)
+ IF (PRESENT(U)) THEN
+ IF (SIZE(U) > 0 ) CALL init_hubbard_commons(U, U_, label, "Hubbard_U")
+ END IF
+ IF (PRESENT(J0)) THEN
+ IF (SIZE(J0) > 0 ) CALL init_hubbard_commons(J0, J0_, label, "Hubbard_J0" )
+ END IF
+ IF (PRESENT(alpha)) THEN
+ IF (SIZE(alpha)> 0) CALL init_hubbard_commons(alpha, alpha_,label, "Hubbard_alpha")
+ END IF
+ IF (PRESENT(beta)) THEN
+ IF (SIZE(beta)>0) CALL init_hubbard_commons(beta, beta_, label, "Hubbard_beta")
+ END IF
+ IF (PRESENT(J)) THEN
+ IF(SIZE(J,2) > 0) CALL init_hubbard_J (J, J_, label, "Hubbard_J" )
+ END IF
+ IF (PRESENT(starting_ns)) THEN
+ IF (SIZE(starting_ns,3) > 0 ) CALL init_starting_ns(starting_ns_ , label)
+ END IF
+ IF (PRESENT(Hub_ns) .OR. PRESENT(Hub_ns_nc) ) THEN
+ IF (SIZE(Hub_ns,4)>0 .OR. SIZE(Hub_ns_nc,4) > 0 ) CALL init_Hubbard_ns(Hubbard_ns_ , label)
+ END IF
!
CALL qes_init (obj, "dftU", lda_plus_u_kind, U_, J0_, alpha_, beta_, J_, starting_ns_, Hubbard_ns_, &
U_projection_type)
@@ -839,9 +853,13 @@ CONTAINS
!
REAL(DP), ALLOCATABLE :: Hubb_occ_aux(:,:)
INTEGER :: i, is,ind, ldim, m1, m2, llmax, nat, nspin
+ LOGICAL :: dononcol = .FALSE.
!
- !
- IF (PRESENT(Hub_ns_nc )) THEN
+ !
+ IF (PRESENT(Hub_ns_nc)) THEN
+ IF (SIZE(Hub_ns_nc,4) > 0) dononcol = .TRUE.
+ END IF
+ IF ( dononcol ) THEN
llmax = SIZE ( Hub_ns_nc, 1)
nat = size(Hub_ns_nc,4)
ALLOCATE (objs(nat))
@@ -862,7 +880,7 @@ CONTAINS
IF (TRIM(labs(ityp(i))) == 'no Hubbard') objs(i)%lwrite = .FALSE.
END DO
RETURN
- ELSE IF (PRESENT (Hub_ns)) THEN
+ ELSE
llmax = SIZE ( Hub_ns,1)
nat = size(Hub_ns,4)
nspin = size(Hub_ns,3)
diff --git a/Modules/qexsd_input.f90 b/Modules/qexsd_input.f90
index 8555c61..c4e0d8c 100644
--- a/Modules/qexsd_input.f90
+++ b/Modules/qexsd_input.f90
@@ -164,7 +164,7 @@ MODULE qexsd_input
!
!
!--------------------------------------------------------------------------------------------------------------------
- SUBROUTINE qexsd_init_basis(obj,k_points,ecutwfc,ecutrho,nr,nrs,nrb)
+ SUBROUTINE qexsd_init_basis(obj,k_points,ecutwfc,ecutrho, nr1, nr2, nr3, nrs1, nrs2, nrs3, nrb1, nrb2, nrb3)
!--------------------------------------------------------------------------------------------------------------------
!
IMPLICIT NONE
@@ -173,25 +173,35 @@ MODULE qexsd_input
CHARACTER(LEN=*),INTENT(IN) :: k_points
REAL(DP),INTENT(IN) :: ecutwfc
REAL(DP),OPTIONAL,INTENT(IN) :: ecutrho
- INTEGER,OPTIONAL,INTENT(IN) :: nr(:), nrs(:), nrb(:)
+ INTEGER,OPTIONAL,INTENT(IN) :: nr1, nr2, nr3, nrs1, nrs2, nrs3, nrb1, nrb2, nrb3
!
TYPE(basisSetItem_type),POINTER :: grid_obj => NULL(), smooth_grid_obj => NULL(), box_obj => NULL()
CHARACTER(LEN=*),PARAMETER :: TAGNAME="basis",FFT_GRID="fft_grid",FFT_SMOOTH="fft_smooth", FFT_BOX="fft_box"
LOGICAL :: gamma_only=.FALSE.
+ INTEGER :: nr1_, nr2_, nr3_
!
- IF ( PRESENT(nr)) THEN
+ IF ( PRESENT(nr1) .AND. PRESENT(nr2) .AND. PRESENT(nr3)) THEN
ALLOCATE(grid_obj)
- CALL qes_init (grid_obj,FFT_GRID,nr(1),nr(2),nr(3),"grid set in input")
+ nr1_ = nr1
+ nr2_ = nr2
+ nr3_ = nr3
+ CALL qes_init (grid_obj,FFT_GRID,nr1_,nr2_,nr3_,"grid set in input")
END IF
!
- IF( PRESENT(nrs)) THEN
+ IF( PRESENT(nrs1) .AND. PRESENT(nrs2) .AND. PRESENT(nrs3)) THEN
ALLOCATE(smooth_grid_obj)
- CALL qes_init (smooth_grid_obj,FFT_SMOOTH,nrs(1),nrs(2),nrs(3),"grid set in input")
+ nr1_ = nrs1
+ nr2_ = nrs2
+ nr3_ = nrs3
+ CALL qes_init (smooth_grid_obj,FFT_SMOOTH,nr1_,nr2_,nr3_,"grid set in input")
END IF
!
- IF( PRESENT(nrb)) THEN
+ IF( PRESENT(nrb1) .AND. PRESENT(nrb2) .AND. PRESENT(nrb3)) THEN
ALLOCATE(box_obj)
- CALL qes_init (box_obj,FFT_BOX,nrb(1),nrb(2),nrb(3),"grid set in input")
+ nr1_ = nrb1
+ nr2_ = nrb2
+ nr3_= nrb3
+ CALL qes_init (box_obj,FFT_BOX,nr1_,nr2_,nr3_,"grid set in input")
END IF
!
IF (TRIM(k_points) .EQ. "gamma" ) gamma_only=.TRUE.
diff --git a/Modules/read_pseudo.f90 b/Modules/read_pseudo.f90
index 5009a3d..2aa321f 100644
--- a/Modules/read_pseudo.f90
+++ b/Modules/read_pseudo.f90
@@ -47,15 +47,26 @@ SUBROUTINE readpp ( input_dft, printout, ecutwfc_pp, ecutrho_pp )
USE pseudo_types, ONLY: pseudo_upf, nullify_pseudo_upf, deallocate_pseudo_upf
USE funct, ONLY: enforce_input_dft, set_dft_from_name, &
get_iexch, get_icorr, get_igcx, get_igcc, get_inlc
- use radial_grids, ONLY: deallocate_radial_grid, nullify_radial_grid
+ use radial_grids, ONLY: radial_grid_type, deallocate_radial_grid, nullify_radial_grid
USE wrappers, ONLY: md5_from_file, f_remove
- USE upf_module, ONLY: read_upf
+ !USE upf_module, ONLY: read_upf
USE emend_upf_module, ONLY: make_emended_upf_copy
USE upf_to_internal, ONLY: add_upf_grid, set_upf_q
USE read_uspp_module, ONLY: readvan, readrrkj
USE m_gth, ONLY: readgth
!
IMPLICIT NONE
+ INTERFACE
+ SUBROUTINE read_upf(upf, grid, ierr, unit, filename)
+ IMPORT pseudo_upf, radial_grid_type
+ IMPLICIT NONE
+ INTEGER,INTENT(IN), OPTIONAL :: unit
+ CHARACTER(len=*),INTENT(IN),OPTIONAL :: filename
+ TYPE(pseudo_upf),INTENT(INOUT) :: upf
+ TYPE(radial_grid_type),OPTIONAL,INTENT(INOUT),TARGET :: grid
+ INTEGER,INTENT(INOUT) :: ierr
+ END SUBROUTINE read_upf
+ END INTERFACE
!
CHARACTER(len=*), INTENT(INOUT) :: input_dft
LOGICAL, OPTIONAL, INTENT(IN) :: printout
diff --git a/Modules/read_upf.f90 b/Modules/read_upf.f90
new file mode 100644
index 0000000..75e9086
--- /dev/null
+++ b/Modules/read_upf.f90
@@ -0,0 +1,91 @@
+SUBROUTINE read_upf(upf, grid, ierr, unit, filename) !
+ !---------------------------------------------+
+ !! Reads pseudopotential in UPF format (either v.1 or v.2 or upf_schema).
+ !! Derived-type variable *upf* and optionally *grid* store in output the
+ !! data read from file.
+ !! If unit number is provided with the *unit* argument, only UPF v1 format
+ !! is checked; the PP file must be opened and closed outside the routine.
+ !! Otherwise the *filename* argument must be given, file is opened and closed
+ !! inside the routine, all formats will be checked.
+ !! @Note last revision: 01-01-2019 PG - upf fix moved out from here
+ !! @Note last revision: 11-05-2018 PG - removed xml_only
+ !
+ USE pseudo_types, ONLY: pseudo_upf, deallocate_pseudo_upf
+ USE radial_grids, ONLY: radial_grid_type, deallocate_radial_grid
+ USE read_upf_v1_module,ONLY: read_upf_v1
+ USE read_upf_v2_module,ONLY: read_upf_v2
+ USE read_upf_schema_module ,ONLY: read_upf_schema
+ USE FoX_DOM, ONLY: Node, domException, parseFile, getFirstChild, &
+ getExceptionCode, getTagName
+ IMPLICIT NONE
+ INTEGER,INTENT(IN), OPTIONAL :: unit
+ !! i/o unit:
+ CHARACTER(len=*),INTENT(IN),OPTIONAL :: filename
+ !! i/o filename
+ TYPE(pseudo_upf),INTENT(INOUT) :: upf
+ !! the derived type storing the pseudo data
+ TYPE(radial_grid_type),OPTIONAL,INTENT(INOUT),TARGET :: grid
+ !! derived type where is possible to store data on the radial mesh
+ INTEGER,INTENT(INOUT) :: ierr
+ !! On input:
+ !! ierr =0: return if not a valid xml schema or UPF v.2 file
+ !! ierr/=0: continue if not a valid xml schema or UPF v.2 file
+ !! On output:
+ !! ierr=0: xml schema, ierr=-1: UPF v.1, ierr=-2: UPF v.2
+ !! ierr>0: error reading PP file
+ !! ierr=-81: error reading PP file, possibly UPF fix needed
+ !
+ TYPE(Node),POINTER :: u,doc
+ INTEGER :: u_temp,& ! i/o unit in case of upf v1
+ iun, ferr
+ TYPE(DOMException) :: ex
+ INTEGER, EXTERNAL :: find_free_unit
+
+ ferr = ierr
+ ierr = 0
+ IF ( present ( unit ) ) THEN
+ REWIND (unit)
+ CALL deallocate_pseudo_upf(upf)
+ CALL deallocate_radial_grid( grid )
+ CALL read_upf_v1 (unit, upf, grid, ierr )
+ IF (ierr == 0 ) ierr = -1
+ !
+ ELSE IF (PRESENT(filename) ) THEN
+ doc => parseFile(TRIM(filename), EX = ex )
+ ierr = getExceptionCode( ex )
+ IF ( ferr == 0 .AND. ierr == 81 ) THEN
+ ierr = -81
+ RETURN
+ END IF
+ IF ( ierr == 0 ) THEN
+ u => getFirstChild(doc)
+ SELECT CASE (TRIM(getTagname(u)))
+ CASE ('UPF')
+ CALL read_upf_v2( u, upf, grid, ierr )
+ IF ( ierr == 0 ) ierr = -2
+ CASE ('qe_pp:pseudo')
+ CALL read_upf_schema( u, upf, grid, ierr)
+ CASE default
+ ierr = 1
+ CALL errore('read_upf', 'xml format '//TRIM(getTagName(u))//' not implemented', ierr)
+ END SELECT
+ IF ( ierr > 0 ) CALL errore( 'read_upf', 'File is Incomplete or wrong: '//TRIM(filename), ierr)
+ !
+ ELSE IF ( ierr > 0 ) THEN
+ !
+ u_temp = find_free_unit()
+ OPEN (UNIT = u_temp, FILE = TRIM(filename), STATUS = 'old', FORM = 'formatted', IOSTAT = ierr)
+ CALL errore ("upf_module:read_upf", "error while opening file " // TRIM(filename), ierr)
+ CALL deallocate_pseudo_upf( upf )
+ CALL deallocate_radial_grid( grid )
+ CALL read_upf_v1( u_temp, upf, grid, ierr )
+ IF ( ierr == 0 ) ierr = -1
+ CLOSE ( u_temp)
+ !
+ END IF
+ ELSE
+ CALL errore('read_upf', 'Nothing to read !!! Provide either filename or unit optional arguments',1)
+ END IF
+ !
+ END SUBROUTINE read_upf
+
diff --git a/PW/src/input.f90 b/PW/src/input.f90
index 8d9822d..e5fc42c 100644
--- a/PW/src/input.f90
+++ b/PW/src/input.f90
@@ -1689,7 +1689,7 @@ SUBROUTINE iosys()
!
! ... End of reading input parameters
!
-#if ! defined (__INTEL_COMPILER) || (__INTEL_COMPILER >= 1300)
+#if ! defined (__INTEL_COMPILER) || (__INTEL_COMPILER >= 1100)
CALL pw_init_qexsd_input(qexsd_input_obj, obj_tagname="input")
#endif
CALL deallocate_input_parameters ()
diff --git a/PW/src/pw_init_qexsd_input.f90 b/PW/src/pw_init_qexsd_input.f90
index fc3a435..7c91a56 100644
--- a/PW/src/pw_init_qexsd_input.f90
+++ b/PW/src/pw_init_qexsd_input.f90
@@ -118,7 +118,7 @@
hubbard_J0_(:), hubbard_beta_(:),starting_ns_(:,:,:)
CHARACTER(LEN=3),ALLOCATABLE :: species_(:)
INTEGER, POINTER :: nr_1,nr_2, nr_3, nrs_1, nrs_2, nrs_3, nrb_1, nrb_2, nrb_3
- INTEGER,ALLOCATABLE :: nr_(:), nrs_(:), nrb_(:)
+ INTEGER, TARGET :: nr_1_,nr_2_, nr_3_, nrs_1_, nrs_2_, nrs_3_, nrb_1_, nrb_2_, nrb_3_
!
!
NULLIFY (gate_ptr, block_ptr, relaxz_ptr, block_1_ptr, block_2_ptr, block_height_ptr, zgate_ptr, dftU_, vdW_, hybrid_)
@@ -280,25 +280,35 @@
IF ( ANY(ip_hubbard_u(1:ntyp) /=0.0_DP)) THEN
ALLOCATE(hubbard_U_(ntyp))
hubbard_U_(1:ntyp) = ip_hubbard_u(1:ntyp)
+ ELSE
+ ALLOCATE(hubbard_U_(0))
END IF
IF (ANY (ip_hubbard_J0 /=0.0_DP)) THEN
ALLOCATE(hubbard_J0_(ntyp))
hubbard_J0_ (1:ntyp) = ip_hubbard_J0(1:ntyp)
+ ELSE
+ ALLOCATE(hubbard_J0_(0))
END IF
IF (ANY (ip_hubbard_alpha /=0.0_DP)) THEN
ALLOCATE(hubbard_alpha_(ntyp))
hubbard_alpha_ (1:ntyp) = ip_hubbard_alpha(1:ntyp)
+ ELSE
+ ALLOCATE(hubbard_alpha_(0))
END IF
IF (ANY (ip_hubbard_beta /=0.0_DP)) THEN
ALLOCATE(hubbard_beta_(ntyp))
hubbard_beta_ (1:ntyp) = ip_hubbard_beta(1:ntyp)
+ ELSE
+ ALLOCATE(hubbard_beta_(0))
END IF
IF (ANY (ip_hubbard_J(:,1:ntyp) /=0.0_DP )) THEN
ALLOCATE(hubbard_J_(3,ntyp))
hubbard_J_(1:3,1:ntyp) = ip_hubbard_J(1:3,1:ntyp)
- END IF
- IF (ANY(starting_ns_eigenvalue /= -1.0_DP)) THEN
- IF (lsda) THEN
+ ELSE
+ ALLOCATE(hubbard_J_(3,0))
+ END IF
+ IF (ANY(starting_ns_eigenvalue /= -1.0_DP)) THEN
+ IF (lsda) THEN
spin_ns = 2
ELSE
spin_ns = 1
@@ -306,8 +316,10 @@
ALLOCATE (starting_ns_(2*hublmax+1, spin_ns, ntyp))
starting_ns_ (1:2*hublmax+1, 1:spin_ns, 1:ntyp) = &
starting_ns_eigenvalue(1:2*hublmax+1, 1:spin_ns, 1:ntyp)
- END IF
- CALL qexsd_init_dftU(dftU_, NSP = ntyp, PSD = upf(1:ntyp)%psd, SPECIES = atm(1:ntyp), ITYP = ip_ityp(1:ntyp), &
+ ELSE
+ ALLOCATE(starting_ns_(1,1,0))
+ END IF
+ CALL qexsd_init_dftU(dftU_, NSP = ntyp, PSD = upf(1:ntyp)%psd, SPECIES = atm(1:ntyp), ITYP = ip_ityp(1:ntyp), &
IS_HUBBARD = is_hubbard(1:ntyp), LDA_PLUS_U_KIND = ip_lda_plus_u_kind, &
U_PROJECTION_TYPE=u_projection_type, U=hubbard_U_, J0=hubbard_J0_, NONCOLIN=ip_noncolin, &
ALPHA = hubbard_alpha_, BETA = hubbard_beta_, J = hubbard_J_, STARTING_NS = starting_ns_ )
@@ -364,19 +376,32 @@
! BASIS ELEMENT
!---------------------------------------------------------------------------------------------------------------------------
IF (ANY([ip_nr1,ip_nr2,ip_nr3] /=0)) THEN
- ALLOCATE (nr_(3))
- nr_ = [ip_nr1,ip_nr2,ip_nr3]
+ nr_1_ = ip_nr1
+ nr_1 => nr_1_
+ nr_2_ = ip_nr2
+ nr_2 => nr_2_
+ nr_3_ = ip_nr3
+ nr_3 => nr_3_
END IF
IF (ANY([ip_nr1s,ip_nr2s,ip_nr3s] /=0)) THEN
- ALLOCATE (nrs_(3))
- nrs_ = [ip_nr1s,ip_nr2s,ip_nr3s]
+ nrs_1_ = ip_nr1s
+ nrs_1 => nrs_1_
+ nrs_2_ = ip_nr2s
+ nrs_2 => nrs_2_
+ nrs_3_ = ip_nr3
+ nrs_3 => nrs_3_
END IF
IF (ANY([ip_nr1b,ip_nr2b,ip_nr3b] /=0)) THEN
- ALLOCATE(nrb_(3))
- nrb_ = [ip_nr1b,ip_nr2b,ip_nr3b]
+ nrb_1_ = ip_nr1b
+ nrb_1 => nrb_1_
+ nrb_2_ = ip_nr2b
+ nrb_2 => nrb_2_
+ nrb_3_ = ip_nr3b
+ nrb_3 => nrb_3_
END IF
- CALL qexsd_init_basis(obj%basis, ip_k_points, ecutwfc/e2, ip_ecutrho/e2, nr_ , nrs_, nrb_ )
+CALL qexsd_init_basis(obj%basis, ip_k_points, ecutwfc/e2, ip_ecutrho/e2, nr_1, nr_2, nr_3, nrs_1, nrs_2, nrs_3, &
+ nrb_1, nrb_2, nrb_3 )
!-----------------------------------------------------------------------------------------------------------------------------
! ELECTRON CONTROL
!------------------------------------------------------------------------------------------------------------------------------