(git:374b731)
Loading...
Searching...
No Matches
optimize_basis_utils.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7MODULE optimize_basis_utils
8 USE cp_files, ONLY: close_file,&
9 open_file
10 USE cp_log_handling, ONLY: cp_get_default_logger,&
11 cp_logger_get_default_unit_nr,&
12 cp_logger_type,&
13 cp_to_string
14 USE cp_parser_methods, ONLY: parser_get_object,&
15 parser_search_string
16 USE cp_parser_types, ONLY: cp_parser_type,&
17 parser_create,&
18 parser_release
19 USE input_constants, ONLY: do_opt_all,&
20 do_opt_coeff,&
21 do_opt_exps,&
22 do_opt_none
23 USE input_section_types, ONLY: section_vals_get,&
24 section_vals_get_subs_vals,&
25 section_vals_type,&
26 section_vals_val_get
27 USE kinds, ONLY: default_path_length,&
28 default_string_length,&
29 dp
30 USE machine, ONLY: default_output_unit,&
31 m_getcwd
32 USE message_passing, ONLY: mp_para_env_type
33 USE optimize_basis_types, ONLY: basis_optimization_type,&
34 derived_basis_info,&
35 flex_basis_type,&
36 subset_type
37 USE powell, ONLY: opt_state_type
38 USE string_utilities, ONLY: uppercase
39#include "./base/base_uses.f90"
40
41 IMPLICIT NONE
42 PRIVATE
43
44 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'optimize_basis_utils'
45
46 PUBLIC :: optimize_basis_init_read_input, get_set_and_basis_id, &
47 update_derived_basis_sets
48
49CONTAINS
50
51! **************************************************************************************************
52!> \brief initialize all parts of the optimization type and read input settings
53!> \param opt_bas ...
54!> \param root_section ...
55!> \param para_env ...
56!> \author Florian Schiffmann
57! **************************************************************************************************
58
59 SUBROUTINE optimize_basis_init_read_input(opt_bas, root_section, para_env)
60 TYPE(basis_optimization_type) :: opt_bas
61 TYPE(section_vals_type), POINTER :: root_section
62 TYPE(mp_para_env_type), POINTER :: para_env
63
64 CHARACTER(LEN=default_path_length) :: main_dir
65 INTEGER :: iset, iweight, nrep
66 TYPE(section_vals_type), POINTER :: kind_section, optbas_section, &
67 powell_section, train_section
68
69 optbas_section => section_vals_get_subs_vals(root_section, "OPTIMIZE_BASIS")
70 powell_section => section_vals_get_subs_vals(optbas_section, "OPTIMIZATION")
71 train_section => section_vals_get_subs_vals(optbas_section, "TRAINING_FILES")
72 kind_section => section_vals_get_subs_vals(optbas_section, "FIT_KIND")
73
74 CALL section_vals_val_get(optbas_section, "BASIS_TEMPLATE_FILE", c_val=opt_bas%template_basis_file)
75 CALL section_vals_val_get(optbas_section, "BASIS_WORK_FILE", c_val=opt_bas%work_basis_file)
76 CALL section_vals_val_get(optbas_section, "BASIS_OUTPUT_FILE", c_val=opt_bas%output_basis_file)
77 CALL m_getcwd(main_dir)
78 opt_bas%work_basis_file = trim(adjustl(main_dir))//"/"//trim(adjustl(opt_bas%work_basis_file))
79
80 CALL section_vals_val_get(optbas_section, "WRITE_FREQUENCY", i_val=opt_bas%write_frequency)
81 CALL section_vals_val_get(optbas_section, "USE_CONDITION_NUMBER", l_val=opt_bas%use_condition_number)
82
83 CALL generate_initial_basis(kind_section, opt_bas, para_env)
84
85 CALL section_vals_get(train_section, n_repetition=opt_bas%ntraining_sets)
86 IF (opt_bas%ntraining_sets == 0) &
87 cpabort("No training set was specified in the Input")
88
89 ALLOCATE (opt_bas%training_input(opt_bas%ntraining_sets))
90 ALLOCATE (opt_bas%training_dir(opt_bas%ntraining_sets))
91 DO iset = 1, opt_bas%ntraining_sets
92 CALL section_vals_val_get(train_section, "DIRECTORY", c_val=opt_bas%training_dir(iset), &
93 i_rep_section=iset)
94 CALL section_vals_val_get(train_section, "INPUT_FILE_NAME", c_val=opt_bas%training_input(iset), &
95 i_rep_section=iset)
96 END DO
97
98 CALL init_powell_var(opt_bas%powell_param, powell_section)
99 opt_bas%powell_param%nvar = SIZE(opt_bas%x_opt)
100
101 CALL generate_derived_basis_sets(opt_bas, para_env)
102
103 CALL generate_basis_combinations(opt_bas, optbas_section)
104
105 CALL section_vals_val_get(optbas_section, "RESIDUUM_WEIGHT", n_rep_val=nrep)
106 ALLOCATE (opt_bas%fval_weight(0:opt_bas%ncombinations))
107 opt_bas%fval_weight = 1.0_dp
108 DO iweight = 1, nrep
109 CALL section_vals_val_get(optbas_section, "RESIDUUM_WEIGHT", r_val=opt_bas%fval_weight(iweight - 1), &
110 i_rep_val=iweight)
111 END DO
112
113 CALL section_vals_val_get(optbas_section, "CONDITION_WEIGHT", n_rep_val=nrep)
114 ALLOCATE (opt_bas%condition_weight(0:opt_bas%ncombinations))
115 opt_bas%condition_weight = 1.0_dp
116 DO iweight = 1, nrep
117 CALL section_vals_val_get(optbas_section, "CONDITION_WEIGHT", r_val=opt_bas%condition_weight(iweight - 1), &
118 i_rep_val=iweight)
119 END DO
120
121 CALL generate_computation_groups(opt_bas, optbas_section, para_env)
122
123 CALL print_opt_info(opt_bas)
124
125 END SUBROUTINE optimize_basis_init_read_input
126
127! **************************************************************************************************
128!> \brief ...
129!> \param opt_bas ...
130! **************************************************************************************************
131 SUBROUTINE print_opt_info(opt_bas)
132 TYPE(basis_optimization_type) :: opt_bas
133
134 INTEGER :: icomb, ikind, unit_nr
135 TYPE(cp_logger_type), POINTER :: logger
136
137 logger => cp_get_default_logger()
138 unit_nr = -1
139 IF (logger%para_env%is_source()) &
140 unit_nr = cp_logger_get_default_unit_nr(logger)
141
142 IF (unit_nr > 0) THEN
143 WRITE (unit_nr, '(1X,A,A)') "BASOPT| Total number of calculations ", &
144 trim(cp_to_string(opt_bas%ncombinations*opt_bas%ntraining_sets))
145 WRITE (unit_nr, '(A)') ""
146 DO icomb = 1, opt_bas%ncombinations
147 WRITE (unit_nr, '(1X,A,A)') "BASOPT| Content of basis combination ", trim(cp_to_string(icomb))
148 DO ikind = 1, opt_bas%nkind
149 WRITE (unit_nr, '(1X,A,A4,4X,A,3X,A)') "BASOPT| Element: ", trim(opt_bas%kind_basis(ikind)%element), &
150 "Basis set: ", trim(opt_bas%kind_basis(ikind)%flex_basis(opt_bas%combination(icomb, ikind))%basis_name)
151 END DO
152 WRITE (unit_nr, '(A)') ""
153 END DO
154 END IF
155 END SUBROUTINE print_opt_info
156
157! **************************************************************************************************
158!> \brief Generation of the requested basis set combinations if multiple kinds
159!> are fitted at the same time (if not specified create all possible)
160!> \param opt_bas ...
161!> \param optbas_section ...
162!> \author Florian Schiffmann
163! **************************************************************************************************
164 SUBROUTINE generate_basis_combinations(opt_bas, optbas_section)
165 TYPE(basis_optimization_type) :: opt_bas
166 TYPE(section_vals_type), POINTER :: optbas_section
167
168 INTEGER :: i, ikind, j, n_rep
169 INTEGER, DIMENSION(:), POINTER :: i_vals, tmp_i, tmp_i2
170 LOGICAL :: explicit, raise
171
172!setup the basis combinations to optimize
173
174 CALL section_vals_val_get(optbas_section, "BASIS_COMBINATIONS", explicit=explicit, n_rep_val=n_rep)
175 IF (.NOT. explicit) THEN
176 opt_bas%ncombinations = 1
177 ALLOCATE (tmp_i(opt_bas%nkind))
178 ALLOCATE (tmp_i2(opt_bas%nkind))
179 DO ikind = 1, opt_bas%nkind
180 opt_bas%ncombinations = opt_bas%ncombinations*SIZE(opt_bas%kind_basis(ikind)%flex_basis)
181 tmp_i(ikind) = opt_bas%kind_basis(ikind)%nbasis_deriv
182 END DO
183 ALLOCATE (opt_bas%combination(opt_bas%ncombinations, opt_bas%nkind))
184 tmp_i2 = 0
185 DO i = 1, opt_bas%ncombinations
186 DO j = 1, opt_bas%nkind
187 opt_bas%combination(i, j) = tmp_i2(j)
188 END DO
189 tmp_i2(opt_bas%nkind) = tmp_i2(opt_bas%nkind) + 1
190 raise = .false.
191 DO j = opt_bas%nkind, 1, -1
192 IF (raise) tmp_i2(j) = tmp_i2(j) + 1
193 IF (tmp_i2(j) .GT. tmp_i(j)) THEN
194 tmp_i2(j) = 0
195 raise = .true.
196 END IF
197 END DO
198 END DO
199 DEALLOCATE (tmp_i)
200 DEALLOCATE (tmp_i2)
201 ELSE
202 opt_bas%ncombinations = n_rep
203 ALLOCATE (opt_bas%combination(opt_bas%ncombinations, opt_bas%nkind))
204 DO i = 1, n_rep
205 CALL section_vals_val_get(optbas_section, "BASIS_COMBINATIONS", i_vals=i_vals, i_rep_val=i)
206 opt_bas%combination(i, :) = i_vals(:)
207 END DO
208 END IF
209
210 END SUBROUTINE generate_basis_combinations
211
212! **************************************************************************************************
213!> \brief returns a mapping from the calculation id to the trainings set id and
214!> basis combination id
215!> \param calc_id ...
216!> \param opt_bas ...
217!> \param set_id ...
218!> \param bas_id ...
219!> \author Florian Schiffmann
220! **************************************************************************************************
221
222 SUBROUTINE get_set_and_basis_id(calc_id, opt_bas, set_id, bas_id)
223
224 INTEGER :: calc_id
225 TYPE(basis_optimization_type) :: opt_bas
226 INTEGER :: set_id, bas_id
227
228 INTEGER :: ncom, nset
229
230 ncom = opt_bas%ncombinations
231 nset = opt_bas%ntraining_sets
232
233 set_id = (calc_id)/ncom + 1
234 bas_id = mod(calc_id, ncom) + 1
235
236 END SUBROUTINE
237
238! **************************************************************************************************
239!> \brief Pack calculations in groups. If less MPI tasks than systems are used
240!> multiple systems will be assigned to a single MPI task
241!> \param opt_bas ...
242!> \param optbas_section ...
243!> \param para_env ...
244!> \author Florian Schiffmann
245! **************************************************************************************************
246
247 SUBROUTINE generate_computation_groups(opt_bas, optbas_section, para_env)
248 TYPE(basis_optimization_type) :: opt_bas
249 TYPE(section_vals_type), POINTER :: optbas_section
250 TYPE(mp_para_env_type), POINTER :: para_env
251
252 INTEGER :: iadd1, iadd2, icount, igroup, isize, j, &
253 ncalc, nproc, nptot
254 INTEGER, DIMENSION(:), POINTER :: i_vals
255 LOGICAL :: explicit
256
257 nproc = para_env%num_pe
258 ncalc = opt_bas%ncombinations*opt_bas%ntraining_sets
259 CALL section_vals_val_get(optbas_section, "GROUP_PARTITION", explicit=explicit)
260
261 ! No input information available, try to equally distribute
262 IF (.NOT. explicit) THEN
263 IF (nproc .GE. ncalc) THEN
264 iadd1 = nproc/ncalc
265 iadd2 = mod(nproc, ncalc)
266 ALLOCATE (opt_bas%comp_group(ncalc))
267 ALLOCATE (opt_bas%group_partition(0:ncalc - 1))
268 DO igroup = 0, ncalc - 1
269 ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(1))
270 opt_bas%comp_group(igroup + 1)%member_list(1) = igroup
271 opt_bas%group_partition(igroup) = iadd1
272 IF (igroup .LT. iadd2) opt_bas%group_partition(igroup) = opt_bas%group_partition(igroup) + 1
273 END DO
274 ELSE
275 iadd1 = ncalc/nproc
276 iadd2 = mod(ncalc, nproc)
277 ALLOCATE (opt_bas%comp_group(nproc))
278 ALLOCATE (opt_bas%group_partition(0:nproc - 1))
279 icount = 0
280 DO igroup = 0, nproc - 1
281 opt_bas%group_partition(igroup) = 1
282 isize = iadd1
283 IF (igroup .LT. iadd2) isize = isize + 1
284 ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(isize))
285 DO j = 1, isize
286 opt_bas%comp_group(igroup + 1)%member_list(j) = icount
287 icount = icount + 1
288 END DO
289 END DO
290 END IF
291 ELSE
292
293 ! Group partition from input. see if all systems can be assigned. If not add to existing group
294 CALL section_vals_val_get(optbas_section, "GROUP_PARTITION", i_vals=i_vals)
295 isize = SIZE(i_vals)
296 nptot = sum(i_vals)
297 IF (nptot /= nproc) &
298 CALL cp_abort(__location__, &
299 "Number of processors in group distribution does not match number of MPI tasks."// &
300 " Please change input.")
301 IF (.NOT. isize .LE. ncalc) &
302 CALL cp_abort(__location__, &
303 "Number of Groups larger than number of calculations"// &
304 " Please change input.")
305 cpassert(nptot == nproc)
306 ALLOCATE (opt_bas%comp_group(isize))
307 ALLOCATE (opt_bas%group_partition(0:isize - 1))
308 IF (isize .LT. ncalc) THEN
309 iadd1 = ncalc/isize
310 iadd2 = mod(ncalc, isize)
311 icount = 0
312 DO igroup = 0, isize - 1
313 opt_bas%group_partition(igroup) = i_vals(igroup + 1)
314 isize = iadd1
315 IF (igroup .LT. iadd2) isize = isize + 1
316 ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(isize))
317 DO j = 1, isize
318 opt_bas%comp_group(igroup + 1)%member_list(j) = icount
319 icount = icount + 1
320 END DO
321 END DO
322 ELSE
323 DO igroup = 0, isize - 1
324 opt_bas%group_partition(igroup) = i_vals(igroup + 1)
325 ALLOCATE (opt_bas%comp_group(igroup + 1)%member_list(1))
326 opt_bas%comp_group(igroup + 1)%member_list(1) = igroup
327 END DO
328 END IF
329 END IF
330
331 END SUBROUTINE generate_computation_groups
332
333! **************************************************************************************************
334!> \brief Regenerate the basis sets from reference 0 after an update from the
335!> optimizer to reference was performed, and print basis file if required
336!> \param opt_bas ...
337!> \param write_it ...
338!> \param output_file ...
339!> \param para_env ...
340!> \author Florian Schiffmann
341! **************************************************************************************************
342 SUBROUTINE update_derived_basis_sets(opt_bas, write_it, output_file, para_env)
343 TYPE(basis_optimization_type) :: opt_bas
344 LOGICAL :: write_it
345 CHARACTER(LEN=default_path_length) :: output_file
346 TYPE(mp_para_env_type), POINTER :: para_env
347
348 INTEGER :: ibasis, ikind, unit_nr
349
350 DO ikind = 1, opt_bas%nkind
351 DO ibasis = 1, opt_bas%kind_basis(ikind)%nbasis_deriv
352 CALL update_used_parts(opt_bas%kind_basis(ikind)%deriv_info(ibasis), &
353 opt_bas%kind_basis(ikind)%flex_basis(0), &
354 opt_bas%kind_basis(ikind)%flex_basis(ibasis))
355 END DO
356 END DO
357
358 IF (write_it) THEN
359 IF (para_env%is_source()) THEN
360 CALL open_file(file_name=output_file, file_status="UNKNOWN", &
361 file_action="WRITE", unit_number=unit_nr)
362 ELSE
363 unit_nr = -999
364 END IF
365 DO ikind = 1, opt_bas%nkind
366 DO ibasis = 0, opt_bas%kind_basis(ikind)%nbasis_deriv
367 CALL write_basis(opt_bas%kind_basis(ikind)%flex_basis(ibasis), opt_bas%kind_basis(ikind)%element, &
368 unit_nr)
369 END DO
370 END DO
371 IF (para_env%is_source()) CALL close_file(unit_number=unit_nr)
372 END IF
373
374 END SUBROUTINE update_derived_basis_sets
375
376! **************************************************************************************************
377!> \brief Update the the information in a given basis set
378!> \param info_new ...
379!> \param basis ...
380!> \param basis_new ...
381!> \author Florian Schiffmann
382! **************************************************************************************************
383
384 SUBROUTINE update_used_parts(info_new, basis, basis_new)
385 TYPE(derived_basis_info) :: info_new
386 TYPE(flex_basis_type) :: basis, basis_new
387
388 INTEGER :: icont, iset, jcont, jset
389
390 jset = 0
391 DO iset = 1, basis%nsets
392 IF (info_new%in_use_set(iset)) THEN
393 jset = jset + 1
394 basis_new%subset(jset)%exps(:) = basis%subset(iset)%exps
395 jcont = 0
396 DO icont = 1, basis%subset(iset)%ncon_tot
397 IF (info_new%use_contr(iset)%in_use(icont)) THEN
398 jcont = jcont + 1
399 basis_new%subset(jset)%coeff(:, jcont) = basis%subset(iset)%coeff(:, icont)
400 END IF
401 END DO
402 END IF
403 END DO
404
405 END SUBROUTINE update_used_parts
406
407! **************************************************************************************************
408!> \brief Initial generation of the basis set from the file and DERIVED_SET
409!> \param opt_bas ...
410!> \param para_env ...
411!> \author Florian Schiffmann
412! **************************************************************************************************
413
414 SUBROUTINE generate_derived_basis_sets(opt_bas, para_env)
415 TYPE(basis_optimization_type) :: opt_bas
416 TYPE(mp_para_env_type), POINTER :: para_env
417
418 INTEGER :: ibasis, ikind, iref, jbasis, unit_nr
419
420 DO ikind = 1, opt_bas%nkind
421 CALL init_deriv_info_ref(opt_bas%kind_basis(ikind)%deriv_info(0), opt_bas%kind_basis(ikind)%flex_basis(0))
422 opt_bas%kind_basis(ikind)%deriv_info(0)%basis_name = trim(adjustl(opt_bas%kind_basis(ikind)%basis_name))
423 ! initialize the reference set used as template for the rest
424 DO ibasis = 1, opt_bas%kind_basis(ikind)%nbasis_deriv
425 iref = opt_bas%kind_basis(ikind)%deriv_info(ibasis)%reference_set
426 DO jbasis = 0, opt_bas%kind_basis(ikind)%nbasis_deriv
427 IF (iref == jbasis) CALL setup_used_parts_init_basis(opt_bas%kind_basis(ikind)%deriv_info(ibasis), &
428 opt_bas%kind_basis(ikind)%deriv_info(iref), &
429 opt_bas%kind_basis(ikind)%flex_basis(0), &
430 opt_bas%kind_basis(ikind)%flex_basis(ibasis))
431 END DO
432 END DO
433 END DO
434
435 IF (para_env%is_source()) THEN
436 CALL open_file(file_name=opt_bas%work_basis_file, file_status="UNKNOWN", &
437 file_action="WRITE", unit_number=unit_nr)
438 ELSE
439 unit_nr = -999
440 END IF
441 DO ikind = 1, opt_bas%nkind
442 DO ibasis = 0, opt_bas%kind_basis(ikind)%nbasis_deriv
443 IF (len_trim(opt_bas%kind_basis(ikind)%deriv_info(ibasis)%basis_name) > 0) THEN
444 opt_bas%kind_basis(ikind)%flex_basis(ibasis)%basis_name = &
445 trim(adjustl(opt_bas%kind_basis(ikind)%deriv_info(ibasis)%basis_name))
446 ELSE
447 opt_bas%kind_basis(ikind)%flex_basis(ibasis)%basis_name = &
448 trim(adjustl(opt_bas%kind_basis(ikind)%basis_name))//"-DERIVED_SET-"//adjustl(cp_to_string(ibasis))
449 END IF
450 CALL write_basis(opt_bas%kind_basis(ikind)%flex_basis(ibasis), opt_bas%kind_basis(ikind)%element, &
451 unit_nr)
452 END DO
453 END DO
454 IF (para_env%is_source()) CALL close_file(unit_number=unit_nr)
455
456 END SUBROUTINE generate_derived_basis_sets
457
458! **************************************************************************************************
459!> \brief Write a basis set file which can be used from CP2K
460!> \param basis ...
461!> \param element ...
462!> \param unit_nr ...
463!> \author Florian Schiffmann
464! **************************************************************************************************
465
466 SUBROUTINE write_basis(basis, element, unit_nr)
467 TYPE(flex_basis_type) :: basis
468 CHARACTER(LEN=default_string_length) :: element
469 INTEGER :: unit_nr
470
471 INTEGER :: iexp, iset
472
473 IF (unit_nr > 0) THEN
474 WRITE (unit=unit_nr, fmt="(A)") trim(adjustl(element))//" "//trim(adjustl(basis%basis_name))
475 WRITE (unit=unit_nr, fmt="(1X,I0)") basis%nsets
476 DO iset = 1, basis%nsets
477 WRITE (unit=unit_nr, fmt="(30(1X,I0))") basis%subset(iset)%n, basis%subset(iset)%lmin, basis%subset(iset)%lmax, &
478 basis%subset(iset)%nexp, basis%subset(iset)%l
479 DO iexp = 1, basis%subset(iset)%nexp
480 WRITE (unit=unit_nr, fmt="(T2,F24.14,30(1X,ES24.14))") &
481 basis%subset(iset)%exps(iexp), basis%subset(iset)%coeff(iexp, :)
482 END DO
483 END DO
484 END IF
485
486 END SUBROUTINE write_basis
487
488! **************************************************************************************************
489!> \brief Initialize the derived basis sets and the vectors containing their
490!> assembly information ehich is used for regeneration of the sets.
491!> \param info_new ...
492!> \param info_ref ...
493!> \param basis ...
494!> \param basis_new ...
495!> \author Florian Schiffmann
496! **************************************************************************************************
497
498 SUBROUTINE setup_used_parts_init_basis(info_new, info_ref, basis, basis_new)
499 TYPE(derived_basis_info) :: info_new, info_ref
500 TYPE(flex_basis_type) :: basis, basis_new
501
502 INTEGER :: i, jset, lind, nsets
503
504! copy the reference information on the new set
505
506 ALLOCATE (info_new%in_use_set(SIZE(info_ref%in_use_set)))
507 info_new%in_use_set(:) = info_ref%in_use_set
508 ALLOCATE (info_new%use_contr(SIZE(info_ref%in_use_set)))
509 DO i = 1, SIZE(info_ref%in_use_set)
510 ALLOCATE (info_new%use_contr(i)%in_use(SIZE(info_ref%use_contr(i)%in_use)))
511 info_new%use_contr(i)%in_use(:) = info_ref%use_contr(i)%in_use
512 END DO
513 DO i = 1, info_new%nsets
514 info_new%in_use_set(info_new%remove_set(i)) = .false.
515 END DO
516 DO i = 1, info_new%ncontr
517 lind = convert_l_contr_to_entry(basis%subset(info_new%remove_contr(i, 1))%lmin, &
518 basis%subset(info_new%remove_contr(i, 1))%l, &
519 info_new%remove_contr(i, 3), info_new%remove_contr(i, 2))
520
521 info_new%use_contr(info_new%remove_contr(i, 1))%in_use(lind) = .false.
522 END DO
523
524 nsets = 0
525 DO i = 1, basis%nsets
526 IF (info_new%in_use_set(i)) nsets = nsets + 1
527 END DO
528 basis_new%nsets = nsets
529 ALLOCATE (basis_new%subset(nsets))
530 jset = 0
531 DO i = 1, basis%nsets
532 IF (info_new%in_use_set(i)) THEN
533 jset = jset + 1
534 CALL create_new_subset(basis%subset(i), basis_new%subset(jset), info_new%use_contr(jset)%in_use)
535 END IF
536 END DO
537
538 END SUBROUTINE setup_used_parts_init_basis
539
540! **************************************************************************************************
541!> \brief Fill the low level information of the derived basis set.
542!> \param subset ...
543!> \param subset_new ...
544!> \param in_use ...
545!> \author Florian Schiffmann
546! **************************************************************************************************
547
548 SUBROUTINE create_new_subset(subset, subset_new, in_use)
549 TYPE(subset_type) :: subset, subset_new
550 LOGICAL, DIMENSION(:) :: in_use
551
552 INTEGER :: icon, iind, il
553 INTEGER, ALLOCATABLE, DIMENSION(:) :: tmp_l
554
555 ALLOCATE (tmp_l(SIZE(subset%l)))
556 tmp_l(:) = subset%l
557 subset_new%lmin = subset%lmin
558 subset_new%lmax = subset%lmin - 1
559 subset_new%nexp = subset%nexp
560 subset_new%n = subset%n
561 DO il = 1, SIZE(subset%l)
562 DO icon = 1, subset%l(il)
563 iind = convert_l_contr_to_entry(subset%lmin, subset%l, icon, subset%lmin + il - 1)
564 IF (.NOT. in_use(iind)) tmp_l(il) = tmp_l(il) - 1
565 END DO
566 IF (tmp_l(il) .GT. 0) subset_new%lmax = subset_new%lmax + 1
567 END DO
568 subset_new%nl = subset_new%lmax - subset_new%lmin + 1
569 subset_new%ncon_tot = sum(tmp_l)
570 ALLOCATE (subset_new%l(subset_new%nl))
571 ALLOCATE (subset_new%coeff(subset_new%nexp, subset_new%ncon_tot))
572 ALLOCATE (subset_new%exps(subset_new%nexp))
573 subset_new%exps(:) = subset%exps
574 DO il = 1, SIZE(subset%l)
575 IF (tmp_l(il) == 0) EXIT
576 subset_new%l(il) = tmp_l(il)
577 END DO
578 DEALLOCATE (tmp_l)
579 iind = 0
580 DO icon = 1, subset%ncon_tot
581 IF (in_use(icon)) THEN
582 iind = iind + 1
583 subset_new%coeff(:, iind) = subset%coeff(:, icon)
584 END IF
585 END DO
586
587 END SUBROUTINE create_new_subset
588
589! **************************************************************************************************
590!> \brief for completeness generate the derived info for set 0(reference from file)
591!> \param info ...
592!> \param basis ...
593!> \author Florian Schiffmann
594! **************************************************************************************************
595
596 SUBROUTINE init_deriv_info_ref(info, basis)
597 TYPE(derived_basis_info) :: info
598 TYPE(flex_basis_type) :: basis
599
600 INTEGER :: i
601
602 ALLOCATE (info%in_use_set(basis%nsets))
603 info%in_use_set = .true.
604 ALLOCATE (info%use_contr(basis%nsets))
605 DO i = 1, basis%nsets
606 ALLOCATE (info%use_contr(i)%in_use(basis%subset(i)%ncon_tot))
607 info%use_contr(i)%in_use = .true.
608 END DO
609
610 END SUBROUTINE init_deriv_info_ref
611
612! **************************************************************************************************
613!> \brief get the general information for the basis sets. E.g. what to optimize,
614!> Basis set name, constraints upon optimization and read the reference basis
615!> \param kind_section ...
616!> \param opt_bas ...
617!> \param para_env ...
618!> \author Florian Schiffmann
619! **************************************************************************************************
620
621 SUBROUTINE generate_initial_basis(kind_section, opt_bas, para_env)
622 TYPE(section_vals_type), POINTER :: kind_section
623 TYPE(basis_optimization_type) :: opt_bas
624 TYPE(mp_para_env_type), POINTER :: para_env
625
626 INTEGER :: ikind, variable_counter
627 LOGICAL :: explicit
628 TYPE(section_vals_type), POINTER :: set_section
629
630 CALL section_vals_get(kind_section, n_repetition=opt_bas%nkind)
631 ALLOCATE (opt_bas%kind_basis(opt_bas%nkind))
632
633 ! counter to get the number of free variables in optimization
634 variable_counter = 0
635 DO ikind = 1, opt_bas%nkind
636 CALL section_vals_val_get(kind_section, "_SECTION_PARAMETERS_", c_val=opt_bas%kind_basis(ikind)%element, &
637 i_rep_section=ikind)
638 CALL section_vals_val_get(kind_section, "BASIS_SET", c_val=opt_bas%kind_basis(ikind)%basis_name, &
639 i_rep_section=ikind)
640 set_section => section_vals_get_subs_vals(kind_section, "DERIVED_BASIS_SETS", &
641 i_rep_section=ikind)
642 CALL section_vals_get(set_section, n_repetition=opt_bas%kind_basis(ikind)%nbasis_deriv, explicit=explicit)
643 IF (.NOT. explicit) opt_bas%kind_basis(ikind)%nbasis_deriv = 0
644 ALLOCATE (opt_bas%kind_basis(ikind)%flex_basis(0:opt_bas%kind_basis(ikind)%nbasis_deriv))
645 ALLOCATE (opt_bas%kind_basis(ikind)%deriv_info(0:opt_bas%kind_basis(ikind)%nbasis_deriv))
646
647 CALL fill_basis_template(kind_section, opt_bas%kind_basis(ikind)%flex_basis(0), opt_bas%template_basis_file, &
648 opt_bas%kind_basis(ikind)%element, opt_bas%kind_basis(ikind)%basis_name, para_env, ikind)
649
650 CALL setup_exp_constraints(kind_section, opt_bas%kind_basis(ikind)%flex_basis(0))
651
652 CALL parse_derived_basis(kind_section, opt_bas%kind_basis(ikind)%deriv_info, ikind)
653
654 variable_counter = variable_counter + opt_bas%kind_basis(ikind)%flex_basis(0)%nopt
655 END DO
656
657 ALLOCATE (opt_bas%x_opt(variable_counter))
658
659 variable_counter = 0
660 DO ikind = 1, opt_bas%nkind
661 CALL assign_x_to_basis(opt_bas%x_opt, opt_bas%kind_basis(ikind)%flex_basis(0), variable_counter)
662 END DO
663
664 cpassert(variable_counter == SIZE(opt_bas%x_opt))
665
666 END SUBROUTINE generate_initial_basis
667
668! **************************************************************************************************
669!> \brief get low level information about how to construc new basis sets from reference
670!> \param kind_section ...
671!> \param deriv_info ...
672!> \param ikind ...
673!> \author Florian Schiffmann
674! **************************************************************************************************
675
676 SUBROUTINE parse_derived_basis(kind_section, deriv_info, ikind)
677 TYPE(section_vals_type), POINTER :: kind_section
678 TYPE(derived_basis_info), DIMENSION(:) :: deriv_info
679 INTEGER :: ikind
680
681 INTEGER :: i_rep, iset, jset, n_rep, nsets
682 INTEGER, DIMENSION(:), POINTER :: i_vals
683 LOGICAL :: explicit
684 TYPE(section_vals_type), POINTER :: set1_section
685
686 nsets = SIZE(deriv_info) - 1
687 set1_section => section_vals_get_subs_vals(kind_section, "DERIVED_BASIS_SETS", &
688 i_rep_section=ikind)
689 DO jset = 1, nsets
690 ! stracnge but as derive info is allcated from 0 to n the count over here has to be shifted
691 iset = jset + 1
692 CALL section_vals_val_get(set1_section, "BASIS_SET_NAME", c_val=deriv_info(iset)%basis_name, &
693 i_rep_section=jset)
694 CALL section_vals_val_get(set1_section, "REFERENCE_SET", i_vals=i_vals, i_rep_section=jset)
695 deriv_info(iset)%reference_set = i_vals(1)
696 CALL section_vals_val_get(set1_section, "REMOVE_CONTRACTION", explicit=explicit, n_rep_val=n_rep, &
697 i_rep_section=jset)
698 deriv_info(iset)%ncontr = n_rep
699 IF (explicit) THEN
700 ALLOCATE (deriv_info(iset)%remove_contr(n_rep, 3))
701 DO i_rep = 1, n_rep
702 CALL section_vals_val_get(set1_section, "REMOVE_CONTRACTION", i_rep_val=i_rep, i_vals=i_vals, &
703 i_rep_section=jset)
704 deriv_info(iset)%remove_contr(i_rep, :) = i_vals(:)
705 END DO
706 END IF
707 CALL section_vals_val_get(set1_section, "REMOVE_SET", explicit=explicit, n_rep_val=n_rep, &
708 i_rep_section=jset)
709 deriv_info(iset)%nsets = n_rep
710 IF (explicit) THEN
711 ALLOCATE (deriv_info(iset)%remove_set(n_rep))
712 DO i_rep = 1, n_rep
713 CALL section_vals_val_get(set1_section, "REMOVE_SET", i_rep_val=i_rep, i_vals=i_vals, &
714 i_rep_section=jset)
715 deriv_info(iset)%remove_set(i_rep) = i_vals(1)
716 END DO
717 END IF
718 END DO
719
720 END SUBROUTINE parse_derived_basis
721
722! **************************************************************************************************
723!> \brief get low level information about constraint on exponents
724!> \param kind1_section ...
725!> \param flex_basis ...
726!> \author Florian Schiffmann
727! **************************************************************************************************
728
729 SUBROUTINE setup_exp_constraints(kind1_section, flex_basis)
730 TYPE(section_vals_type), POINTER :: kind1_section
731 TYPE(flex_basis_type) :: flex_basis
732
733 INTEGER :: ipgf, irep, iset, nrep
734 INTEGER, DIMENSION(:), POINTER :: def_exp
735 LOGICAL :: is_bound, is_varlim
736 TYPE(section_vals_type), POINTER :: const_section
737
738 const_section => section_vals_get_subs_vals(kind1_section, "CONSTRAIN_EXPONENTS")
739 CALL section_vals_get(const_section, n_repetition=nrep)
740 DO irep = 1, nrep
741 CALL section_vals_val_get(const_section, "USE_EXP", i_vals=def_exp, i_rep_section=irep)
742 CALL section_vals_val_get(const_section, "BOUNDARIES", explicit=is_bound, i_rep_section=irep)
743 CALL section_vals_val_get(const_section, "MAX_VAR_FRACTION", explicit=is_varlim, i_rep_section=irep)
744 IF (is_bound .AND. is_varlim) &
745 CALL cp_abort(__location__, "Exponent has two constraints. "// &
746 "This is not possible at the moment. Please change input.")
747 IF (.NOT. is_bound .AND. .NOT. is_varlim) &
748 CALL cp_abort(__location__, "Exponent is declared to be constraint but none is given"// &
749 " Please change input.")
750 IF (def_exp(1) == -1) THEN
751 DO iset = 1, flex_basis%nsets
752 IF (def_exp(2) == -1) THEN
753 DO ipgf = 1, flex_basis%subset(iset)%nexp
754 CALL set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep)
755 END DO
756 ELSE
757 IF (def_exp(2) .LE. flex_basis%subset(iset)%nexp) &
758 CALL cp_abort(__location__, &
759 "Exponent declared in constraint is larger than number of exponents in the set"// &
760 " Please change input.")
761 CALL set_constraint(flex_basis, iset, def_exp(2), const_section, is_bound, is_varlim, irep)
762 END IF
763 END DO
764 ELSE
765 IF (.NOT. def_exp(1) .LE. flex_basis%nsets) &
766 CALL cp_abort(__location__, &
767 "Set number of constraint is larger than number of sets in the template basis set."// &
768 " Please change input.")
769 IF (def_exp(2) == -1) THEN
770 DO ipgf = 1, flex_basis%subset(iset)%nexp
771 CALL set_constraint(flex_basis, def_exp(1), ipgf, const_section, is_bound, is_varlim, irep)
772 END DO
773 ELSE
774 IF (.NOT. def_exp(2) .LE. flex_basis%subset(def_exp(1))%nexp) &
775 CALL cp_abort(__location__, &
776 "Exponent declared in constraint is larger than number of exponents in the set"// &
777 " Please change input.")
778 CALL set_constraint(flex_basis, def_exp(1), def_exp(2), const_section, is_bound, is_varlim, irep)
779 END IF
780 END IF
781 END DO
782
783 END SUBROUTINE setup_exp_constraints
784
785! **************************************************************************************************
786!> \brief put the constraint information in type and process if requires
787!> BOUNDARIES constraint gets transformed into MAX_VAR_FRACTION constraint.
788!> \param flex_basis ...
789!> \param iset ...
790!> \param ipgf ...
791!> \param const_section ...
792!> \param is_bound ...
793!> \param is_varlim ...
794!> \param irep ...
795!> \author Florian Schiffmann
796! **************************************************************************************************
797
798 SUBROUTINE set_constraint(flex_basis, iset, ipgf, const_section, is_bound, is_varlim, irep)
799 TYPE(flex_basis_type) :: flex_basis
800 INTEGER :: iset, ipgf
801 TYPE(section_vals_type), POINTER :: const_section
802 LOGICAL :: is_bound, is_varlim
803 INTEGER :: irep
804
805 REAL(kind=dp) :: r_val
806 REAL(kind=dp), DIMENSION(:), POINTER :: r_vals
807
808 IF (flex_basis%subset(iset)%exp_has_const(ipgf)) &
809 CALL cp_abort(__location__, &
810 "Multiple constraints due to collision in CONSTRAIN_EXPONENTS."// &
811 " Please change input.")
812 flex_basis%subset(iset)%exp_has_const(ipgf) = .true.
813 IF (is_bound) THEN
814 flex_basis%subset(iset)%exp_const(ipgf)%const_type = 0
815 CALL section_vals_val_get(const_section, "BOUNDARIES", r_vals=r_vals, i_rep_section=irep)
816 flex_basis%subset(iset)%exp_const(ipgf)%llim = minval(r_vals)
817 flex_basis%subset(iset)%exp_const(ipgf)%ulim = maxval(r_vals)
818 r_val = flex_basis%subset(iset)%exps(ipgf)
819 IF (flex_basis%subset(iset)%exps(ipgf) .GT. maxval(r_vals) .OR. flex_basis%subset(iset)%exps(ipgf) .LT. minval(r_vals)) &
820 CALL cp_abort(__location__, &
821 "Exponent "//cp_to_string(r_val)// &
822 " declared in constraint is out of bounds of constraint"//cp_to_string(minval(r_vals))// &
823 " to"//cp_to_string(maxval(r_vals))// &
824 " Please change input.")
825 flex_basis%subset(iset)%exp_const(ipgf)%init = sum(r_vals)/2.0_dp
826 flex_basis%subset(iset)%exp_const(ipgf)%var_fac = maxval(r_vals)/flex_basis%subset(iset)%exp_const(ipgf)%init - 1.0_dp
827 END IF
828 IF (is_varlim) THEN
829 flex_basis%subset(iset)%exp_const(ipgf)%const_type = 1
830 CALL section_vals_val_get(const_section, "MAX_VAR_FRACTION", r_vals=r_vals, i_rep_section=irep)
831 flex_basis%subset(iset)%exp_const(ipgf)%var_fac = r_vals(1)
832 flex_basis%subset(iset)%exp_const(ipgf)%init = flex_basis%subset(iset)%exps(ipgf)
833 END IF
834
835 END SUBROUTINE set_constraint
836
837! **************************************************************************************************
838!> \brief Initialize the optimization vector with the values from the refernece sets
839!> \param x ...
840!> \param basis ...
841!> \param x_ind ...
842!> \author Florian Schiffmann
843! **************************************************************************************************
844
845 SUBROUTINE assign_x_to_basis(x, basis, x_ind)
846 REAL(kind=dp), DIMENSION(:) :: x
847 TYPE(flex_basis_type) :: basis
848 INTEGER :: x_ind
849
850 INTEGER :: icont, ipgf, iset
851
852 DO iset = 1, basis%nsets
853 DO ipgf = 1, basis%subset(iset)%nexp
854 IF (basis%subset(iset)%opt_exps(ipgf)) THEN
855 x_ind = x_ind + 1
856 basis%subset(iset)%exp_x_ind(ipgf) = x_ind
857 x(x_ind) = basis%subset(iset)%exps(ipgf)
858 END IF
859 DO icont = 1, basis%subset(iset)%ncon_tot
860 IF (basis%subset(iset)%opt_coeff(ipgf, icont)) THEN
861 x_ind = x_ind + 1
862 basis%subset(iset)%coeff_x_ind(ipgf, icont) = x_ind
863 x(x_ind) = basis%subset(iset)%coeff(ipgf, icont)
864 END IF
865 END DO
866 END DO
867 END DO
868
869 END SUBROUTINE assign_x_to_basis
870
871! **************************************************************************************************
872!> \brief Fill the reference set and get the free varialbles from input
873!> \param kind1_section ...
874!> \param flex_basis ...
875!> \param template_basis_file ...
876!> \param element ...
877!> \param basis_name ...
878!> \param para_env ...
879!> \param ikind ...
880!> \author Florian Schiffmann
881! **************************************************************************************************
882
883 SUBROUTINE fill_basis_template(kind1_section, flex_basis, template_basis_file, element, basis_name, para_env, ikind)
884 TYPE(section_vals_type), POINTER :: kind1_section
885 TYPE(flex_basis_type) :: flex_basis
886 CHARACTER(LEN=default_path_length) :: template_basis_file
887 CHARACTER(LEN=default_string_length) :: element, basis_name
888 TYPE(mp_para_env_type), POINTER :: para_env
889 INTEGER :: ikind
890
891 INTEGER :: icont, idof, ipgf, irep, iset, nrep
892 INTEGER, DIMENSION(:), POINTER :: switch
893
894 CALL parse_basis(flex_basis, template_basis_file, element, basis_name, para_env)
895
896 ! get the optimizable parameters. Many way to modify them but in the end only logical matrix
897 ! is either set or values get flipped according to the input
898 CALL section_vals_val_get(kind1_section, "INITIAL_DEGREES_OF_FREEDOM", i_val=idof, &
899 i_rep_section=ikind)
900 DO iset = 1, flex_basis%nsets
901 SELECT CASE (idof)
902 CASE (do_opt_none)
903 ! initialization in parse subset did the job
904 CASE (do_opt_all)
905 flex_basis%subset(iset)%opt_coeff = .true.
906 flex_basis%subset(iset)%opt_exps = .true.
907 CASE (do_opt_coeff)
908 flex_basis%subset(iset)%opt_coeff = .true.
909 CASE (do_opt_exps)
910 flex_basis%subset(iset)%opt_exps = .true.
911 CASE DEFAULT
912 cpabort("No initialization available?????")
913 END SELECT
914 END DO
915
916 CALL section_vals_val_get(kind1_section, "SWITCH_CONTRACTION_STATE", n_rep_val=nrep, i_rep_section=ikind)
917 DO irep = 1, nrep
918 CALL section_vals_val_get(kind1_section, "SWITCH_CONTRACTION_STATE", i_rep_val=irep, &
919 i_rep_section=ikind, i_vals=switch)
920 icont = convert_l_contr_to_entry(flex_basis%subset(switch(1))%lmin, flex_basis%subset(switch(1))%l, switch(3), switch(2))
921 DO ipgf = 1, flex_basis%subset(switch(1))%nexp
922 flex_basis%subset(switch(1))%opt_coeff(ipgf, icont) = .NOT. flex_basis%subset(switch(1))%opt_coeff(ipgf, icont)
923 END DO
924 END DO
925
926 CALL section_vals_val_get(kind1_section, "SWITCH_COEFF_STATE", n_rep_val=nrep, i_rep_section=ikind)
927 DO irep = 1, nrep
928 CALL section_vals_val_get(kind1_section, "SWITCH_COEFF_STATE", i_rep_val=irep, &
929 i_rep_section=ikind, i_vals=switch)
930 icont = convert_l_contr_to_entry(flex_basis%subset(switch(1))%lmin, flex_basis%subset(switch(1))%l, switch(3), switch(2))
931 flex_basis%subset(switch(1))%opt_coeff(switch(4), icont) = &
932 .NOT. flex_basis%subset(switch(1))%opt_coeff(switch(4), icont)
933 END DO
934
935 CALL section_vals_val_get(kind1_section, "SWITCH_EXP_STATE", n_rep_val=nrep, i_rep_section=ikind)
936 DO irep = 1, nrep
937 CALL section_vals_val_get(kind1_section, "SWITCH_EXP_STATE", i_rep_val=irep, &
938 i_rep_section=ikind, i_vals=switch)
939 flex_basis%subset(switch(1))%opt_exps(switch(2)) = .NOT. flex_basis%subset(switch(1))%opt_exps(switch(2))
940 END DO
941
942 CALL section_vals_val_get(kind1_section, "SWITCH_SET_STATE", n_rep_val=nrep, i_rep_section=ikind)
943 DO irep = 1, nrep
944 CALL section_vals_val_get(kind1_section, "SWITCH_SET_STATE", i_rep_val=irep, &
945 i_rep_section=ikind, i_vals=switch)
946 DO ipgf = 1, flex_basis%subset(switch(2))%nexp
947 SELECT CASE (switch(1))
948 CASE (0) ! switch all states in the set
949 DO icont = 1, flex_basis%subset(switch(2))%ncon_tot
950 flex_basis%subset(switch(2))%opt_coeff(ipgf, icont) = &
951 .NOT. flex_basis%subset(switch(2))%opt_coeff(ipgf, icont)
952 END DO
953 flex_basis%subset(switch(2))%opt_exps(ipgf) = .NOT. flex_basis%subset(switch(2))%opt_exps(ipgf)
954 CASE (1) ! switch only exp
955 flex_basis%subset(switch(2))%opt_exps(ipgf) = .NOT. flex_basis%subset(switch(2))%opt_exps(ipgf)
956 CASE (2) ! switch only coeff
957 DO icont = 1, flex_basis%subset(switch(2))%ncon_tot
958 flex_basis%subset(switch(2))%opt_coeff(ipgf, icont) = &
959 .NOT. flex_basis%subset(switch(2))%opt_coeff(ipgf, icont)
960 END DO
961 CASE DEFAULT
962 cpabort("Invalid option in SWITCH_SET_STATE, 1st value has to be 0, 1 or 2")
963 END SELECT
964 END DO
965 END DO
966
967 ! perform a final modification. If basis set is uncontracted coefficient will never have to be optimized
968 DO irep = 1, flex_basis%nsets
969 IF (flex_basis%subset(irep)%nexp == 1) THEN
970 DO ipgf = 1, flex_basis%subset(irep)%nexp
971 flex_basis%subset(irep)%opt_coeff(ipgf, 1) = .false.
972 END DO
973 END IF
974 END DO
975
976 ! finally count the total number of free parameters
977 flex_basis%nopt = 0
978 DO irep = 1, flex_basis%nsets
979 DO ipgf = 1, flex_basis%subset(irep)%nexp
980 DO icont = 1, flex_basis%subset(irep)%ncon_tot
981 IF (flex_basis%subset(irep)%opt_coeff(ipgf, icont)) flex_basis%nopt = flex_basis%nopt + 1
982 END DO
983 IF (flex_basis%subset(irep)%opt_exps(ipgf)) flex_basis%nopt = flex_basis%nopt + 1
984 END DO
985 END DO
986
987 END SUBROUTINE fill_basis_template
988
989! **************************************************************************************************
990!> \brief Helper function to parse input. Converts l and index position of
991!> a contraction to index in the contraction array of the set using lmin and nl
992!> \param lmin ...
993!> \param nl ...
994!> \param icontr ...
995!> \param l ...
996!> \return ...
997!> \author Florian Schiffmann
998! **************************************************************************************************
999
1000 FUNCTION convert_l_contr_to_entry(lmin, nl, icontr, l) RESULT(ientry)
1001 INTEGER :: lmin
1002 INTEGER, DIMENSION(:) :: nl
1003 INTEGER :: icontr, l, ientry
1004
1005 INTEGER :: i, icon2l, iwork
1006
1007 iwork = l - lmin
1008 icon2l = 0
1009 DO i = 1, iwork
1010 icon2l = icon2l + nl(i)
1011 END DO
1012 ientry = icon2l + icontr
1013
1014 END FUNCTION convert_l_contr_to_entry
1015
1016! **************************************************************************************************
1017!> \brief Read the reference basis sets from the template basis file
1018!> \param flex_basis ...
1019!> \param template_basis_file ...
1020!> \param element ...
1021!> \param basis_name ...
1022!> \param para_env ...
1023!> \author Florian Schiffmann
1024! **************************************************************************************************
1025
1026 SUBROUTINE parse_basis(flex_basis, template_basis_file, element, basis_name, para_env)
1027 TYPE(flex_basis_type) :: flex_basis
1028 CHARACTER(LEN=default_path_length) :: template_basis_file
1029 CHARACTER(LEN=default_string_length) :: element, basis_name
1030 TYPE(mp_para_env_type), POINTER :: para_env
1031
1032 CHARACTER(LEN=240) :: line
1033 CHARACTER(LEN=242) :: line2
1034 CHARACTER(LEN=LEN(basis_name)+2) :: basis_name2
1035 CHARACTER(LEN=LEN(element)+2) :: element2
1036 INTEGER :: iset, strlen1, strlen2
1037 LOGICAL :: basis_found, found, match
1038 TYPE(cp_parser_type) :: parser
1039
1040 basis_found = .false.
1041 CALL uppercase(element)
1042 CALL uppercase(basis_name)
1043 CALL parser_create(parser, template_basis_file, para_env=para_env)
1044
1045 search_loop: DO
1046 CALL parser_search_string(parser, trim(basis_name), .true., found, line)
1047 IF (found) THEN
1048 match = .false.
1049 CALL uppercase(line)
1050 ! Check both the element symbol and the basis set name
1051 line2 = " "//line//" "
1052 element2 = " "//trim(element)//" "
1053 basis_name2 = " "//trim(basis_name)//" "
1054 strlen1 = len_trim(element2) + 1
1055 strlen2 = len_trim(basis_name2) + 1
1056 IF ((index(line2, element2(:strlen1)) > 0) .AND. &
1057 (index(line2, basis_name2(:strlen2)) > 0)) match = .true.
1058 IF (match) THEN
1059 CALL parser_get_object(parser, flex_basis%nsets, newline=.true.)
1060 ALLOCATE (flex_basis%subset(flex_basis%nsets))
1061 DO iset = 1, flex_basis%nsets
1062 CALL parse_subset(parser, flex_basis%subset(iset))
1063 END DO
1064 basis_found = .true.
1065 EXIT
1066 END IF
1067 ELSE
1068 EXIT search_loop
1069 END IF
1070 END DO search_loop
1071 CALL parser_release(parser)
1072
1073 IF (.NOT. basis_found) CALL cp_abort(__location__, &
1074 "The requested basis set <"//trim(basis_name)// &
1075 "> for element <"//trim(element)//"> was not "// &
1076 "found in the template basis set file ")
1077
1078 END SUBROUTINE parse_basis
1079
1080! **************************************************************************************************
1081!> \brief Read the subset information from the template basis file
1082!> \param parser ...
1083!> \param subset ...
1084!> \author Florian Schiffmann
1085! **************************************************************************************************
1086 SUBROUTINE parse_subset(parser, subset)
1087 TYPE(cp_parser_type), INTENT(INOUT) :: parser
1088 TYPE(subset_type) :: subset
1089
1090 CHARACTER(len=20*default_string_length) :: line_att
1091 INTEGER :: icon1, icon2, il, ipgf, ishell, istart
1092 REAL(kind=dp) :: gs_scale
1093 REAL(kind=dp), POINTER :: r_val
1094
1095 line_att = ""
1096 CALL parser_get_object(parser, subset%n, newline=.true.)
1097 CALL parser_get_object(parser, subset%lmin)
1098 CALL parser_get_object(parser, subset%lmax)
1099 CALL parser_get_object(parser, subset%nexp)
1100 subset%nl = subset%lmax - subset%lmin + 1
1101 ALLOCATE (r_val)
1102 ALLOCATE (subset%l(subset%nl))
1103 ALLOCATE (subset%exps(subset%nexp))
1104 ALLOCATE (subset%exp_has_const(subset%nexp))
1105 subset%exp_has_const = .false.
1106 ALLOCATE (subset%opt_exps(subset%nexp))
1107 subset%opt_exps = .false.
1108 ALLOCATE (subset%exp_const(subset%nexp))
1109 ALLOCATE (subset%exp_x_ind(subset%nexp))
1110 DO ishell = 1, subset%nl
1111 CALL parser_get_object(parser, subset%l(ishell))
1112 END DO
1113 subset%ncon_tot = sum(subset%l)
1114 ALLOCATE (subset%coeff(subset%nexp, subset%ncon_tot))
1115 ALLOCATE (subset%opt_coeff(subset%nexp, subset%ncon_tot))
1116 subset%opt_coeff = .false.
1117 ALLOCATE (subset%coeff_x_ind(subset%nexp, subset%ncon_tot))
1118 DO ipgf = 1, subset%nexp
1119 CALL parser_get_object(parser, r_val, newline=.true.)
1120 subset%exps(ipgf) = r_val
1121 DO ishell = 1, subset%ncon_tot
1122 CALL parser_get_object(parser, r_val)
1123 subset%coeff(ipgf, ishell) = r_val
1124 END DO
1125 END DO
1126
1127 ! orthonormalize contraction coefficients using gram schmidt
1128 istart = 1
1129 DO il = 1, subset%nl
1130 DO icon1 = istart, istart + subset%l(il) - 2
1131 DO icon2 = icon1 + 1, istart + subset%l(il) - 1
1132 gs_scale = dot_product(subset%coeff(:, icon2), subset%coeff(:, icon1))/ &
1133 dot_product(subset%coeff(:, icon1), subset%coeff(:, icon1))
1134 subset%coeff(:, icon2) = subset%coeff(:, icon2) - gs_scale*subset%coeff(:, icon1)
1135 END DO
1136 END DO
1137 istart = istart + subset%l(il)
1138 END DO
1139
1140 ! just to get an understandable basis normalize coefficients
1141 DO icon1 = 1, subset%ncon_tot
1142 subset%coeff(:, icon1) = subset%coeff(:, icon1)/ &
1143 sqrt(dot_product(subset%coeff(:, icon1), subset%coeff(:, icon1)))
1144 END DO
1145 DEALLOCATE (r_val)
1146
1147 END SUBROUTINE parse_subset
1148
1149! **************************************************************************************************
1150!> \brief Initialize the variables for the powell optimizer
1151!> \param p_param ...
1152!> \param powell_section ...
1153!> \author Florian Schiffmann
1154! **************************************************************************************************
1155
1156 SUBROUTINE init_powell_var(p_param, powell_section)
1157 TYPE(opt_state_type), INTENT(INOUT) :: p_param
1158 TYPE(section_vals_type), POINTER :: powell_section
1159
1160 p_param%state = 0
1161 p_param%nvar = 0
1162 p_param%iprint = 0
1163 p_param%unit = default_output_unit
1164 CALL section_vals_val_get(powell_section, "ACCURACY", r_val=p_param%rhoend)
1165 CALL section_vals_val_get(powell_section, "STEP_SIZE", r_val=p_param%rhobeg)
1166 CALL section_vals_val_get(powell_section, "MAX_FUN", i_val=p_param%maxfun)
1167
1168 END SUBROUTINE init_powell_var
1169
1170END MODULE optimize_basis_utils
cp_log_handling::cp_to_string
Definition cp_log_handling.F:90
cp_parser_methods::parser_get_object
Definition cp_parser_methods.F:54
cp_files
Utility routines to open and close files. Tracking of preconnections.
Definition cp_files.F:16
cp_files::open_file
subroutine, public open_file(file_name, file_status, file_form, file_action, file_position, file_pad, unit_number, debug, skip_get_unit_number, file_access)
Opens the requested file using a free unit number.
Definition cp_files.F:308
cp_files::close_file
subroutine, public close_file(unit_number, file_status, keep_preconnection)
Close an open file given by its logical unit number. Optionally, keep the file and unit preconnected.
Definition cp_files.F:119
cp_log_handling
various routines to log and control the output. The idea is that decisions about where to log should ...
Definition cp_log_handling.F:41
cp_log_handling::cp_logger_get_default_unit_nr
recursive integer function, public cp_logger_get_default_unit_nr(logger, local, skip_not_ionode)
asks the default unit number of the given logger. try to use cp_logger_get_unit_nr
Definition cp_log_handling.F:567
cp_log_handling::cp_get_default_logger
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
Definition cp_log_handling.F:234
cp_parser_methods
Utility routines to read data from files. Kept as close as possible to the old parser because.
Definition cp_parser_methods.F:20
cp_parser_methods::parser_search_string
subroutine, public parser_search_string(parser, string, ignore_case, found, line, begin_line, search_from_begin_of_file)
Search a string pattern in a file defined by its logical unit number "unit". A case sensitive search ...
Definition cp_parser_methods.F:786
cp_parser_types
Utility routines to read data from files. Kept as close as possible to the old parser because.
Definition cp_parser_types.F:21
cp_parser_types::parser_release
subroutine, public parser_release(parser)
releases the parser
Definition cp_parser_types.F:109
cp_parser_types::parser_create
subroutine, public parser_create(parser, file_name, unit_nr, para_env, end_section_label, separator_chars, comment_char, continuation_char, quote_char, section_char, parse_white_lines, initial_variables, apply_preprocessing)
Start a parser run. Initial variables allow to @SET stuff before opening the file.
Definition cp_parser_types.F:147
input_constants
collects all constants needed in input so that they can be used without circular dependencies
Definition input_constants.F:17
input_constants::do_opt_coeff
integer, parameter, public do_opt_coeff
Definition input_constants.F:1096
input_constants::do_opt_all
integer, parameter, public do_opt_all
Definition input_constants.F:1096
input_constants::do_opt_exps
integer, parameter, public do_opt_exps
Definition input_constants.F:1096
input_constants::do_opt_none
integer, parameter, public do_opt_none
Definition input_constants.F:1096
input_section_types
objects that represent the structure of input sections and the data contained in an input section
Definition input_section_types.F:15
input_section_types::section_vals_get_subs_vals
recursive type(section_vals_type) function, pointer, public section_vals_get_subs_vals(section_vals, subsection_name, i_rep_section, can_return_null)
returns the values of the requested subsection
Definition input_section_types.F:724
input_section_types::section_vals_get
subroutine, public section_vals_get(section_vals, ref_count, n_repetition, n_subs_vals_rep, section, explicit)
returns various attributes about the section_vals
Definition input_section_types.F:697
input_section_types::section_vals_val_get
subroutine, public section_vals_val_get(section_vals, keyword_name, i_rep_section, i_rep_val, n_rep_val, val, l_val, i_val, r_val, c_val, l_vals, i_vals, r_vals, c_vals, explicit)
returns the requested value
Definition input_section_types.F:1040
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
kinds::default_string_length
integer, parameter, public default_string_length
Definition kinds.F:57
kinds::default_path_length
integer, parameter, public default_path_length
Definition kinds.F:58
machine
Machine interface based on Fortran 2003 and POSIX.
Definition machine.F:17
machine::default_output_unit
integer, parameter, public default_output_unit
Definition machine.F:45
machine::m_getcwd
subroutine, public m_getcwd(curdir)
...
Definition machine.F:507
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:23
optimize_basis_types
Definition optimize_basis_types.F:7
optimize_basis_utils
Definition optimize_basis_utils.F:7
optimize_basis_utils::get_set_and_basis_id
subroutine, public get_set_and_basis_id(calc_id, opt_bas, set_id, bas_id)
returns a mapping from the calculation id to the trainings set id and basis combination id
Definition optimize_basis_utils.F:223
optimize_basis_utils::optimize_basis_init_read_input
subroutine, public optimize_basis_init_read_input(opt_bas, root_section, para_env)
initialize all parts of the optimization type and read input settings
Definition optimize_basis_utils.F:60
optimize_basis_utils::update_derived_basis_sets
subroutine, public update_derived_basis_sets(opt_bas, write_it, output_file, para_env)
Regenerate the basis sets from reference 0 after an update from the optimizer to reference was perfor...
Definition optimize_basis_utils.F:343
powell
Definition powell.F:9
string_utilities
Utilities for string manipulations.
Definition string_utilities.F:16
string_utilities::newline
character(len=1), parameter, public newline
Definition string_utilities.F:29
string_utilities::uppercase
elemental subroutine, public uppercase(string)
Convert all lower case characters in a string to upper case.
Definition string_utilities.F:3361
cp_log_handling::cp_logger_type
type of a logger, at the moment it contains just a print level starting at which level it should be l...
Definition cp_log_handling.F:140
cp_parser_types::cp_parser_type
represent a parser
Definition cp_parser_types.F:77
input_section_types::section_vals_type
stores the values of a section
Definition input_section_types.F:126
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:763
optimize_basis_types::basis_optimization_type
type containing all information needed for basis matching
Definition optimize_basis_types.F:97
optimize_basis_types::derived_basis_info
Definition optimize_basis_types.F:64
optimize_basis_types::flex_basis_type
Definition optimize_basis_types.F:51
optimize_basis_types::subset_type
Definition optimize_basis_types.F:35
powell::opt_state_type
Definition powell.F:18