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