(git:e7e05ae)
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 !--------------------------------------------------------------------------------------------------!
7 MODULE 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 
49 CONTAINS
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 
1170 END MODULE optimize_basis_utils
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::uppercase
elemental subroutine, public uppercase(string)
Convert all lower case characters in a string to upper case.
Definition: string_utilities.F:3361
powell::opt_state_type
Definition: powell.F:18