1! Copyright (C) 2019 Quantum ESPRESSO group 2! This file is distributed under the terms of the 3! GNU General Public License. See the file `License' 4! in the root directory of the present distribution, 5! or http://www.gnu.org/copyleft/gpl.txt . 6! 7!---------------------------------------------------------------------------- 8MODULE qexsd_copy 9 !---------------------------------------------------------------------------- 10 ! 11 ! This module contains some common subroutines used to copy data read from 12 ! XML format into data used by the Quantum ESPRESSO package. 13 ! 14 ! Written by Paolo Giannozzi, building upon pre-existing code 15 ! 16 USE kinds, ONLY : dp 17 IMPLICIT NONE 18 ! 19 PRIVATE 20 SAVE 21 ! 22 PUBLIC:: qexsd_copy_geninfo, qexsd_copy_parallel_info, & 23 qexsd_copy_atomic_species, qexsd_copy_atomic_structure, & 24 qexsd_copy_symmetry, qexsd_copy_algorithmic_info, & 25 qexsd_copy_basis_set, qexsd_copy_dft, qexsd_copy_band_structure, & 26 qexsd_copy_efield, qexsd_copy_magnetization, qexsd_copy_kpoints, & 27 qexsd_copy_efermi 28 ! 29CONTAINS 30 !------------------------------------------------------------------------------- 31 SUBROUTINE qexsd_copy_geninfo (geninfo_obj, qexsd_fmt, qexsd_version) 32 !------------------------------------------------------------------------------- 33 ! 34 USE io_files, ONLY: qexsd_init 35 USE qes_types_module, ONLY: general_info_type 36 IMPLICIT NONE 37 ! 38 TYPE (general_info_type ),INTENT(IN) :: geninfo_obj 39 CHARACTER(LEN=*), INTENT(OUT) :: qexsd_fmt, qexsd_version 40 ! 41 IF ( qexsd_init ) RETURN 42 qexsd_fmt = TRIM (geninfo_obj%xml_format%NAME) 43 qexsd_version = TRIM ( geninfo_obj%xml_format%VERSION) 44 qexsd_init = .TRUE. 45 ! 46 END SUBROUTINE qexsd_copy_geninfo 47 ! 48 ! 49 !--------------------------------------------------------------------------- 50 SUBROUTINE qexsd_copy_parallel_info (parinfo_obj, nproc_file, & 51 nproc_pool_file, nproc_image_file, ntask_groups_file, & 52 nproc_bgrp_file, nproc_ortho_file) 53 !--------------------------------------------------------------------------- ! 54 USE qes_types_module, ONLY : parallel_info_type 55 ! 56 IMPLICIT NONE 57 ! 58 TYPE ( parallel_info_type ),INTENT(IN) :: parinfo_obj 59 INTEGER, INTENT(OUT) :: nproc_file, nproc_pool_file, & 60 nproc_image_file, ntask_groups_file, & 61 nproc_bgrp_file, nproc_ortho_file 62 ! 63 nproc_file = parinfo_obj%nprocs 64 nproc_pool_file = nproc_file/parinfo_obj%npool 65 nproc_image_file = nproc_file 66 ntask_groups_file = parinfo_obj%ntasks 67 nproc_bgrp_file = nproc_image_file / parinfo_obj%npool / parinfo_obj%nbgrp 68 nproc_ortho_file = parinfo_obj%ndiag 69 ! 70 END SUBROUTINE qexsd_copy_parallel_info 71 ! 72 !-------------------------------------------------------------------------- 73 SUBROUTINE qexsd_copy_atomic_species (atomic_species, nsp, atm, amass, & 74 starting_magnetization, angle1, angle2, psfile, pseudo_dir) 75 !--------------------------------------------------------------------------- ! 76 USE qes_types_module, ONLY : atomic_species_type 77 ! 78 IMPLICIT NONE 79 ! 80 TYPE ( atomic_species_type ),INTENT(IN) :: atomic_species 81 INTEGER, INTENT(out) :: nsp 82 CHARACTER(LEN=*), INTENT(out) :: atm(:) 83 REAL(dp), INTENT(out) :: amass(:) 84 REAL(dp), OPTIONAL, INTENT(out) :: starting_magnetization(:), & 85 angle1(:), angle2(:) 86 CHARACTER(LEN=*), OPTIONAL, INTENT(out) :: psfile(:), pseudo_dir 87 ! 88 INTEGER :: isp 89 ! 90 nsp = atomic_species%ntyp 91 DO isp = 1, nsp 92 amass(isp) = 0.d0 93 IF (atomic_species%species(isp)%mass_ispresent) & 94 amass(isp) = atomic_species%species(isp)%mass 95 atm(isp) = TRIM ( atomic_species%species(isp)%name ) 96 IF ( PRESENT (psfile) ) THEN 97 psfile(isp) = TRIM ( atomic_species%species(isp)%pseudo_file) 98 END IF 99 IF ( PRESENT (starting_magnetization) ) THEN 100 IF ( atomic_species%species(isp)%starting_magnetization_ispresent) THEN 101 starting_magnetization(isp) = atomic_species%species(isp)%starting_magnetization 102 END IF 103 END IF 104 IF ( PRESENT (angle1) ) THEN 105 IF ( atomic_species%species(isp)%spin_teta_ispresent ) THEN 106 angle1(isp) = atomic_species%species(isp)%spin_teta 107 END IF 108 END IF 109 IF ( PRESENT (angle2) ) THEN 110 IF ( atomic_species%species(isp)%spin_phi_ispresent ) THEN 111 angle2(isp) = atomic_species%species(isp)%spin_phi 112 END IF 113 END IF 114 END DO 115 ! 116 ! ... this is where PP files were originally found (if available) 117 ! 118 IF ( PRESENT (pseudo_dir) ) THEN 119 IF ( atomic_species%pseudo_dir_ispresent) THEN 120 pseudo_dir = TRIM(atomic_species%pseudo_dir) 121 ELSE 122 pseudo_dir = ' ' 123 END IF 124 END IF 125 ! 126 END SUBROUTINE qexsd_copy_atomic_species 127 128 !-------------------------------------------------------------------------- 129 SUBROUTINE qexsd_copy_atomic_structure (atomic_structure, nsp, atm, & 130 nat, tau, ityp, alat, a1, a2, a3, ibrav ) 131 !-------------------------------------------------------------------------- 132 133 USE qes_types_module, ONLY : atomic_structure_type 134 ! 135 IMPLICIT NONE 136 ! 137 TYPE ( atomic_structure_type ),INTENT(IN) :: atomic_structure 138 INTEGER, INTENT(in) :: nsp 139 CHARACTER(LEN = 3), INTENT(in) :: atm(:) 140 ! 141 INTEGER, INTENT(out) :: nat, ibrav 142 REAL(dp), INTENT(out) :: alat, a1(:), a2(:), a3(:) 143 INTEGER, INTENT(inout), ALLOCATABLE :: ityp(:) 144 REAL(dp), INTENT(inout), ALLOCATABLE :: tau(:,:) 145 ! 146 CHARACTER(LEN=3), ALLOCATABLE :: symbols(:) 147 INTEGER :: iat, idx, isp 148 ! 149 nat = atomic_structure%nat 150 alat = atomic_structure%alat 151 IF ( atomic_structure%bravais_index_ispresent ) THEN 152 ibrav = atomic_structure%bravais_index 153 IF (atomic_structure%alternative_axes_ispresent ) THEN 154 SELECT CASE(ibrav) 155 CASE(3) 156 IF (TRIM(atomic_structure%alternative_axes)=="b:a-b+c:-c") THEN 157 ibrav = -ibrav 158 ELSE 159 CALL errore("qexsd_copy_atomic_structure:","alternative axes not recognised", 1) 160 END IF 161 CASE(5) 162 IF (TRIM(atomic_structure%alternative_axes)=="3fold-111") THEN 163 ibrav = -ibrav 164 ELSE 165 CALL errore("qexsd_copy_atomic_structure:","alternative axes not recognised", 1) 166 END IF 167 CASE(9) 168 IF (TRIM(atomic_structure%alternative_axes)=="-b:a:c") THEN 169 ibrav = -ibrav 170 ELSE IF( TRIM(atomic_structure%alternative_axes)=="bcoA-type") THEN 171 ibrav = 91 172 ELSE 173 CALL errore("qexsd_copy_atomic_structure:","alternative axes not recognised", 1) 174 END IF 175 CASE(13,12) 176 IF (TRIM(atomic_structure%alternative_axes)=="unique-axis-b") THEN 177 ibrav = -ibrav 178 ELSE 179 CALL errore("qexsd_copy_atomic_structure:","alternativ axes not recognised", 1) 180 END IF 181 END SELECT 182 END IF 183 ELSE 184 ibrav = 0 185 END IF 186 IF ( .NOT. ALLOCATED(tau) ) ALLOCATE(tau(3,nat)) 187 IF ( .NOT. ALLOCATED(ityp)) ALLOCATE(ityp(nat)) 188 ALLOCATE ( symbols(nat) ) 189 loop_on_atoms:DO iat = 1, nat 190 idx = atomic_structure%atomic_positions%atom(iat)%index 191 tau(:,idx) = atomic_structure%atomic_positions%atom(iat)%atom 192 symbols(idx) = TRIM ( atomic_structure%atomic_positions%atom(idx)%name) 193 loop_on_species:DO isp = 1, nsp 194 IF ( TRIM(symbols(idx)) == TRIM (atm(isp))) THEN 195 ityp(iat) = isp 196 exit loop_on_species 197 END IF 198 END DO loop_on_species 199 END DO loop_on_atoms 200 DEALLOCATE (symbols) 201 IF ( atomic_structure%alat_ispresent ) alat = atomic_structure%alat 202 a1(:) = atomic_structure%cell%a1 203 a2(:) = atomic_structure%cell%a2 204 a3(:) = atomic_structure%cell%a3 205 206 END SUBROUTINE qexsd_copy_atomic_structure 207 ! 208 !------------------------------------------------------------------------ 209 SUBROUTINE qexsd_copy_symmetry ( symms_obj, & 210 nsym, nrot, s, ft, sname, t_rev, invsym, irt, & 211 noinv, nosym, no_t_rev, flags_obj ) 212 !------------------------------------------------------------------------ 213 ! 214 USE qes_types_module,ONLY : symmetries_type, symmetry_flags_type 215 ! 216 IMPLICIT NONE 217 ! 218 TYPE ( symmetries_type ) :: symms_obj 219 TYPE (symmetry_flags_type), OPTIONAL :: flags_obj 220 INTEGER, INTENT(OUT) :: nrot 221 INTEGER, INTENT(OUT) :: nsym 222 INTEGER, INTENT(OUT) :: s(:,:,:) 223 LOGICAL, INTENT(OUT) :: invsym 224 REAL(dp), INTENT(OUT):: ft(:,:) 225 INTEGER, INTENT(OUT) :: irt(:,:) 226 INTEGER, INTENT(OUT) :: t_rev(:) 227 CHARACTER(len=45) :: sname(:) 228 ! 229 LOGICAL, INTENT(OUT) :: noinv, nosym, no_t_rev 230 ! 231 INTEGER :: isym 232 ! 233 IF ( PRESENT(flags_obj) ) THEN 234 noinv = flags_obj%noinv 235 nosym = flags_obj%nosym 236 no_t_rev = flags_obj%no_t_rev 237 ELSE 238 noinv = .FALSE. 239 nosym = .FALSE. 240 no_t_rev=.FALSE. 241 ENDIF 242 ! 243 nrot = symms_obj%nrot 244 nsym = symms_obj%nsym 245 ! 246 invsym = .FALSE. 247 DO isym = 1, nrot 248 s(:,:,isym) = reshape(symms_obj%symmetry(isym)%rotation%matrix, [3,3]) 249 sname(isym) = TRIM ( symms_obj%symmetry(isym)%info%name ) 250 IF ( (TRIM(sname(isym)) == "inversion") .AND. (isym .LE. nsym) ) invsym = .TRUE. 251 IF ( symms_obj%symmetry(isym)%fractional_translation_ispresent .AND. (isym .LE. nsym) ) THEN 252 ft(1:3,isym) = symms_obj%symmetry(isym)%fractional_translation(1:3) 253 END IF 254 IF ( symms_obj%symmetry(isym)%info%time_reversal_ispresent ) THEN 255 IF (symms_obj%symmetry(isym)%info%time_reversal) THEN 256 t_rev( isym ) = 1 257 ELSE 258 t_rev( isym ) = 0 259 END IF 260 END IF 261 IF ( symms_obj%symmetry(isym)%equivalent_atoms_ispresent .AND. (isym .LE. nsym) ) & 262 irt(isym,:) = symms_obj%symmetry(isym)%equivalent_atoms%equivalent_atoms(:) 263 END DO 264 ! 265 END SUBROUTINE qexsd_copy_symmetry 266 ! 267 268 !-------------------------------------------------------------------------- 269 SUBROUTINE qexsd_copy_basis_set ( basis_set, gamma_only, ecutwfc, ecutrho, & 270 nr1s, nr2s, nr3s, nr1, nr2, nr3, nr1b, nr2b, nr3b, & 271 ngm_g, ngms_g, npw_g, b1, b2, b3 ) 272 !-------------------------------------------------------------------------- 273 ! 274 USE qes_types_module, ONLY : basis_set_type 275 ! 276 IMPLICIT NONE 277 TYPE ( basis_set_type ),INTENT(IN) :: basis_set 278 LOGICAL, INTENT(out) :: gamma_only 279 INTEGER, INTENT(out) :: ngm_g, ngms_g, npw_g 280 INTEGER, INTENT(out) :: nr1s, nr2s, nr3s, nr1, nr2, nr3 281 INTEGER, INTENT(inout) :: nr1b, nr2b, nr3b 282 REAL(dp), INTENT(out) :: ecutwfc, ecutrho, b1(:), b2(:), b3(:) 283 ! 284 ecutwfc = basis_set%ecutwfc 285 ecutrho = basis_set%ecutrho 286 gamma_only= basis_set%gamma_only 287 nr1 = basis_set%fft_grid%nr1 288 nr2 = basis_set%fft_grid%nr2 289 nr3 = basis_set%fft_grid%nr3 290 nr1s= basis_set%fft_smooth%nr1 291 nr2s= basis_set%fft_smooth%nr2 292 nr3s= basis_set%fft_smooth%nr3 293 IF ( basis_set%fft_box_ispresent ) THEN 294 nr1b = basis_set%fft_box%nr1 295 nr2b = basis_set%fft_box%nr2 296 nr3b = basis_set%fft_box%nr3 297 END IF 298 ngm_g = basis_set%ngm 299 ngms_g = basis_set%ngms 300 npw_g = basis_set%npwx 301 ! 302 b1 = basis_set%reciprocal_lattice%b1 303 b2 = basis_set%reciprocal_lattice%b2 304 b3 = basis_set%reciprocal_lattice%b3 305 ! 306 END SUBROUTINE qexsd_copy_basis_set 307 ! 308 !----------------------------------------------------------------------- 309 SUBROUTINE qexsd_copy_dft ( dft_obj, nsp, atm, & 310 dft_name, nq1, nq2, nq3, ecutfock, exx_fraction, screening_parameter, & 311 exxdiv_treatment, x_gamma_extrapolation, ecutvcut, local_thr, & 312 lda_plus_U, lda_plus_U_kind, U_projection, Hubbard_l, Hubbard_lmax, & 313 Hubbard_l_back, Hubbard_l1_back, backall, Hubbard_lmax_back, Hubbard_alpha_back, & 314 Hubbard_U, Hubbard_U_back, Hubbard_J0, Hubbard_alpha, Hubbard_beta, Hubbard_J, & 315 vdw_corr, scal6, lon_rcut, vdw_isolated ) 316 !------------------------------------------------------------------- 317 ! 318 USE qes_types_module, ONLY : dft_type 319 ! 320 IMPLICIT NONE 321 TYPE ( dft_type ),INTENT(in) :: dft_obj 322 INTEGER, INTENT(in) :: nsp 323 CHARACTER(LEN=*), INTENT(in) :: atm(nsp) 324 ! 325 CHARACTER(LEN=*), INTENT(out) :: dft_name 326 ! Variables that may or may not be present should be intent(inout) 327 ! so that they do not forget their default value (if any) 328 CHARACTER(LEN=*), INTENT(inout) :: exxdiv_treatment 329 REAL(dp), INTENT(inout) :: ecutfock, exx_fraction, screening_parameter, & 330 ecutvcut, local_thr 331 INTEGER, INTENT(inout) :: nq1, nq2, nq3 332 LOGICAL, INTENT(inout) :: x_gamma_extrapolation 333 ! 334 LOGICAL, INTENT(out) :: lda_plus_U 335 INTEGER, INTENT(inout) :: lda_plus_U_kind, Hubbard_lmax, Hubbard_lmax_back 336 CHARACTER(LEN=*), INTENT(inout) :: U_projection 337 INTEGER, INTENT(inout) :: Hubbard_l(:), Hubbard_l_back(:), Hubbard_l1_back(:) 338 REAL(dp), INTENT(inout) :: Hubbard_U(:), Hubbard_U_back(:), Hubbard_J0(:), Hubbard_J(:,:), & 339 Hubbard_alpha(:), Hubbard_alpha_back(:), Hubbard_beta(:) 340 LOGICAL, INTENT(inout) :: backall(:) 341 OPTIONAL :: Hubbard_U_back, Hubbard_l_back, Hubbard_lmax_back, Hubbard_alpha_back, & 342 Hubbard_l1_back 343 ! 344 CHARACTER(LEN=*), INTENT(out) :: vdw_corr 345 REAL(dp), INTENT(inout) :: scal6, lon_rcut 346 LOGICAL, INTENT(inout) :: vdw_isolated 347 ! 348 CHARACTER(LEN=256 ) :: label 349 CHARACTER(LEN=3 ) :: symbol 350 INTEGER :: ihub, isp 351 ! 352 dft_name = TRIM(dft_obj%functional) 353 IF ( dft_obj%hybrid_ispresent ) THEN 354 nq1 = dft_obj%hybrid%qpoint_grid%nqx1 355 nq2 = dft_obj%hybrid%qpoint_grid%nqx2 356 nq3 = dft_obj%hybrid%qpoint_grid%nqx3 357 ecutfock = dft_obj%hybrid%ecutfock 358 exx_fraction = dft_obj%hybrid%exx_fraction 359 screening_parameter = dft_obj%hybrid%screening_parameter 360 exxdiv_treatment = dft_obj%hybrid%exxdiv_treatment 361 x_gamma_extrapolation = dft_obj%hybrid%x_gamma_extrapolation 362 ecutvcut = dft_obj%hybrid%ecutvcut 363 IF (dft_obj%hybrid%localization_threshold_ispresent) THEN 364 local_thr = dft_obj%hybrid%localization_threshold 365 ELSE 366 local_thr = 0._DP 367 END IF 368 END IF 369 ! 370 lda_plus_u = dft_obj%dftU_ispresent 371 IF ( lda_plus_u ) THEN 372 Hubbard_U = 0.0_DP 373 Hubbard_U_back =0.0_DP 374 Hubbard_alpha = 0.0_DP 375 Hubbard_alpha_back = 0.0_DP 376 Hubbard_J = 0.0_DP 377 Hubbard_J0 = 0.0_DP 378 Hubbard_beta = 0.0_DP 379 lda_plus_u_kind = dft_obj%dftU%lda_plus_u_kind 380 U_projection = TRIM ( dft_obj%dftU%U_projection_type ) 381 Hubbard_l =-1 382 Hubbard_l_back =-1 383 backall = .false. 384 ! 385 IF ( dft_obj%dftU%Hubbard_U_ispresent) THEN 386 loop_on_hubbardU:DO ihub =1, dft_obj%dftU%ndim_Hubbard_U 387 symbol = TRIM(dft_obj%dftU%Hubbard_U(ihub)%specie) 388 label = TRIM(dft_obj%dftU%Hubbard_U(ihub)%label ) 389 loop_on_speciesU:DO isp = 1, nsp 390 IF ( TRIM(symbol) == TRIM ( atm(isp) ) ) THEN 391 Hubbard_U(isp) = dft_obj%dftU%Hubbard_U(ihub)%HubbardCommon 392 SELECT CASE ( TRIM (label)) 393 CASE ( '1s', '2s', '3s', '4s', '5s', '6s', '7s' ) 394 Hubbard_l(isp) = 0 395 CASE ( '2p', '3p', '4p', '5p', '6p' ) 396 Hubbard_l(isp) = 1 397 CASE ( '3d', '4d', '5d' ) 398 Hubbard_l( isp ) = 2 399 CASE ( '4f', '5f' ) 400 Hubbard_l(isp ) = 3 401 CASE default 402 IF (Hubbard_U(isp)/=0) & 403 CALL errore ("qexsd_copy_dft:", "unrecognized label for Hubbard "//label, 1 ) 404 END SELECT 405 EXIT loop_on_speciesU 406 END IF 407 END DO loop_on_speciesU 408 END DO loop_on_hubbardU 409 END IF 410 ! 411 IF ( dft_obj%dftU%Hubbard_U_back_ispresent) THEN 412 loop_on_hubbardUback:DO ihub =1, dft_obj%dftU%ndim_Hubbard_U_back 413 symbol = TRIM(dft_obj%dftU%Hubbard_U_back(ihub)%specie) 414 label = TRIM(dft_obj%dftU%Hubbard_U_back(ihub)%label ) 415 loop_on_speciesU_back:DO isp = 1, nsp 416 IF ( TRIM(symbol) == TRIM ( atm(isp) ) ) THEN 417 Hubbard_U_back(isp) = dft_obj%dftU%Hubbard_U_back(ihub)%HubbardCommon 418 EXIT loop_on_speciesU_back 419 END IF 420 END DO loop_on_speciesU_back 421 END DO loop_on_hubbardUback 422 IF (.NOT. dft_obj%dftU%Hubbard_back_ispresent) CALL errore("qexsd_copy:", & 423 "internal error: U_back is present but not Hub_back",1) 424 loop_hubbardBack: DO ihub =1, dft_obj%dftU%ndim_Hubbard_back 425 symbol = TRIM(dft_obj%dftU%Hubbard_back(ihub)%species) 426 loop_on_species_2:DO isp = 1, nsp 427 IF ( TRIM(symbol) == TRIM(atm(isp))) THEN 428 Hubbard_l_back(isp) = dft_obj%dftU%Hubbard_back(ihub)%l_number(1)%backL 429 SELECT CASE ( TRIM (dft_obj%dftU%Hubbard_back(ihub)%background)) 430 CASE ('one_orbital') 431 backall(isp) = .FALSE. 432 CASE ('two_orbitals') 433 backall(isp) = .TRUE. 434 Hubbard_l1_back(isp) = dft_obj%dftU%Hubbard_back(ihub)%l_number(2)%backL 435 END SELECT 436 EXIT loop_on_species_2 437 END IF 438 END DO loop_on_species_2 439 END DO loop_hubbardBack 440 441 END IF 442 443 ! 444 IF ( dft_obj%dftU%Hubbard_J0_ispresent ) THEN 445 loop_on_hubbardj0:DO ihub =1, dft_obj%dftU%ndim_Hubbard_J0 446 symbol = TRIM(dft_obj%dftU%Hubbard_J0(ihub)%specie) 447 loop_on_speciesj0:DO isp = 1, nsp 448 IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN 449 Hubbard_J0(isp) = dft_obj%dftU%Hubbard_J0(ihub)%HubbardCommon 450 EXIT loop_on_speciesj0 451 END IF 452 END DO loop_on_speciesj0 453 END DO loop_on_hubbardj0 454 END IF 455 ! 456 IF ( dft_obj%dftU%Hubbard_alpha_ispresent) THEN 457 loop_on_hubbardAlpha:DO ihub =1, dft_obj%dftU%ndim_Hubbard_alpha 458 symbol = TRIM(dft_obj%dftU%Hubbard_alpha(ihub)%specie) 459 loop_on_speciesAlpha:DO isp = 1, nsp 460 IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN 461 Hubbard_alpha(isp) = dft_obj%dftU%Hubbard_alpha(ihub)%HubbardCommon 462 EXIT loop_on_speciesAlpha 463 END IF 464 END DO loop_on_speciesAlpha 465 END DO loop_on_hubbardAlpha 466 END IF 467 ! 468 IF ( dft_obj%dftU%Hubbard_alpha_back_ispresent) THEN 469 loop_on_hubbardAlphaBack:DO ihub =1, dft_obj%dftU%ndim_Hubbard_alpha_back 470 symbol = TRIM(dft_obj%dftU%Hubbard_alpha_back(ihub)%specie) 471 loop_on_speciesAlphaBack:DO isp = 1, nsp 472 IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN 473 Hubbard_alpha_back(isp) = dft_obj%dftU%Hubbard_alpha_back(ihub)%HubbardCommon 474 EXIT loop_on_speciesAlphaBack 475 END IF 476 END DO loop_on_speciesAlphaBack 477 END DO loop_on_hubbardAlphaBack 478 END IF 479 ! 480 IF ( dft_obj%dftU%Hubbard_beta_ispresent) THEN 481 loop_on_hubbardBeta:DO ihub =1, dft_obj%dftU%ndim_Hubbard_beta 482 symbol = TRIM(dft_obj%dftU%Hubbard_beta(ihub)%specie) 483 loop_on_speciesBeta:DO isp = 1, nsp 484 IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN 485 Hubbard_beta(isp) = dft_obj%dftU%Hubbard_beta(ihub)%HubbardCommon 486 EXIT loop_on_speciesBeta 487 END IF 488 END DO loop_on_speciesBeta 489 END DO loop_on_hubbardBeta 490 END IF 491 ! 492 IF ( dft_obj%dftU%Hubbard_J_ispresent) THEN 493 loop_on_hubbardJ:DO ihub =1, dft_obj%dftU%ndim_Hubbard_J 494 symbol = TRIM(dft_obj%dftU%Hubbard_J(ihub)%specie) 495 loop_on_speciesJ:DO isp = 1, nsp 496 IF ( TRIM(symbol) == TRIM (atm(isp)) ) THEN 497 Hubbard_J(:,isp) = dft_obj%dftU%Hubbard_J(ihub)%HubbardJ 498 EXIT loop_on_speciesJ 499 END IF 500 END DO loop_on_speciesJ 501 END DO loop_on_hubbardJ 502 END IF 503 ! 504 Hubbard_lmax = MAXVAL( Hubbard_l(1:nsp) ) 505 Hubbard_lmax_back = MAXVAL( Hubbard_l_back(1:nsp) ) 506 ! 507 END IF 508 509 IF ( dft_obj%vdW_ispresent ) THEN 510 vdw_corr = TRIM( dft_obj%vdW%vdw_corr ) 511 ELSE 512 vdw_corr = '' 513 END IF 514 515 IF ( dft_obj%vdW_ispresent ) THEN 516 IF (dft_obj%vdW%london_s6_ispresent ) THEN 517 scal6 = dft_obj%vdW%london_s6 518 END IF 519 IF ( dft_obj%vdW%london_rcut_ispresent ) THEN 520 lon_rcut = dft_obj%vdW%london_rcut 521 END IF 522 IF (dft_obj%vdW%ts_vdW_isolated_ispresent ) THEN 523 vdW_isolated = dft_obj%vdW%ts_vdW_isolated 524 END IF 525 END IF 526 527 END SUBROUTINE qexsd_copy_dft 528 ! 529 !------------------------------------------------------------------------ 530 SUBROUTINE qexsd_copy_band_structure( band_struct_obj, lsda, nkstot, & 531 isk, natomwfc, nbnd, nbnd_up, nbnd_dw, nelec, xk, wk, wg, & 532 ef, ef_up, ef_dw, et ) 533 !------------------------------------------------------------------------ 534 ! 535 ! IMPORTANT NOTICE: IN LSDA CASE CONVERTS TO "PWSCF" LOGIC for k-points 536 ! 537 USE qes_types_module, ONLY : band_structure_type 538 ! 539 IMPLICIT NONE 540 TYPE ( band_structure_type) :: band_struct_obj 541 LOGICAL, INTENT(out) :: lsda 542 INTEGER, INTENT(out) :: nkstot, natomwfc, nbnd, nbnd_up, nbnd_dw, & 543 isk(:) 544 REAL(dp), INTENT(out):: nelec, ef, ef_up, ef_dw, xk(:,:), wk(:) 545 REAL(dp), INTENT(inout), ALLOCATABLE :: wg(:,:), et(:,:) 546 ! 547 LOGICAL :: two_fermi_energies 548 INTEGER :: ik 549 ! 550 lsda = band_struct_obj%lsda 551 nkstot = band_struct_obj%nks 552 natomwfc = band_struct_obj%num_of_atomic_wfc 553 ! 554 IF ( lsda) THEN 555 ! 556 IF (band_struct_obj%nbnd_ispresent) THEN 557 nbnd = band_struct_obj%nbnd / 2 558 ELSE IF ( band_struct_obj%nbnd_up_ispresent .AND. band_struct_obj%nbnd_dw_ispresent ) THEN 559 nbnd = (band_struct_obj%nbnd_up + band_struct_obj%nbnd_dw)/2 560 ELSE 561 CALL errore ('qexsd_copy_band_structure: ','both nbnd and nbnd_up+nbnd_dw missing', 1) 562 END IF 563 ! 564 IF ( band_struct_obj%nbnd_up_ispresent .AND. & 565 band_struct_obj%nbnd_dw_ispresent ) THEN 566 nbnd_up = band_struct_obj%nbnd_up 567 nbnd_dw = band_struct_obj%nbnd_dw 568 ELSE IF ( band_struct_obj%nbnd_up_ispresent ) THEN 569 nbnd_up = band_struct_obj%nbnd_up 570 nbnd_dw = band_struct_obj%ks_energies(ik)%eigenvalues%size - nbnd_up 571 ELSE IF ( band_struct_obj%nbnd_dw_ispresent ) THEN 572 nbnd_dw = band_struct_obj%nbnd_dw 573 nbnd_up = band_struct_obj%ks_energies(ik)%eigenvalues%size - nbnd_dw 574 ELSE 575 nbnd_up = band_struct_obj%ks_energies(ik)%eigenvalues%size/2 576 nbnd_dw = band_struct_obj%ks_energies(ik)%eigenvalues%size/2 577 END IF 578 ! 579 nkstot = nkstot * 2 580 isk(1:nkstot/2) = 1 581 isk(nkstot/2+1:nkstot) = 2 582 ELSE 583 IF (band_struct_obj%nbnd_ispresent) THEN 584 nbnd = band_struct_obj%nbnd 585 ELSE 586 CALL errore ('qexsd_copy_band_structure: ','nbnd missing', 1) 587 END IF 588 nbnd_up = nbnd 589 nbnd_dw = nbnd 590 isk(1:nkstot) = 1 591 END IF 592 ! 593 CALL qexsd_copy_efermi ( band_struct_obj, & 594 nelec, ef, two_fermi_energies, ef_up, ef_dw ) 595 ! 596 IF ( .NOT. ALLOCATED(et) ) ALLOCATE( et(nbnd,nkstot) ) 597 IF ( .NOT. ALLOCATED(wg) ) ALLOCATE( wg(nbnd,nkstot) ) 598 ! 599 DO ik =1, band_struct_obj%ndim_ks_energies 600 IF ( band_struct_obj%lsda) THEN 601 xk(:,ik) = band_struct_obj%ks_energies(ik)%k_point%k_point(:) 602 xk(:,ik + band_struct_obj%ndim_ks_energies) = xk(:,ik) 603 wk(ik) = band_struct_obj%ks_energies(ik)%k_point%weight 604 wk(ik + band_struct_obj%ndim_ks_energies ) = wk(ik) 605 et(1:nbnd_up,ik) = band_struct_obj%ks_energies(ik)%eigenvalues%vector(1:nbnd_up) 606 et(1:nbnd_dw,ik+band_struct_obj%ndim_ks_energies) = & 607 band_struct_obj%ks_energies(ik)%eigenvalues%vector(nbnd_up+1:nbnd_up+nbnd_dw) 608 wg(1:nbnd_up,ik) = & 609 band_struct_obj%ks_energies(ik)%occupations%vector(1:nbnd_up)*wk(ik) 610 wg(1:nbnd_dw,ik+band_struct_obj%ndim_ks_energies) = & 611 band_struct_obj%ks_energies(ik)%occupations%vector(nbnd_up+1:nbnd_up+nbnd_dw)*wk(ik) 612 ELSE 613 xk(:,ik) = band_struct_obj%ks_energies(ik)%k_point%k_point(:) 614 wk(ik) = band_struct_obj%ks_energies(ik)%k_point%weight 615 et (1:nbnd,ik) = band_struct_obj%ks_energies(ik)%eigenvalues%vector(1:nbnd) 616 wg (1:nbnd,ik) = band_struct_obj%ks_energies(ik)%occupations%vector(1:nbnd)*wk(ik) 617 END IF 618 ! 619 END DO 620 ! 621 END SUBROUTINE qexsd_copy_band_structure 622 ! 623 SUBROUTINE qexsd_copy_efermi ( band_struct_obj, & 624 nelec, ef, two_fermi_energies, ef_up, ef_dw ) 625 !------------------------------------------------------------------------ 626 ! 627 USE qes_types_module, ONLY : band_structure_type 628 ! 629 IMPLICIT NONE 630 TYPE ( band_structure_type) :: band_struct_obj 631 LOGICAL, INTENT(out) :: two_fermi_energies 632 REAL(dp), INTENT(out):: nelec, ef, ef_up, ef_dw 633 ! 634 nelec = band_struct_obj%nelec 635 two_fermi_energies = band_struct_obj%two_fermi_energies_ispresent 636 IF ( band_struct_obj%fermi_energy_ispresent) THEN 637 ef = band_struct_obj%fermi_energy 638 ef_up = 0.d0 639 ef_dw = 0.d0 640 ELSE IF ( two_fermi_energies ) THEN 641 ef = 0.d0 642 ef_up = band_struct_obj%two_fermi_energies(1) 643 ef_dw = band_struct_obj%two_fermi_energies(2) 644 ELSE 645 ef = 0.d0 646 ef_up = 0.d0 647 ef_dw = 0.d0 648 END IF 649 ! 650 END SUBROUTINE qexsd_copy_efermi 651 !----------------------------------------------------------------------- 652 SUBROUTINE qexsd_copy_algorithmic_info ( algo_obj, & 653 real_space, tqr, okvan, okpaw ) 654 USE qes_types_module, ONLY: algorithmic_info_type 655 IMPLICIT NONE 656 TYPE(algorithmic_info_type),INTENT(IN) :: algo_obj 657 LOGICAL, INTENT(OUT) :: real_space, tqr, okvan, okpaw 658 ! 659 tqr = algo_obj%real_space_q 660 real_space = algo_obj%real_space_beta 661 okvan = algo_obj%uspp 662 okpaw = algo_obj%paw 663 ! 664 END SUBROUTINE qexsd_copy_algorithmic_info 665 !----------------------------------------------------------------------- 666 ! 667 !--------------------------------------------------------------------------- 668 SUBROUTINE qexsd_copy_efield ( efield_obj, tefield, dipfield, edir, & 669 emaxpos, eopreg, eamp, gate, zgate, & 670 block_, block_1, block_2, block_height, relaxz ) 671 !--------------------------------------------------------------------------- 672 USE qes_types_module, ONLY: electric_field_type 673 IMPLICIT NONE 674 ! 675 TYPE ( electric_field_type),OPTIONAL, INTENT(IN) :: efield_obj 676 LOGICAL, INTENT(OUT) :: tefield, dipfield 677 INTEGER, INTENT(INOUT) :: edir 678 LOGICAL, INTENT(INOUT) :: gate, block_, relaxz 679 REAL(dp), INTENT(INOUT) :: emaxpos, eopreg, eamp, & 680 zgate, block_1, block_2, block_height 681 ! 682 ! 683 tefield = .FALSE. 684 dipfield = .FALSE. 685 IF ( .NOT. PRESENT( efield_obj) ) RETURN 686 IF (TRIM(efield_obj%electric_potential) == 'sawtooth_potential') THEN 687 tefield = .TRUE. 688 IF ( efield_obj%dipole_correction_ispresent ) THEN 689 dipfield = efield_obj%dipole_correction 690 ELSE 691 dipfield = .FALSE. 692 END IF 693 IF ( efield_obj%electric_field_direction_ispresent ) THEN 694 edir = efield_obj%electric_field_direction 695 ELSE 696 edir = 3 697 END IF 698 IF ( efield_obj%potential_max_position_ispresent ) THEN 699 emaxpos = efield_obj%potential_max_position 700 ELSE 701 emaxpos = 5d-1 702 END IF 703 IF ( efield_obj%potential_decrease_width_ispresent ) THEN 704 eopreg = efield_obj%potential_decrease_width 705 ELSE 706 eopreg = 1.d-1 707 END IF 708 IF ( efield_obj%electric_field_amplitude_ispresent ) THEN 709 eamp = efield_obj%electric_field_amplitude 710 ELSE 711 eamp = 1.d-3 712 END IF 713 IF (efield_obj%gate_settings_ispresent) THEN 714 gate = efield_obj%gate_settings%use_gate 715 IF (efield_obj%gate_settings%zgate_ispresent) & 716 zgate = efield_obj%gate_settings%zgate 717 IF (efield_obj%gate_settings%relaxz_ispresent) & 718 relaxz = efield_obj%gate_settings%relaxz 719 IF (efield_obj%gate_settings%block_ispresent) & 720 block_ = efield_obj%gate_settings%block 721 IF (efield_obj%gate_settings%block_1_ispresent) & 722 block_1 = efield_obj%gate_settings%block_1 723 IF (efield_obj%gate_settings%block_2_ispresent) & 724 block_2 = efield_obj%gate_settings%block_2 725 IF (efield_obj%gate_settings%block_height_ispresent) & 726 block_height = efield_obj%gate_settings%block_height 727 END IF 728 END IF 729 ! 730 END SUBROUTINE qexsd_copy_efield 731 ! 732 !-------------------------------------------------------------------------- 733 SUBROUTINE qexsd_copy_magnetization ( magnetization_obj, & 734 lsda, noncolin, lspinorb, domag, tot_magnetization ) 735 !------------------------------------------------------------------------ 736 ! 737 USE qes_types_module, ONLY : magnetization_type 738 ! 739 IMPLICIT NONE 740 ! 741 TYPE ( magnetization_type ) ,INTENT(IN) :: magnetization_obj 742 LOGICAL, INTENT(OUT) :: lsda, noncolin, lspinorb, domag 743 REAL(dp), INTENT(OUT) :: tot_magnetization 744 ! 745 lsda = magnetization_obj%lsda 746 noncolin = magnetization_obj%noncolin 747 lspinorb = magnetization_obj%spinorbit 748 domag = magnetization_obj%do_magnetization 749 tot_magnetization = magnetization_obj%total 750 ! 751 END SUBROUTINE qexsd_copy_magnetization 752 !----------------------------------------------------------------------- 753 ! 754 !--------------------------------------------------------------------------- 755 SUBROUTINE qexsd_copy_kpoints ( band_struct_obj, nks_start, xk_start,& 756 wk_start, nk1, nk2, nk3, k1, k2, k3, occupations, smearing, degauss ) 757 !--------------------------------------------------------------------------- 758 ! 759 USE qes_types_module, ONLY : band_structure_type 760 ! 761 IMPLICIT NONE 762 ! 763 TYPE ( band_structure_type ),INTENT(IN) :: band_struct_obj 764 INTEGER, INTENT(out) :: nks_start, nk1, nk2, nk3, k1, k2, k3 765 REAL(dp), ALLOCATABLE, INTENT(inout) :: xk_start(:,:), wk_start(:) 766 REAL(dp), INTENT(out) :: degauss 767 CHARACTER(LEN=*), intent(out) :: smearing, occupations 768 ! 769 INTEGER :: ik 770 ! 771 occupations = TRIM ( band_struct_obj%occupations_kind%occupations ) 772 smearing = TRIM ( band_struct_obj%smearing%smearing ) 773 degauss = band_struct_obj%smearing%degauss 774 ! 775 IF ( band_struct_obj%starting_k_points%monkhorst_pack_ispresent ) THEN 776 nks_start = 0 777 nk1 = band_struct_obj%starting_k_points%monkhorst_pack%nk1 778 nk2 = band_struct_obj%starting_k_points%monkhorst_pack%nk2 779 nk3 = band_struct_obj%starting_k_points%monkhorst_pack%nk3 780 k1 = band_struct_obj%starting_k_points%monkhorst_pack%k1 781 k2 = band_struct_obj%starting_k_points%monkhorst_pack%k2 782 k3 = band_struct_obj%starting_k_points%monkhorst_pack%k3 783 ELSE IF (band_struct_obj%starting_k_points%nk_ispresent ) THEN 784 nks_start = band_struct_obj%starting_k_points%nk 785 IF ( nks_start > 0 ) THEN 786 IF ( .NOT. ALLOCATED(xk_start) ) ALLOCATE (xk_start(3,nks_start)) 787 IF ( .NOT. ALLOCATED(wk_start) ) ALLOCATE (wk_start(nks_start)) 788 IF ( nks_start == size( band_struct_obj%starting_k_points%k_point ) ) THEN 789 DO ik =1, nks_start 790 xk_start(:,ik) = band_struct_obj%starting_k_points%k_point(ik)%k_point(:) 791 IF ( band_struct_obj%starting_k_points%k_point(ik)%weight_ispresent) THEN 792 wk_start(ik) = band_struct_obj%starting_k_points%k_point(ik)%weight 793 ELSE 794 wk_start(ik) = 0.d0 795 END IF 796 END DO 797 ELSE 798 CALL infomsg ( "qexsd_copy_kp: ", & 799 "actual number of start kpoint not equal to nks_start, set nks_start=0") 800 nks_start = 0 801 END IF 802 END IF 803 ELSE 804 CALL errore ("qexsd_copy_kp: ", & 805 " no information found for initializing brillouin zone information", 1) 806 END IF 807 ! 808 END SUBROUTINE qexsd_copy_kpoints 809 ! 810 END MODULE qexsd_copy 811