Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief Routines that process Quantum Espresso UPF files.
10 : !> \par History
11 : !> * 07.2018 CP2K-SIRIUS interface [Juerg Hutter]
12 : !> * 02.2016 created [Juerg Hutter]
13 : ! **************************************************************************************************
14 : MODULE atom_upf
15 : USE cp_parser_methods, ONLY: parser_get_next_line,&
16 : parser_get_object,&
17 : parser_test_next_token
18 : USE cp_parser_types, ONLY: cp_parser_type,&
19 : parser_create,&
20 : parser_release
21 : USE ieee_arithmetic, ONLY: ieee_is_finite
22 : USE kinds, ONLY: default_string_length,&
23 : dp
24 : USE periodic_table, ONLY: get_ptable_info,&
25 : ptable
26 : USE upf_types, ONLY: atom_upfpot_type,&
27 : upf_partial_waves_type,&
28 : upf_radial_weights,&
29 : upf_release
30 : #include "../base/base_uses.f90"
31 :
32 : IMPLICIT NONE
33 :
34 : PRIVATE
35 : PUBLIC :: atom_read_upf, atom_upfpot_type, atom_release_upf, upf_radial_weights, upf_partial_waves_type
36 :
37 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'atom_upf'
38 :
39 : ! **************************************************************************************************
40 :
41 : CONTAINS
42 :
43 : ! **************************************************************************************************
44 : !> \brief ...
45 : !> \param pot ...
46 : !> \param upf_filename ...
47 : !> \param read_header ...
48 : !> \param read_augmentation Import scalar USPP augmentation and optional full partial waves explicitly.
49 : !> This reader option does not enable USPP in a calculation method.
50 : ! **************************************************************************************************
51 38 : SUBROUTINE atom_read_upf(pot, upf_filename, read_header, read_augmentation)
52 :
53 : TYPE(atom_upfpot_type) :: pot
54 : CHARACTER(len=*), INTENT(IN) :: upf_filename
55 : LOGICAL, INTENT(IN), OPTIONAL :: read_header, read_augmentation
56 :
57 : CHARACTER(LEN=2) :: symbol
58 : INTEGER :: l, ncore, nel
59 : LOGICAL :: readall, readaug
60 :
61 38 : IF (PRESENT(read_header)) THEN
62 2 : readall = .NOT. read_header
63 : ELSE
64 36 : readall = .TRUE.
65 : END IF
66 38 : readaug = .FALSE.
67 38 : IF (PRESENT(read_augmentation)) readaug = read_augmentation
68 :
69 : ! filename
70 38 : pot%filename = ADJUSTL(TRIM(upf_filename))
71 :
72 : ! Ignore json potentials as SIRIUS will parse those on its own.
73 38 : l = LEN_TRIM(pot%filename)
74 38 : IF (l >= 5) THEN
75 38 : IF (pot%filename(l - 4:l) == '.json') THEN
76 0 : pot%zion = 0.0_dp
77 0 : RETURN
78 : END IF
79 : END IF
80 :
81 38 : CALL atom_read_upf_v2(pot, upf_filename, readall, readaug)
82 :
83 : ! set up econf
84 190 : IF (SUM(pot%econf) == 0) THEN
85 38 : symbol = ADJUSTL(TRIM(pot%symbol))
86 38 : CALL get_ptable_info(symbol, number=ncore)
87 190 : pot%econf(0:3) = ptable(ncore)%e_conv(0:3)
88 38 : nel = NINT(ncore - pot%zion)
89 0 : SELECT CASE (nel)
90 : CASE DEFAULT
91 0 : CPABORT("Unknown Core State")
92 : CASE (0)
93 : ! no core electron
94 : CASE (2)
95 50 : pot%econf(0:3) = pot%econf(0:3) - ptable(2)%e_conv(0:3)
96 : CASE (10)
97 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(10)%e_conv(0:3)
98 : CASE (18)
99 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(18)%e_conv(0:3)
100 : CASE (28)
101 30 : pot%econf(0:3) = pot%econf(0:3) - ptable(18)%e_conv(0:3)
102 6 : pot%econf(2) = pot%econf(2) - 10
103 : CASE (36)
104 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(36)%e_conv(0:3)
105 : CASE (46)
106 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(36)%e_conv(0:3)
107 0 : pot%econf(2) = pot%econf(2) - 10
108 : CASE (54)
109 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(54)%e_conv(0:3)
110 : CASE (60)
111 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(36)%e_conv(0:3)
112 0 : pot%econf(2) = pot%econf(2) - 10
113 0 : pot%econf(3) = pot%econf(3) - 14
114 : CASE (62)
115 : ! [Kr] 4d10 4f14 5s2 core, with 5p semicore in the valence (e.g. Pt).
116 10 : pot%econf(0:3) = pot%econf(0:3) - [10, 18, 20, 14]
117 : CASE (68)
118 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(54)%e_conv(0:3)
119 0 : pot%econf(3) = pot%econf(3) - 14
120 : CASE (78)
121 0 : pot%econf(0:3) = pot%econf(0:3) - ptable(54)%e_conv(0:3)
122 0 : pot%econf(2) = pot%econf(2) - 10
123 38 : pot%econf(3) = pot%econf(3) - 14
124 : END SELECT
125 : !
126 190 : CPASSERT(ALL(pot%econf >= 0))
127 : END IF
128 :
129 : ! name
130 38 : IF (pot%pname == "") THEN
131 38 : pot%pname = ADJUSTL(TRIM(pot%symbol))
132 : END IF
133 :
134 : END SUBROUTINE atom_read_upf
135 :
136 : ! **************************************************************************************************
137 : !> \brief ...
138 : !> \param pot ...
139 : !> \param upf_filename ...
140 : !> \param readall ...
141 : !> \param readaug Read scalar USPP augmentation arrays.
142 : ! **************************************************************************************************
143 38 : SUBROUTINE atom_read_upf_v2(pot, upf_filename, readall, readaug)
144 :
145 : TYPE(atom_upfpot_type) :: pot
146 : CHARACTER(len=*), INTENT(IN) :: upf_filename
147 : LOGICAL, INTENT(IN) :: readall, readaug
148 :
149 : CHARACTER(LEN=default_string_length) :: nametag
150 : INTEGER :: ib, ntag
151 : LOGICAL :: at_end
152 : TYPE(cp_parser_type) :: parser
153 :
154 38 : ntag = 0
155 38 : CALL parser_create(parser, upf_filename, apply_preprocessing=.FALSE.)
156 : DO
157 : at_end = .FALSE.
158 18948 : CALL parser_get_next_line(parser, 1, at_end)
159 18948 : IF (at_end) EXIT
160 18948 : CALL parser_get_object(parser, nametag, lower_to_upper=.TRUE.)
161 18948 : IF (nametag(1:1) /= "<") CYCLE
162 640 : IF (ntag == 0) THEN
163 : ! we are looking for UPF tag
164 38 : IF (nametag(2:4) == "UPF") THEN
165 38 : CALL parser_get_object(parser, nametag, lower_to_upper=.TRUE.)
166 : ! read UPF file version
167 38 : CALL parser_get_object(parser, nametag, lower_to_upper=.TRUE.)
168 38 : pot%version = TRIM(nametag)
169 38 : CPASSERT(nametag(1:5) == "2.0.1")
170 38 : CALL parser_get_object(parser, nametag, lower_to_upper=.TRUE.)
171 38 : CPASSERT(nametag(1:1) == ">")
172 : ntag = 1
173 : END IF
174 564 : ELSE IF (ntag == 1) THEN
175 : ! we are looking for 1st level tags
176 564 : IF (nametag(2:8) == "PP_INFO") THEN
177 28 : CPASSERT(nametag(9:9) == ">")
178 28 : CALL upf_info_section(parser, pot)
179 536 : ELSE IF (nametag(2:10) == "PP_HEADER") THEN
180 38 : IF (.NOT. (nametag(11:11) == ">")) THEN
181 38 : CALL upf_header_option(parser, pot)
182 : END IF
183 38 : IF (readaug .AND. pot%is_ultrasoft .AND. .NOT. pot%is_paw .AND. pot%has_wfc) THEN
184 2 : CPASSERT(.NOT. ALLOCATED(pot%partial_waves))
185 2 : ALLOCATE (pot%partial_waves)
186 : END IF
187 498 : ELSE IF (nametag(2:8) == "PP_MESH") THEN
188 38 : IF (.NOT. (nametag(9:9) == ">")) THEN
189 32 : CALL upf_mesh_option(parser, pot)
190 : END IF
191 38 : CALL upf_mesh_section(parser, pot)
192 460 : ELSE IF (nametag(2:8) == "PP_NLCC") THEN
193 6 : IF (nametag(9:9) == ">") THEN
194 0 : CALL upf_nlcc_section(parser, pot, .FALSE.)
195 : ELSE
196 6 : CALL upf_nlcc_section(parser, pot, .TRUE.)
197 : END IF
198 454 : ELSE IF (nametag(2:9) == "PP_LOCAL") THEN
199 38 : IF (nametag(10:10) == ">") THEN
200 6 : CALL upf_local_section(parser, pot, .FALSE.)
201 : ELSE
202 32 : CALL upf_local_section(parser, pot, .TRUE.)
203 : END IF
204 416 : ELSE IF (nametag(2:12) == "PP_NONLOCAL") THEN
205 38 : CPASSERT(nametag(13:13) == ">")
206 38 : CALL upf_nonlocal_section(parser, pot, readaug)
207 378 : ELSE IF (nametag(2:13) == "PP_SEMILOCAL") THEN
208 2 : CALL upf_semilocal_section(parser, pot)
209 376 : ELSE IF (nametag(2:9) == "PP_PSWFC") THEN
210 : ! skip section for now
211 338 : ELSE IF (nametag(2:12) == "PP_FULL_WFC") THEN
212 4 : IF (ALLOCATED(pot%partial_waves)) THEN
213 2 : CALL upf_full_wfc_section(parser, pot%partial_waves, nametag, pot%mesh_size, pot%number_of_proj)
214 : END IF
215 334 : ELSE IF (nametag(2:11) == "PP_RHOATOM") THEN
216 : ! skip section for now
217 306 : ELSE IF (nametag(2:7) == "PP_PAW") THEN
218 : ! skip section for now
219 306 : ELSE IF (nametag(2:6) == "/UPF>") THEN
220 : EXIT
221 : END IF
222 : END IF
223 : END DO
224 38 : CALL parser_release(parser)
225 :
226 38 : CPASSERT(ntag > 0)
227 :
228 : ! rescale projectors
229 38 : IF (ALLOCATED(pot%beta)) THEN
230 38 : CPASSERT(ALLOCATED(pot%r) .AND. ALLOCATED(pot%rab))
231 108 : DO ib = 1, pot%number_of_proj
232 108 : IF (pot%r(1) == 0.0_dp) THEN
233 39456 : pot%beta(2:, ib) = pot%beta(2:, ib)/pot%r(2:)
234 : ELSE
235 11532 : pot%beta(:, ib) = pot%beta(:, ib)/pot%r(:)
236 : END IF
237 : END DO
238 : END IF
239 :
240 : ! test for not supported options
241 38 : IF (readall) THEN
242 36 : IF (pot%is_ultrasoft .AND. .NOT. readaug) THEN
243 0 : CPABORT("UPF ultrasoft pseudopotential not implemented")
244 : END IF
245 36 : IF (pot%is_paw) THEN
246 0 : CPABORT("UPF PAW potential not implemented")
247 : END IF
248 : END IF
249 38 : IF (readaug .AND. pot%is_ultrasoft .AND. .NOT. pot%is_paw) THEN
250 6 : CPASSERT(ALLOCATED(pot%qij) .AND. ALLOCATED(pot%qijl))
251 : END IF
252 :
253 38 : IF (ALLOCATED(pot%partial_waves)) THEN
254 2 : CPASSERT(ALLOCATED(pot%partial_waves%ae_wfc))
255 2 : CPASSERT(ALLOCATED(pot%partial_waves%ps_wfc))
256 6 : CPASSERT(ALL(pot%partial_waves%angular_momenta == pot%lbeta))
257 : END IF
258 :
259 114 : END SUBROUTINE atom_read_upf_v2
260 :
261 : ! **************************************************************************************************
262 : !> \brief ...
263 : !> \param parser ...
264 : !> \param pot ...
265 : ! **************************************************************************************************
266 28 : SUBROUTINE upf_info_section(parser, pot)
267 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
268 : TYPE(atom_upfpot_type) :: pot
269 :
270 : CHARACTER(LEN=default_string_length) :: line, string
271 : INTEGER :: icount, iline
272 : LOGICAL :: at_end
273 :
274 28 : icount = 0
275 : DO
276 558 : CALL parser_get_next_line(parser, 1, at_end)
277 558 : CPASSERT(.NOT. at_end)
278 558 : iline = parser%buffer%present_line_number
279 558 : line = TRIM(parser%buffer%input_lines(iline))
280 558 : CALL parser_get_object(parser, string)
281 558 : IF (string(1:10) == "</PP_INFO>") EXIT
282 530 : icount = icount + 1
283 530 : IF (icount > pot%maxinfo) CYCLE
284 530 : pot%info(icount) = line
285 : END DO
286 28 : pot%maxinfo = icount
287 :
288 28 : END SUBROUTINE upf_info_section
289 :
290 : ! **************************************************************************************************
291 : !> \brief ...
292 : !> \param parser ...
293 : !> \param pot ...
294 : ! **************************************************************************************************
295 38 : SUBROUTINE upf_header_option(parser, pot)
296 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
297 : TYPE(atom_upfpot_type) :: pot
298 :
299 : CHARACTER(LEN=default_string_length) :: string
300 : LOGICAL :: at_end
301 :
302 : DO
303 834 : IF (parser_test_next_token(parser) == "EOL") THEN
304 704 : CALL parser_get_next_line(parser, 1, at_end)
305 1538 : CPASSERT(.NOT. at_end)
306 : END IF
307 834 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
308 834 : IF (string == "/>") EXIT
309 38 : SELECT CASE (string)
310 : CASE ("GENERATED")
311 28 : CALL parser_get_object(parser, pot%generated, allow_empty=.TRUE.)
312 : CASE ("AUTHOR")
313 28 : CALL parser_get_object(parser, pot%author, allow_empty=.TRUE.)
314 : CASE ("DATE")
315 28 : CALL parser_get_object(parser, pot%date, allow_empty=.TRUE.)
316 : CASE ("COMMENT")
317 28 : CALL parser_get_object(parser, pot%comment, allow_empty=.TRUE.)
318 : CASE ("ELEMENT")
319 38 : CALL parser_get_object(parser, pot%symbol)
320 38 : CPASSERT(2 <= LEN(pot%symbol))
321 : CASE ("PSEUDO_TYPE")
322 38 : CALL parser_get_object(parser, pot%pseudo_type)
323 : CASE ("RELATIVISTIC")
324 28 : CALL parser_get_object(parser, pot%relativistic)
325 : CASE ("IS_ULTRASOFT")
326 36 : CALL parser_get_object(parser, pot%is_ultrasoft)
327 : CASE ("IS_PAW")
328 34 : CALL parser_get_object(parser, pot%is_paw)
329 : CASE ("IS_COULOMB")
330 28 : CALL parser_get_object(parser, pot%is_coulomb)
331 : CASE ("HAS_SO")
332 28 : CALL parser_get_object(parser, pot%has_so)
333 : CASE ("HAS_WFC")
334 34 : CALL parser_get_object(parser, pot%has_wfc)
335 : CASE ("HAS_GIPAW")
336 28 : CALL parser_get_object(parser, pot%has_gipaw)
337 : CASE ("PAW_AS_GIPAW")
338 22 : CALL parser_get_object(parser, pot%paw_as_gipaw)
339 : CASE ("CORE_CORRECTION")
340 28 : CALL parser_get_object(parser, pot%core_correction)
341 : CASE ("FUNCTIONAL")
342 28 : CALL parser_get_object(parser, pot%functional)
343 : CASE ("Z_VALENCE")
344 38 : CALL parser_get_object(parser, pot%zion)
345 : CASE ("TOTAL_PSENERGY")
346 28 : CALL parser_get_object(parser, pot%total_psenergy)
347 : CASE ("WFC_CUTOFF")
348 22 : CALL parser_get_object(parser, pot%wfc_cutoff)
349 : CASE ("RHO_CUTOFF")
350 28 : CALL parser_get_object(parser, pot%rho_cutoff)
351 : CASE ("L_MAX")
352 38 : CALL parser_get_object(parser, pot%l_max)
353 : CASE ("L_MAX_RHO")
354 22 : CALL parser_get_object(parser, pot%l_max_rho)
355 : CASE ("L_LOCAL")
356 28 : CALL parser_get_object(parser, pot%l_local)
357 : CASE ("MESH_SIZE")
358 38 : CALL parser_get_object(parser, pot%mesh_size)
359 : CASE ("NUMBER_OF_WFC")
360 34 : CALL parser_get_object(parser, pot%number_of_wfc)
361 : CASE ("NUMBER_OF_PROJ")
362 38 : CALL parser_get_object(parser, pot%number_of_proj)
363 : CASE DEFAULT
364 0 : CPWARN(string)
365 : CALL cp_abort(__LOCATION__, "Error while parsing UPF header: "// &
366 796 : "Adjust format of delimiters ... only double quotes are admissible.")
367 : END SELECT
368 : END DO
369 :
370 38 : END SUBROUTINE upf_header_option
371 :
372 : ! **************************************************************************************************
373 : !> \brief ...
374 : !> \param parser ...
375 : !> \param pot ...
376 : ! **************************************************************************************************
377 32 : SUBROUTINE upf_mesh_option(parser, pot)
378 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
379 : TYPE(atom_upfpot_type) :: pot
380 :
381 : CHARACTER(LEN=default_string_length) :: string
382 : INTEGER :: jj
383 : LOGICAL :: at_end
384 :
385 : DO
386 152 : IF (parser_test_next_token(parser) == "EOL") THEN
387 22 : CALL parser_get_next_line(parser, 1, at_end)
388 174 : CPASSERT(.NOT. at_end)
389 : END IF
390 152 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
391 152 : IF (string == ">") EXIT
392 32 : SELECT CASE (string)
393 : CASE ("DX")
394 22 : CALL parser_get_object(parser, pot%dx)
395 : CASE ("XMIN")
396 22 : CALL parser_get_object(parser, pot%xmin)
397 : CASE ("RMAX")
398 22 : CALL parser_get_object(parser, pot%rmax)
399 : CASE ("MESH")
400 32 : CALL parser_get_object(parser, jj)
401 32 : CPASSERT(pot%mesh_size == jj)
402 : CASE ("ZMESH")
403 22 : CALL parser_get_object(parser, pot%zmesh)
404 : CASE DEFAULT
405 120 : CPABORT("Unknown UPF PP_MESH option <"//TRIM(string)//"> found")
406 : END SELECT
407 :
408 : END DO
409 :
410 32 : END SUBROUTINE upf_mesh_option
411 :
412 : ! **************************************************************************************************
413 : !> \brief ...
414 : !> \param parser ...
415 : !> \param pot ...
416 : ! **************************************************************************************************
417 38 : SUBROUTINE upf_mesh_section(parser, pot)
418 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
419 : TYPE(atom_upfpot_type) :: pot
420 :
421 : CHARACTER(LEN=default_string_length) :: line, string, string2
422 : INTEGER :: icount, m, mc, ms
423 : LOGICAL :: at_end
424 :
425 : DO
426 190 : CALL parser_get_next_line(parser, 1, at_end)
427 190 : CPASSERT(.NOT. at_end)
428 190 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
429 38 : SELECT CASE (string)
430 : CASE ("<PP_R", "<PP_R>")
431 38 : m = pot%mesh_size
432 38 : ms = pot%mesh_size
433 : mc = 1
434 38 : IF (string /= "<PP_R>") THEN
435 : ! options
436 : DO
437 118 : IF (parser_test_next_token(parser) == "EOL") THEN
438 0 : CALL parser_get_next_line(parser, 1, at_end)
439 118 : CPASSERT(.NOT. at_end)
440 : END IF
441 118 : CALL parser_get_object(parser, string2, lower_to_upper=.TRUE.)
442 118 : IF (string2 == ">") EXIT
443 30 : SELECT CASE (string2)
444 : CASE ("TYPE")
445 30 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
446 30 : CPASSERT(line == "REAL")
447 : CASE ("SIZE")
448 30 : CALL parser_get_object(parser, ms)
449 30 : CPASSERT(ms <= m)
450 : CASE ("COLUMNS")
451 28 : CALL parser_get_object(parser, mc)
452 : CASE DEFAULT
453 88 : CPABORT("Unknown UPF PP_R option <"//TRIM(string2)//"> found")
454 : END SELECT
455 : END DO
456 : END IF
457 114 : ALLOCATE (pot%r(m))
458 27386 : pot%r = 0.0_dp
459 : icount = 1
460 33418 : DO WHILE (icount <= ms)
461 33418 : IF (parser_test_next_token(parser) == "EOL") THEN
462 6032 : CALL parser_get_next_line(parser, 1, at_end)
463 6032 : CPASSERT(.NOT. at_end)
464 : ELSE
465 27348 : CALL parser_get_object(parser, pot%r(icount))
466 60728 : icount = icount + 1
467 : END IF
468 : END DO
469 : CASE ("<PP_RAB", "<PP_RAB>")
470 38 : m = pot%mesh_size
471 38 : ms = pot%mesh_size
472 : mc = 1
473 38 : IF (string /= "<PP_RAB>") THEN
474 : ! options
475 : DO
476 118 : IF (parser_test_next_token(parser) == "EOL") THEN
477 0 : CALL parser_get_next_line(parser, 1, at_end)
478 118 : CPASSERT(.NOT. at_end)
479 : END IF
480 118 : CALL parser_get_object(parser, string2, lower_to_upper=.TRUE.)
481 118 : IF (string2 == ">") EXIT
482 30 : SELECT CASE (string2)
483 : CASE ("TYPE")
484 30 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
485 30 : CPASSERT(line == "REAL")
486 : CASE ("SIZE")
487 30 : CALL parser_get_object(parser, ms)
488 30 : CPASSERT(ms <= m)
489 : CASE ("COLUMNS")
490 28 : CALL parser_get_object(parser, mc)
491 : CASE DEFAULT
492 88 : CPABORT("Unknown UPF PP_RAB option <"//TRIM(string2)//"> found")
493 : END SELECT
494 : END DO
495 : END IF
496 114 : ALLOCATE (pot%rab(m))
497 27386 : pot%rab = 0.0_dp
498 : icount = 1
499 33418 : DO WHILE (icount <= ms)
500 33418 : IF (parser_test_next_token(parser) == "EOL") THEN
501 6032 : CALL parser_get_next_line(parser, 1, at_end)
502 6032 : CPASSERT(.NOT. at_end)
503 : ELSE
504 27348 : CALL parser_get_object(parser, pot%rab(icount))
505 60728 : icount = icount + 1
506 : END IF
507 : END DO
508 : CASE ("</PP_MESH>")
509 190 : EXIT
510 : CASE DEFAULT
511 : !
512 : END SELECT
513 : END DO
514 :
515 38 : END SUBROUTINE upf_mesh_section
516 :
517 : ! **************************************************************************************************
518 : !> \brief ...
519 : !> \param parser ...
520 : !> \param pot ...
521 : !> \param options ...
522 : ! **************************************************************************************************
523 6 : SUBROUTINE upf_nlcc_section(parser, pot, options)
524 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
525 : TYPE(atom_upfpot_type) :: pot
526 : LOGICAL, INTENT(IN) :: options
527 :
528 : CHARACTER(LEN=default_string_length) :: line, string
529 : INTEGER :: icount, m, mc, ms
530 : LOGICAL :: at_end
531 :
532 6 : m = pot%mesh_size
533 6 : ms = m
534 : mc = 1
535 6 : IF (options) THEN
536 : DO
537 24 : IF (parser_test_next_token(parser) == "EOL") THEN
538 0 : CALL parser_get_next_line(parser, 1, at_end)
539 24 : CPASSERT(.NOT. at_end)
540 : END IF
541 24 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
542 24 : IF (string == ">") EXIT
543 6 : SELECT CASE (string)
544 : CASE ("TYPE")
545 6 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
546 6 : CPASSERT(line == "REAL")
547 : CASE ("SIZE")
548 6 : CALL parser_get_object(parser, ms)
549 6 : CPASSERT(ms <= m)
550 : CASE ("COLUMNS")
551 6 : CALL parser_get_object(parser, mc)
552 : CASE DEFAULT
553 18 : CPABORT("Unknown UPF PP_NLCC option <"//TRIM(string)//"> found")
554 : END SELECT
555 : END DO
556 : END IF
557 :
558 18 : ALLOCATE (pot%rho_nlcc(m))
559 6582 : pot%rho_nlcc = 0.0_dp
560 : icount = 1
561 8226 : DO WHILE (icount <= ms)
562 8226 : IF (parser_test_next_token(parser) == "EOL") THEN
563 1644 : CALL parser_get_next_line(parser, 1, at_end)
564 1644 : CPASSERT(.NOT. at_end)
565 : ELSE
566 6576 : CALL parser_get_object(parser, pot%rho_nlcc(icount))
567 14796 : icount = icount + 1
568 : END IF
569 : END DO
570 :
571 6 : CALL parser_get_next_line(parser, 1, at_end)
572 6 : CPASSERT(.NOT. at_end)
573 6 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
574 6 : CPASSERT(string == "</PP_NLCC>")
575 :
576 6 : END SUBROUTINE upf_nlcc_section
577 :
578 : ! **************************************************************************************************
579 : !> \brief ...
580 : !> \param parser ...
581 : !> \param pot ...
582 : !> \param options ...
583 : ! **************************************************************************************************
584 38 : SUBROUTINE upf_local_section(parser, pot, options)
585 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
586 : TYPE(atom_upfpot_type) :: pot
587 : LOGICAL, INTENT(IN) :: options
588 :
589 : CHARACTER(LEN=default_string_length) :: line, string
590 : INTEGER :: icount, m, mc, ms
591 : LOGICAL :: at_end
592 :
593 38 : m = pot%mesh_size
594 38 : ms = m
595 : mc = 1
596 38 : IF (options) THEN
597 : DO
598 124 : IF (parser_test_next_token(parser) == "EOL") THEN
599 0 : CALL parser_get_next_line(parser, 1, at_end)
600 124 : CPASSERT(.NOT. at_end)
601 : END IF
602 124 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
603 124 : IF (string == ">") EXIT
604 32 : SELECT CASE (string)
605 : CASE ("TYPE")
606 32 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
607 32 : CPASSERT(line == "REAL")
608 : CASE ("SIZE")
609 32 : CALL parser_get_object(parser, ms)
610 32 : CPASSERT(ms <= m)
611 : CASE ("COLUMNS")
612 28 : CALL parser_get_object(parser, mc)
613 : CASE DEFAULT
614 92 : CPABORT("Unknown UPF PP_LOCAL option <"//TRIM(string)//"> found")
615 : END SELECT
616 : END DO
617 : END IF
618 :
619 114 : ALLOCATE (pot%vlocal(m))
620 27386 : pot%vlocal = 0.0_dp
621 : icount = 1
622 34240 : DO WHILE (icount <= ms)
623 34240 : IF (parser_test_next_token(parser) == "EOL") THEN
624 6854 : CALL parser_get_next_line(parser, 1, at_end)
625 6854 : CPASSERT(.NOT. at_end)
626 : ELSE
627 27348 : CALL parser_get_object(parser, pot%vlocal(icount))
628 61550 : icount = icount + 1
629 : END IF
630 : END DO
631 :
632 : ! Ry -> Hartree
633 27386 : pot%vlocal = 0.5_dp*pot%vlocal
634 :
635 38 : CALL parser_get_next_line(parser, 1, at_end)
636 38 : CPASSERT(.NOT. at_end)
637 38 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
638 38 : CPASSERT(string == "</PP_LOCAL>")
639 :
640 38 : END SUBROUTINE upf_local_section
641 :
642 : ! **************************************************************************************************
643 : !> \brief ...
644 : !> \param parser ...
645 : !> \param pot ...
646 : !> \param readaug Import angular-resolved USPP augmentation data.
647 : ! **************************************************************************************************
648 38 : SUBROUTINE upf_nonlocal_section(parser, pot, readaug)
649 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
650 : TYPE(atom_upfpot_type) :: pot
651 : LOGICAL, INTENT(IN) :: readaug
652 :
653 : CHARACTER(LEN=default_string_length) :: line, string
654 : INTEGER :: i1, i2, ibeta, icount, la, m, mc, ms, &
655 : nbeta
656 : LOGICAL :: at_end
657 :
658 38 : m = pot%mesh_size
659 38 : nbeta = pot%number_of_proj
660 294 : ALLOCATE (pot%dion(nbeta, nbeta), pot%beta(m, nbeta), pot%lbeta(nbeta))
661 390 : pot%dion = 0.0_dp
662 51062 : pot%beta = 0.0_dp
663 108 : pot%lbeta = -1
664 :
665 : ibeta = 0
666 : DO
667 294 : CALL parser_get_next_line(parser, 1, at_end)
668 294 : CPASSERT(.NOT. at_end)
669 294 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
670 332 : IF (string(1:8) == "<PP_BETA") THEN
671 70 : ms = m
672 70 : ibeta = ibeta + 1
673 70 : i1 = ibeta
674 70 : la = 0
675 70 : CPASSERT(ibeta <= nbeta)
676 : DO
677 516 : IF (parser_test_next_token(parser) == "EOL") THEN
678 266 : CALL parser_get_next_line(parser, 1, at_end)
679 782 : CPASSERT(.NOT. at_end)
680 : END IF
681 516 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
682 516 : IF (string == ">") EXIT
683 70 : SELECT CASE (string)
684 : CASE ("TYPE")
685 58 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
686 58 : CPASSERT(line == "REAL")
687 : CASE ("SIZE")
688 70 : CALL parser_get_object(parser, ms)
689 70 : CPASSERT(ms <= m)
690 : CASE ("COLUMNS")
691 50 : CALL parser_get_object(parser, mc)
692 : CASE ("INDEX")
693 70 : CALL parser_get_object(parser, i1)
694 70 : CPASSERT(i1 <= nbeta)
695 : CASE ("ANGULAR_MOMENTUM")
696 84 : CALL parser_get_object(parser, la)
697 : CASE ("LABEL")
698 14 : CALL parser_get_object(parser, line, allow_empty=.TRUE.)
699 : ! not used currently
700 : CASE ("CUTOFF_RADIUS_INDEX")
701 50 : CALL parser_get_object(parser, line)
702 : ! not used currently
703 : CASE ("CUTOFF_RADIUS")
704 50 : CALL parser_get_object(parser, line)
705 : ! not used currently
706 : CASE ("ULTRASOFT_CUTOFF_RADIUS")
707 14 : CALL parser_get_object(parser, line)
708 : ! not used currently
709 : CASE DEFAULT
710 446 : CPABORT("Unknown UPF PP_BETA option <"//TRIM(string)//"> found")
711 : END SELECT
712 : END DO
713 70 : pot%lbeta(i1) = la
714 70 : icount = 1
715 63776 : DO WHILE (icount <= ms)
716 63776 : IF (parser_test_next_token(parser) == "EOL") THEN
717 12752 : CALL parser_get_next_line(parser, 1, at_end)
718 12752 : CPASSERT(.NOT. at_end)
719 : ELSE
720 50954 : CALL parser_get_object(parser, pot%beta(icount, i1))
721 114660 : icount = icount + 1
722 : END IF
723 : END DO
724 224 : ELSE IF (string(1:7) == "<PP_DIJ") THEN
725 38 : ms = nbeta*nbeta
726 38 : IF (string /= "<PP_DIJ>") THEN
727 : DO
728 118 : IF (parser_test_next_token(parser) == "EOL") THEN
729 0 : CALL parser_get_next_line(parser, 1, at_end)
730 118 : CPASSERT(.NOT. at_end)
731 : END IF
732 118 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
733 118 : IF (string == ">") EXIT
734 30 : SELECT CASE (string)
735 : CASE ("TYPE")
736 30 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
737 30 : CPASSERT(line == "REAL")
738 : CASE ("SIZE")
739 30 : CALL parser_get_object(parser, ms)
740 30 : CPASSERT(ms == nbeta*nbeta)
741 : CASE ("COLUMNS")
742 28 : CALL parser_get_object(parser, mc)
743 : CASE DEFAULT
744 88 : CPABORT("Unknown UPF PP_DIJ option <"//TRIM(string)//"> found")
745 : END SELECT
746 : END DO
747 : END IF
748 : icount = 1
749 398 : DO WHILE (icount <= ms)
750 398 : IF (parser_test_next_token(parser) == "EOL") THEN
751 78 : CALL parser_get_next_line(parser, 1, at_end)
752 78 : CPASSERT(.NOT. at_end)
753 : ELSE
754 282 : i1 = (icount - 1)/nbeta + 1
755 282 : i2 = MOD(icount - 1, nbeta) + 1
756 282 : CALL parser_get_object(parser, pot%dion(i1, i2))
757 642 : icount = icount + 1
758 : END IF
759 : END DO
760 186 : ELSE IF (string(1:16) == "<PP_AUGMENTATION") THEN
761 8 : IF (readaug .AND. .NOT. pot%is_paw) CALL upf_augmentation_section(parser, pot)
762 178 : ELSE IF (string(1:14) == "</PP_NONLOCAL>") THEN
763 : EXIT
764 : END IF
765 : END DO
766 :
767 : ! Convert the complete beta*D*beta operator from Ry to Hartree without
768 : ! changing the tabulated projector amplitude. This also preserves the
769 : ! projector convention needed by augmentation charges and PAW duality.
770 : ! Some NC converters put energy units into beta and inverse energy into D;
771 : ! preserving their numerical beta still gives the correct operator here.
772 : ! The radial prefactor in PP_BETA is removed after reading the whole file.
773 390 : pot%dion = 0.5_dp*pot%dion
774 :
775 38 : END SUBROUTINE upf_nonlocal_section
776 :
777 : ! **************************************************************************************************
778 : !> \brief Read angular-momentum-resolved USPP augmentation in its tabulated convention.
779 : !> PP_Q is retained independently of the radial quadrature of PP_QIJL. Those
780 : !> quantities need not agree exactly in a finite-precision dataset. No energy
781 : !> conversion or projector normalization is applied to either augmentation array.
782 : !> \param parser UPF token stream, positioned after the PP_AUGMENTATION tag name.
783 : !> \param pot UPF data with the mesh and all beta angular momenta already read.
784 : ! **************************************************************************************************
785 6 : SUBROUTINE upf_augmentation_section(parser, pot)
786 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
787 : TYPE(atom_upfpot_type), INTENT(INOUT) :: pot
788 :
789 : CHARACTER(LEN=default_string_length) :: string, tag, value
790 : INTEGER :: i, j, k, l, lmax, m, nb, nc, nqf, nqlc, &
791 : pair, size_data, tag_i, tag_j, tag_l
792 : LOGICAL :: at_end, is_null, q_with_l, read_q, &
793 : self_closing
794 6 : LOGICAL, ALLOCATABLE :: present_channel(:, :)
795 :
796 6 : CPASSERT(.NOT. ALLOCATED(pot%qij) .AND. .NOT. ALLOCATED(pot%qijl))
797 18 : CPASSERT(ALL(pot%lbeta >= 0))
798 6 : nb = pot%number_of_proj
799 6 : m = pot%mesh_size
800 18 : lmax = 2*MAXVAL(pot%lbeta)
801 6 : q_with_l = .FALSE.
802 6 : nqf = -1
803 6 : nqlc = lmax + 1
804 : DO
805 24 : IF (parser_test_next_token(parser) == "EOL") THEN
806 0 : CALL parser_get_next_line(parser, 1, at_end)
807 24 : CPASSERT(.NOT. at_end)
808 : END IF
809 24 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
810 24 : IF (string == ">") EXIT
811 6 : SELECT CASE (string)
812 : CASE ("Q_WITH_L")
813 6 : CALL parser_get_object(parser, q_with_l)
814 : CASE ("NQF")
815 12 : CALL parser_get_object(parser, nqf)
816 : CASE ("NQLC")
817 6 : CALL parser_get_object(parser, nqlc)
818 : CASE DEFAULT
819 18 : CPABORT("Unknown UPF PP_AUGMENTATION option <"//TRIM(string)//"> found")
820 : END SELECT
821 : END DO
822 6 : IF (.NOT. q_with_l .OR. nqf /= 0) THEN
823 0 : CPABORT("Native USPP import requires angular-resolved PP_QIJL with nqf=0")
824 : END IF
825 6 : IF (nqlc == 0) nqlc = lmax + 1
826 6 : CPASSERT(nqlc >= lmax + 1)
827 6 : nc = nb*(nb + 1)/2
828 66 : ALLOCATE (pot%qij(nb, nb), pot%qijl(m, nc, 0:lmax), present_channel(nc, 0:lmax))
829 42 : pot%qij = 0.0_dp
830 240 : pot%qijl = 0.0_dp
831 6 : present_channel = .FALSE.
832 6 : read_q = .FALSE.
833 : DO
834 64 : CALL parser_get_next_line(parser, 1, at_end)
835 64 : CPASSERT(.NOT. at_end)
836 64 : CALL parser_get_object(parser, tag, lower_to_upper=.TRUE.)
837 64 : IF (tag == "</PP_AUGMENTATION>") EXIT
838 58 : IF (tag(1:2) == "</") CYCLE
839 30 : CPASSERT(tag(1:8) == "<PP_QIJL" .OR. tag == "<PP_Q" .OR. tag == "<PP_Q>")
840 30 : i = -1
841 30 : j = -1
842 30 : l = -1
843 30 : pair = -1
844 30 : size_data = m
845 30 : IF (tag == "<PP_Q" .OR. tag == "<PP_Q>") size_data = nb*nb
846 30 : is_null = .FALSE.
847 30 : self_closing = .FALSE.
848 30 : IF (tag /= "<PP_Q>") THEN
849 : DO
850 130 : IF (parser_test_next_token(parser) == "EOL") THEN
851 4 : CALL parser_get_next_line(parser, 1, at_end)
852 134 : CPASSERT(.NOT. at_end)
853 : END IF
854 130 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
855 130 : IF (string == ">") EXIT
856 108 : IF (string == "/>") THEN
857 : self_closing = .TRUE.
858 : EXIT
859 : END IF
860 22 : SELECT CASE (string)
861 : CASE ("TYPE")
862 2 : CALL parser_get_object(parser, value, lower_to_upper=.TRUE.)
863 2 : CPASSERT(value == "REAL")
864 : CASE ("SIZE")
865 4 : CALL parser_get_object(parser, size_data)
866 : CASE ("COLUMNS")
867 0 : CALL parser_get_object(parser, value)
868 : CASE ("FIRST_INDEX")
869 48 : CALL parser_get_object(parser, i)
870 : CASE ("SECOND_INDEX")
871 48 : CALL parser_get_object(parser, j)
872 : CASE ("COMPOSITE_INDEX")
873 48 : CALL parser_get_object(parser, pair)
874 : CASE ("ANGULAR_MOMENTUM")
875 28 : CALL parser_get_object(parser, l)
876 : CASE ("IS_NULL")
877 4 : CALL parser_get_object(parser, is_null)
878 : CASE DEFAULT
879 106 : CPABORT("Unknown UPF augmentation array option <"//TRIM(string)//"> found")
880 : END SELECT
881 : END DO
882 : END IF
883 36 : IF (tag(1:8) == "<PP_QIJL") THEN
884 24 : CPASSERT(i >= 1 .AND. i <= j .AND. j <= nb)
885 24 : CPASSERT(pair == j*(j - 1)/2 + i)
886 24 : CPASSERT(l >= ABS(pot%lbeta(i) - pot%lbeta(j)))
887 24 : CPASSERT(l <= pot%lbeta(i) + pot%lbeta(j))
888 24 : CPASSERT(MODULO(pot%lbeta(i) + pot%lbeta(j) - l, 2) == 0)
889 : ! Cross-check the tag suffix as well as the explicit attributes.
890 24 : string = tag(10:)
891 144 : DO k = 1, LEN_TRIM(string)
892 144 : IF (string(k:k) == ".") string(k:k) = " "
893 : END DO
894 24 : READ (string, *) tag_i, tag_j, tag_l
895 24 : CPASSERT(tag_i == i .AND. tag_j == j .AND. tag_l == l)
896 24 : CPASSERT(.NOT. present_channel(pair, l))
897 24 : present_channel(pair, l) = .TRUE.
898 24 : IF (is_null) THEN
899 2 : CPASSERT(self_closing .AND. size_data == 0)
900 : CYCLE
901 : END IF
902 22 : CPASSERT(.NOT. self_closing .AND. size_data == m)
903 88 : DO k = 1, m
904 88 : DO WHILE (parser_test_next_token(parser) == "EOL")
905 22 : CALL parser_get_next_line(parser, 1, at_end)
906 22 : CPASSERT(.NOT. at_end)
907 : END DO
908 88 : CALL parser_get_object(parser, pot%qijl(k, pair, l))
909 : END DO
910 : ELSE
911 6 : CPASSERT(.NOT. read_q .AND. .NOT. self_closing .AND. .NOT. is_null)
912 6 : CPASSERT(size_data == nb*nb)
913 18 : DO j = 1, nb
914 42 : DO i = 1, nb
915 30 : DO WHILE (parser_test_next_token(parser) == "EOL")
916 6 : CALL parser_get_next_line(parser, 1, at_end)
917 6 : CPASSERT(.NOT. at_end)
918 : END DO
919 36 : CALL parser_get_object(parser, pot%qij(i, j))
920 : END DO
921 : END DO
922 : read_q = .TRUE.
923 : END IF
924 : END DO
925 6 : CPASSERT(read_q)
926 18 : DO j = 1, nb
927 36 : DO i = 1, j
928 18 : pair = j*(j - 1)/2 + i
929 54 : DO l = ABS(pot%lbeta(i) - pot%lbeta(j)), pot%lbeta(i) + pot%lbeta(j), 2
930 42 : CPASSERT(present_channel(pair, l))
931 : END DO
932 : END DO
933 : END DO
934 6 : END SUBROUTINE upf_augmentation_section
935 :
936 : ! **************************************************************************************************
937 : !> \brief ...
938 : !> \param parser ...
939 : !> \param pot ...
940 : ! **************************************************************************************************
941 2 : SUBROUTINE upf_semilocal_section(parser, pot)
942 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
943 : TYPE(atom_upfpot_type) :: pot
944 :
945 : CHARACTER(LEN=default_string_length) :: line, string
946 : INTEGER :: i1, ib, icount, la, lmax, m, mc, ms
947 : LOGICAL :: at_end
948 :
949 2 : m = pot%mesh_size
950 2 : lmax = pot%l_max
951 8 : ALLOCATE (pot%vsemi(m, lmax + 1))
952 3698 : pot%vsemi = 0.0_dp
953 :
954 : ib = 0
955 : DO
956 14 : CALL parser_get_next_line(parser, 1, at_end)
957 14 : CPASSERT(.NOT. at_end)
958 14 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
959 16 : IF (string(1:7) == "<PP_VNL") THEN
960 6 : ms = m
961 6 : ib = ib + 1
962 6 : i1 = ib
963 6 : la = 0
964 6 : CPASSERT(ib <= lmax + 1)
965 : DO
966 30 : IF (parser_test_next_token(parser) == "EOL") THEN
967 0 : CALL parser_get_next_line(parser, 1, at_end)
968 30 : CPASSERT(.NOT. at_end)
969 : END IF
970 30 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
971 30 : IF (string == ">") EXIT
972 6 : SELECT CASE (string)
973 : CASE ("TYPE")
974 6 : CALL parser_get_object(parser, line, lower_to_upper=.TRUE.)
975 6 : CPASSERT(line == "REAL")
976 : CASE ("SIZE")
977 6 : CALL parser_get_object(parser, ms)
978 6 : CPASSERT(ms <= m)
979 : CASE ("COLUMNS")
980 6 : CALL parser_get_object(parser, mc)
981 : CASE ("L")
982 6 : CALL parser_get_object(parser, la)
983 : CASE DEFAULT
984 24 : CPABORT("Unknown UPF PP_VNL option <"//TRIM(string)//"> found")
985 : END SELECT
986 : END DO
987 6 : i1 = la + 1
988 6 : icount = 1
989 3468 : DO WHILE (icount <= ms)
990 3468 : IF (parser_test_next_token(parser) == "EOL") THEN
991 696 : CALL parser_get_next_line(parser, 1, at_end)
992 696 : CPASSERT(.NOT. at_end)
993 : ELSE
994 2766 : CALL parser_get_object(parser, pot%vsemi(icount, i1))
995 6228 : icount = icount + 1
996 : END IF
997 : END DO
998 8 : ELSE IF (string(1:15) == "</PP_SEMILOCAL>") THEN
999 : EXIT
1000 : ELSE
1001 : !
1002 : END IF
1003 : END DO
1004 : ! Ry -> Hartree
1005 3698 : pot%vsemi = 0.5_dp*pot%vsemi
1006 :
1007 2 : END SUBROUTINE upf_semilocal_section
1008 :
1009 : ! **************************************************************************************************
1010 : !> \brief Skip complete XML comment lines before original full-wave data.
1011 : !> \param parser ...
1012 : !> \param at_end ...
1013 : ! **************************************************************************************************
1014 26 : SUBROUTINE upf_next_line(parser, at_end)
1015 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
1016 : LOGICAL, INTENT(OUT) :: at_end
1017 :
1018 26 : CHARACTER(LEN=:), ALLOCATABLE :: line
1019 : LOGICAL :: in_comment
1020 :
1021 26 : in_comment = .FALSE.
1022 0 : DO
1023 26 : CALL parser_get_next_line(parser, 1, at_end)
1024 26 : IF (at_end) THEN
1025 0 : CPASSERT(.NOT. in_comment)
1026 26 : RETURN
1027 : END IF
1028 26 : line = ADJUSTL(parser%buffer%input_lines(parser%buffer%present_line_number))
1029 26 : IF (.NOT. in_comment .AND. INDEX(line, '<!--') /= 1) RETURN
1030 0 : in_comment = INDEX(line, '-->') == 0
1031 : END DO
1032 52 : END SUBROUTINE upf_next_line
1033 :
1034 : ! **************************************************************************************************
1035 : !> \brief Read an original full-wave array without normalization or unit conversion.
1036 : !> \param parser ...
1037 : !> \param tag ...
1038 : !> \param values ...
1039 : !> \param index_value ...
1040 : !> \param angular_momentum ...
1041 : ! **************************************************************************************************
1042 8 : SUBROUTINE upf_real_array(parser, tag, values, index_value, angular_momentum)
1043 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
1044 : CHARACTER(LEN=*), INTENT(IN) :: tag
1045 : REAL(dp), INTENT(OUT) :: values(:)
1046 : INTEGER, INTENT(OUT), OPTIONAL :: index_value, angular_momentum
1047 :
1048 : CHARACTER(LEN=default_string_length) :: name, string, value
1049 : INTEGER :: i, last, n
1050 : LOGICAL :: at_end
1051 :
1052 8 : n = SIZE(values)
1053 8 : last = LEN_TRIM(tag)
1054 8 : IF (PRESENT(index_value)) index_value = -1
1055 8 : IF (PRESENT(angular_momentum)) angular_momentum = -1
1056 8 : IF (tag(last:last) == ">") THEN
1057 0 : name = tag(2:last - 1)
1058 : ELSE
1059 8 : name = tag(2:last)
1060 : DO
1061 24 : IF (parser_test_next_token(parser) == "EOL") THEN
1062 0 : CALL upf_next_line(parser, at_end)
1063 24 : CPASSERT(.NOT. at_end)
1064 : END IF
1065 24 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
1066 24 : IF (string == ">") EXIT
1067 8 : SELECT CASE (string)
1068 : CASE ("TYPE")
1069 2 : CALL parser_get_object(parser, value, lower_to_upper=.TRUE.)
1070 2 : CPASSERT(value == "REAL")
1071 : CASE ("SIZE")
1072 2 : CALL parser_get_object(parser, n)
1073 2 : CPASSERT(n == SIZE(values))
1074 : CASE ("COLUMNS")
1075 0 : CALL parser_get_object(parser, value)
1076 : CASE ("INDEX")
1077 4 : CPASSERT(PRESENT(index_value))
1078 4 : CALL parser_get_object(parser, index_value)
1079 : CASE ("L")
1080 8 : CPASSERT(PRESENT(angular_momentum))
1081 8 : CALL parser_get_object(parser, angular_momentum)
1082 : CASE ("LABEL")
1083 0 : CALL parser_get_object(parser, value, allow_empty=.TRUE.)
1084 : CASE DEFAULT
1085 28 : CPABORT("Unknown UPF "//TRIM(name)//" option <"//TRIM(string)//"> found")
1086 : END SELECT
1087 : END DO
1088 : END IF
1089 32 : DO i = 1, n
1090 32 : DO WHILE (parser_test_next_token(parser) == "EOL")
1091 8 : CALL upf_next_line(parser, at_end)
1092 8 : CPASSERT(.NOT. at_end)
1093 : END DO
1094 32 : CALL parser_get_object(parser, values(i))
1095 : END DO
1096 32 : CPASSERT(ALL(ieee_is_finite(values)))
1097 8 : CALL upf_next_line(parser, at_end)
1098 8 : CPASSERT(.NOT. at_end)
1099 8 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
1100 8 : CPASSERT(string == "</"//TRIM(name)//">")
1101 8 : END SUBROUTINE upf_real_array
1102 :
1103 : ! **************************************************************************************************
1104 : !> \brief Import projector-indexed AE and PS partial waves, retaining r*phi(r).
1105 : !> \param parser ...
1106 : !> \param waves ...
1107 : !> \param opening_tag ...
1108 : !> \param mesh_size ...
1109 : !> \param number_of_proj ...
1110 : ! **************************************************************************************************
1111 2 : SUBROUTINE upf_full_wfc_section(parser, waves, opening_tag, mesh_size, number_of_proj)
1112 : TYPE(cp_parser_type), INTENT(INOUT) :: parser
1113 :
1114 : CLASS(upf_partial_waves_type), INTENT(INOUT) :: waves
1115 : CHARACTER(LEN=*), INTENT(IN) :: opening_tag
1116 : INTEGER, INTENT(IN) :: mesh_size, number_of_proj
1117 :
1118 : CHARACTER(LEN=default_string_length) :: string, suffix, tag
1119 : INTEGER :: i, index_value, ios, l, last, m, n, nb, &
1120 : wave_type
1121 : LOGICAL :: at_end
1122 2 : LOGICAL, ALLOCATABLE :: found(:, :)
1123 2 : REAL(dp), ALLOCATABLE :: values(:)
1124 :
1125 2 : nb = number_of_proj
1126 2 : m = mesh_size
1127 2 : CPASSERT(nb > 0 .AND. m > 0)
1128 2 : CPASSERT(.NOT. ALLOCATED(waves%ae_wfc) .AND. .NOT. ALLOCATED(waves%ps_wfc))
1129 2 : CPASSERT(.NOT. ALLOCATED(waves%angular_momenta))
1130 2 : IF (opening_tag /= "<PP_FULL_WFC>") THEN
1131 2 : DO
1132 4 : IF (parser_test_next_token(parser) == "EOL") THEN
1133 0 : CALL upf_next_line(parser, at_end)
1134 4 : CPASSERT(.NOT. at_end)
1135 : END IF
1136 4 : CALL parser_get_object(parser, string, lower_to_upper=.TRUE.)
1137 4 : IF (string == ">") EXIT
1138 2 : CPASSERT(string == "NUMBER_OF_WFC")
1139 2 : CALL parser_get_object(parser, n)
1140 4 : CPASSERT(n == nb)
1141 : END DO
1142 : END IF
1143 16 : ALLOCATE (waves%ae_wfc(m, nb), waves%ps_wfc(m, nb), waves%angular_momenta(nb))
1144 10 : ALLOCATE (found(nb, 2), values(m))
1145 2 : found = .FALSE.
1146 6 : waves%angular_momenta = -1
1147 18 : DO
1148 10 : CALL upf_next_line(parser, at_end)
1149 10 : CPASSERT(.NOT. at_end)
1150 10 : CALL parser_get_object(parser, tag, lower_to_upper=.TRUE.)
1151 10 : IF (tag == "</PP_FULL_WFC>") EXIT
1152 : SELECT CASE (tag(1:10))
1153 : CASE ("<PP_AEWFC.")
1154 4 : wave_type = 1
1155 : CASE ("<PP_PSWFC.")
1156 4 : wave_type = 2
1157 : CASE DEFAULT
1158 8 : CPABORT("Unknown UPF full partial-wave tag "//TRIM(tag))
1159 : END SELECT
1160 8 : last = LEN_TRIM(tag)
1161 8 : IF (tag(last:last) == ">") last = last - 1
1162 8 : suffix = tag(11:last)
1163 8 : READ (suffix, *, IOSTAT=ios) i
1164 8 : CPASSERT(ios == 0)
1165 8 : CPASSERT(i >= 1 .AND. i <= nb)
1166 8 : CPASSERT(.NOT. found(i, wave_type))
1167 8 : CALL upf_real_array(parser, tag, values, index_value, l)
1168 8 : IF (index_value /= -1) THEN
1169 4 : CPASSERT(index_value == i)
1170 : END IF
1171 8 : CPASSERT(l >= 0)
1172 8 : IF (waves%angular_momenta(i) >= 0) THEN
1173 4 : CPASSERT(l == waves%angular_momenta(i))
1174 : END IF
1175 8 : waves%angular_momenta(i) = l
1176 8 : IF (wave_type == 1) THEN
1177 16 : waves%ae_wfc(:, i) = values
1178 : ELSE
1179 16 : waves%ps_wfc(:, i) = values
1180 : END IF
1181 8 : found(i, wave_type) = .TRUE.
1182 : END DO
1183 14 : CPASSERT(ALL(found))
1184 2 : END SUBROUTINE upf_full_wfc_section
1185 :
1186 : ! **************************************************************************************************
1187 : !> \brief ...
1188 : !> \param upfpot ...
1189 : ! **************************************************************************************************
1190 11760 : PURE SUBROUTINE atom_release_upf(upfpot)
1191 :
1192 : TYPE(atom_upfpot_type), INTENT(INOUT) :: upfpot
1193 :
1194 : ! Intrinsic assignment releases all allocatable components, including NLCC,
1195 : ! and clears metadata before this temporary is reused for another KIND.
1196 11760 : CALL upf_release(upfpot)
1197 :
1198 11760 : END SUBROUTINE atom_release_upf
1199 : ! **************************************************************************************************
1200 :
1201 : END MODULE atom_upf
|
