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