(git:ccc2433)
tmc_tree_build.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 
8 ! **************************************************************************************************
9 !> \brief tree nodes creation, deallocation, references etc.
10 !> - we distinguish two kinds of tree nodes: global and sub tree nodes
11 !> (because we also are able to do parallel tempering)
12 !> - global tree nodes consists of pointers to sub tree nodes
13 !> - sub tree nodes consists of position arrays, potential energy, etc.
14 !> - furthermore the sub tree elements have references the all global
15 !> tree elements referring to them
16 !> - for tree element details see tree_types.F
17 !>
18 !> - for creating we always start with the global tree element
19 !> (if not already exist)
20 !> - for each new global tree element (depending on the move type):
21 !> - two sub tree elements are swapped (Parallel Tempering)
22 !> (in global tree element creation)
23 !> - the volume of a subtree element is changed
24 !> (directly in sub tree element creation)
25 !> - positions in one subtree element changes
26 !> (in sub tree elem creation or NMC)
27 !> - ...
28 !> - sub tree elements will be deleted only if no reference to
29 !> any global tree element exist anymore
30 !> \par History
31 !> 11.2012 created [Mandes Schoenherr]
32 !> \author Mandes
33 ! **************************************************************************************************
34 
35 MODULE tmc_tree_build
36  USE cp_log_handling, ONLY: cp_to_string
37  USE kinds, ONLY: dp
38  USE tmc_calculations, ONLY: calc_e_kin,&
39  init_vel
40  USE tmc_dot_tree, ONLY: create_dot,&
41  create_dot_color,&
42  create_global_tree_dot,&
43  create_global_tree_dot_color
44  USE tmc_file_io, ONLY: read_restart_file,&
45  write_result_list_element
46  USE tmc_move_handle, ONLY: select_random_move_type
47  USE tmc_move_types, ONLY: &
48  mv_type_md, mv_type_nmc_moves, mv_type_atom_swap, mv_type_atom_trans, &
49  mv_type_gausian_adapt, mv_type_mol_rot, mv_type_mol_trans, mv_type_none, &
50  mv_type_proton_reorder, mv_type_swap_conf, mv_type_volume_move
51  USE tmc_moves, ONLY: change_pos,&
52  elements_in_new_subbox
53  USE tmc_stati, ONLY: tmc_status_failed,&
54  tmc_status_wait_for_new_task,&
55  task_type_mc,&
56  task_type_gaussian_adaptation
57  USE tmc_tree_references, ONLY: add_to_references,&
58  remove_gt_references,&
59  remove_subtree_element_of_all_references,&
60  search_and_remove_reference_in_list
61  USE tmc_tree_search, ONLY: most_prob_end,&
62  search_end_of_clean_g_tree,&
63  search_end_of_clean_tree,&
64  search_parent_element
65  USE tmc_tree_types, ONLY: &
66  add_to_list, elem_array_type, global_tree_type, status_accepted, status_accepted_result, &
67  status_calc_approx_ener, status_calculate_md, status_calculate_nmc_steps, &
68  status_calculate_energy, status_calculated, status_cancel_ener, status_cancel_nmc, &
69  status_canceled_ener, status_canceled_nmc, status_created, status_deleted, &
70  status_deleted_result, status_ok, status_rejected, status_rejected_result, tree_type
71  USE tmc_types, ONLY: tmc_env_type,&
72  tmc_param_type
73 #include "../base/base_uses.f90"
74 
75  IMPLICIT NONE
76 
77  PRIVATE
78 
79  CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'tmc_tree_build'
80 
81  PUBLIC :: allocate_new_sub_tree_node, deallocate_sub_tree_node
82  PUBLIC :: init_tree_mod, finalize_init
83  PUBLIC :: create_new_gt_tree_node
84  PUBLIC :: remove_unused_g_tree
85  PUBLIC :: remove_all_trees
86  PUBLIC :: finalize_trees
87 CONTAINS
88 
89  !********************************************************************************
90  ! ALLOCATION - DEALLOCATION
91  !********************************************************************************
92 ! **************************************************************************************************
93 !> \brief allocates an elements of the global element structure
94 !> \param next_el ...
95 !> \param nr_temp ...
96 !> \author Mandes 11.2012
97 ! **************************************************************************************************
98  SUBROUTINE allocate_new_global_tree_node(next_el, nr_temp)
99  TYPE(global_tree_type), POINTER :: next_el
100  INTEGER :: nr_temp
101 
102  CHARACTER(LEN=*), PARAMETER :: routineN = 'allocate_new_global_tree_node'
103 
104  INTEGER :: handle, itmp
105 
106  cpassert(.NOT. ASSOCIATED(next_el))
107 
108  ! start the timing
109  CALL timeset(routinen, handle)
110 
111  ! allocate everything
112  ALLOCATE (next_el)
113  ALLOCATE (next_el%conf(nr_temp))
114  ALLOCATE (next_el%conf_n_acc(nr_temp))
115  next_el%rnd_nr = -1.0_dp
116 
117  DO itmp = 1, nr_temp
118  NULLIFY (next_el%conf(itmp)%elem)
119  next_el%conf_n_acc(itmp) = .false.
120  END DO
121 
122  next_el%swaped = .false.
123  ! end the timing
124  CALL timestop(handle)
125  END SUBROUTINE allocate_new_global_tree_node
126 
127 ! **************************************************************************************************
128 !> \brief deallocates an elements of the global element structure
129 !> \param gt_elem ...
130 !> \author Mandes 11.2012
131 ! **************************************************************************************************
132  SUBROUTINE deallocate_global_tree_node(gt_elem)
133  TYPE(global_tree_type), POINTER :: gt_elem
134 
135  CHARACTER(LEN=*), PARAMETER :: routineN = 'deallocate_global_tree_node'
136 
137  INTEGER :: handle
138 
139  cpassert(ASSOCIATED(gt_elem))
140 
141  ! start the timing
142  CALL timeset(routinen, handle)
143 
144  ! deallocate everything
145  DEALLOCATE (gt_elem%conf_n_acc)
146  DEALLOCATE (gt_elem%conf)
147  DEALLOCATE (gt_elem)
148  ! end the timing
149  CALL timestop(handle)
150  END SUBROUTINE deallocate_global_tree_node
151 
152 ! **************************************************************************************************
153 !> \brief allocates an elements of the subtree element structure
154 !> \param tmc_params structure for storing all (global) parameters
155 !> \param next_el ...
156 !> \param nr_dim ...
157 !> \author Mandes 11.2012
158 ! **************************************************************************************************
159  SUBROUTINE allocate_new_sub_tree_node(tmc_params, next_el, nr_dim)
160  TYPE(tmc_param_type), POINTER :: tmc_params
161  TYPE(tree_type), POINTER :: next_el
162  INTEGER :: nr_dim
163 
164  CHARACTER(LEN=*), PARAMETER :: routinen = 'allocate_new_sub_tree_node'
165 
166  INTEGER :: handle
167 
168  cpassert(.NOT. ASSOCIATED(next_el))
169 
170  ! start the timing
171  CALL timeset(routinen, handle)
172 
173  ALLOCATE (next_el)
174  NULLIFY (next_el%subbox_center, next_el%pos, next_el%mol, next_el%vel, &
175  next_el%frc, next_el%dipole, next_el%elem_stat, &
176  next_el%gt_nodes_references)
177 
178  next_el%scf_energies(:) = huge(next_el%scf_energies)
179  next_el%scf_energies_count = 0
180  ALLOCATE (next_el%pos(nr_dim))
181  ALLOCATE (next_el%mol(nr_dim/tmc_params%dim_per_elem))
182  ALLOCATE (next_el%vel(nr_dim))
183  IF (tmc_params%print_dipole) ALLOCATE (next_el%dipole(tmc_params%dim_per_elem))
184  ALLOCATE (next_el%elem_stat(nr_dim))
185  next_el%elem_stat = status_ok
186  ALLOCATE (next_el%subbox_center(tmc_params%dim_per_elem))
187  IF (tmc_params%print_forces .OR. tmc_params%task_type .EQ. task_type_gaussian_adaptation) THEN
188  IF (tmc_params%task_type .EQ. task_type_gaussian_adaptation) THEN
189  ALLOCATE (next_el%frc(nr_dim*nr_dim))
190  ELSE
191  ALLOCATE (next_el%frc(nr_dim))
192  END IF
193  next_el%frc = 0.0_dp
194  END IF
195  ALLOCATE (next_el%box_scale(3))
196  next_el%pos(:) = -1.0_dp
197  next_el%mol(:) = -1
198  next_el%box_scale(:) = 1.0_dp
199  next_el%scf_energies(:) = 0.0_dp
200  next_el%e_pot_approx = 0.0_dp
201  next_el%potential = 76543.0_dp
202  next_el%vel = 0.0_dp ! standart MC don"t uses velocities, but it is used at least in acceptance check
203  next_el%ekin = 0.0_dp
204  next_el%ekin_before_md = 0.0_dp
205  next_el%sub_tree_nr = 0
206  next_el%nr = -1
207  next_el%rng_seed(:, :, :) = -1.0
208  next_el%move_type = mv_type_none
209 
210  ! end the timing
211  CALL timestop(handle)
212  END SUBROUTINE allocate_new_sub_tree_node
213 
214 ! **************************************************************************************************
215 !> \brief deallocates an elements of the subtree element structure
216 !> \param tree_elem ...
217 !> \author Mandes 11.2012
218 ! **************************************************************************************************
219  SUBROUTINE deallocate_sub_tree_node(tree_elem)
220  TYPE(tree_type), POINTER :: tree_elem
221 
222  CHARACTER(LEN=*), PARAMETER :: routinen = 'deallocate_sub_tree_node'
223 
224  INTEGER :: handle
225 
226  cpassert(ASSOCIATED(tree_elem))
227 
228  ! start the timing
229  CALL timeset(routinen, handle)
230 
231  ! reference handling
232  ! should be not necessary, subtree element should be only deallocated,
233  ! if no global tree element points to anymore
234  CALL remove_subtree_element_of_all_references(ptr=tree_elem)
235 
236  IF (ASSOCIATED(tree_elem%box_scale)) DEALLOCATE (tree_elem%box_scale)
237  IF (ASSOCIATED(tree_elem%frc)) DEALLOCATE (tree_elem%frc)
238  IF (ASSOCIATED(tree_elem%subbox_center)) DEALLOCATE (tree_elem%subbox_center)
239  IF (ASSOCIATED(tree_elem%elem_stat)) DEALLOCATE (tree_elem%elem_stat)
240  IF (ASSOCIATED(tree_elem%dipole)) DEALLOCATE (tree_elem%dipole)
241  IF (ASSOCIATED(tree_elem%vel)) DEALLOCATE (tree_elem%vel)
242  IF (ASSOCIATED(tree_elem%mol)) DEALLOCATE (tree_elem%mol)
243  IF (ASSOCIATED(tree_elem%pos)) DEALLOCATE (tree_elem%pos)
244 
245  DEALLOCATE (tree_elem)
246  ! end the timing
247  CALL timestop(handle)
248  END SUBROUTINE deallocate_sub_tree_node
249 
250  !********************************************************************************
251  ! INITIALIZATION - FINALIZE
252  !********************************************************************************
253 
254 ! **************************************************************************************************
255 !> \brief routine initiate the global and subtrees with the first elements
256 !> \param start_elem ...
257 !> \param tmc_env structure for storing all (global) parameters
258 !> \param job_counts ...
259 !> \param worker_timings ...
260 !> \author Mandes 11.2012
261 ! **************************************************************************************************
262  SUBROUTINE init_tree_mod(start_elem, tmc_env, job_counts, worker_timings)
263  TYPE(tree_type), POINTER :: start_elem
264  TYPE(tmc_env_type), POINTER :: tmc_env
265  INTEGER, DIMENSION(:) :: job_counts
266  REAL(kind=dp), DIMENSION(4) :: worker_timings
267 
268  CHARACTER(LEN=*), PARAMETER :: routinen = 'init_tree_mod'
269 
270  INTEGER :: handle, i
271  TYPE(global_tree_type), POINTER :: global_tree
272 
273  NULLIFY (global_tree)
274 
275  cpassert(ASSOCIATED(start_elem))
276  cpassert(ASSOCIATED(tmc_env))
277  cpassert(ASSOCIATED(tmc_env%m_env))
278 
279  ! start the timing
280  CALL timeset(routinen, handle)
281 
282  ! allocate everything
283  CALL allocate_new_global_tree_node(next_el=tmc_env%m_env%gt_act, &
284  nr_temp=tmc_env%params%nr_temp)
285 
286  ! use initial/default values
287  CALL tmc_env%rng_stream%get( &
288  bg=tmc_env%m_env%gt_act%rng_seed(:, :, 1), &
289  cg=tmc_env%m_env%gt_act%rng_seed(:, :, 2), &
290  ig=tmc_env%m_env%gt_act%rng_seed(:, :, 3))
291 
292  global_tree => tmc_env%m_env%gt_act
293  tmc_env%m_env%gt_head => tmc_env%m_env%gt_act
294 
295  ! set global random seed
296  CALL tmc_env%rng_stream%set(bg=global_tree%rng_seed(:, :, 1), &
297  cg=global_tree%rng_seed(:, :, 2), &
298  ig=global_tree%rng_seed(:, :, 3))
299  global_tree%rnd_nr = tmc_env%rng_stream%next()
300 
301  !-- SUBTREES: set initial values
302  DO i = 1, SIZE(global_tree%conf)
303  CALL allocate_new_sub_tree_node(tmc_env%params, next_el=global_tree%conf(i)%elem, &
304  nr_dim=SIZE(start_elem%pos))
305  global_tree%conf(i)%elem%move_type = 0
306  global_tree%conf(i)%elem%next_elem_nr => tmc_env%m_env%tree_node_count(i)
307  global_tree%conf(i)%elem%parent => null()
308  global_tree%conf(i)%elem%nr = global_tree%conf(i)%elem%next_elem_nr
309  global_tree%conf(i)%elem%sub_tree_nr = i
310  global_tree%conf(i)%elem%elem_stat = status_ok
311  global_tree%conf(i)%elem%pos = start_elem%pos
312  global_tree%conf(i)%elem%mol = start_elem%mol
313  global_tree%conf(i)%elem%e_pot_approx = start_elem%e_pot_approx
314  global_tree%conf(i)%elem%temp_created = i
315  global_tree%conf(i)%elem%stat = status_calculate_energy
316  !it is default already: global_tree%conf(i)%elem%box_scale(:) = 1.0_dp
317  IF (tmc_env%params%task_type .EQ. task_type_gaussian_adaptation) THEN
318  global_tree%conf(i)%elem%vel(:) = start_elem%vel(:)
319  global_tree%conf(i)%elem%frc(:) = start_elem%frc(:)
320  global_tree%conf(i)%elem%potential = start_elem%potential
321  global_tree%conf(i)%elem%ekin = start_elem%ekin
322  global_tree%conf(i)%elem%ekin_before_md = start_elem%ekin_before_md
323  END IF
324 
325  !-- different random seeds for every subtree
326  CALL tmc_env%rng_stream%reset_to_next_substream()
327  CALL tmc_env%rng_stream%get(bg=global_tree%conf(i)%elem%rng_seed(:, :, 1), &
328  cg=global_tree%conf(i)%elem%rng_seed(:, :, 2), &
329  ig=global_tree%conf(i)%elem%rng_seed(:, :, 3))
330 
331  !-- gaussian distributed velocities
332  !-- calculating the kinetic energy of the initial configuration velocity
333  IF (tmc_env%params%task_type .EQ. task_type_mc) THEN
334  IF (tmc_env%params%move_types%mv_weight(mv_type_md) .GT. 0.0_dp) THEN
335  CALL init_vel(vel=global_tree%conf(i)%elem%vel, atoms=tmc_env%params%atoms, &
336  temerature=tmc_env%params%Temp(i), &
337  rng_stream=tmc_env%rng_stream, &
338  rnd_seed=global_tree%conf(i)%elem%rng_seed)
339  global_tree%conf(i)%elem%ekin = calc_e_kin(vel=global_tree%conf(i)%elem%vel, &
340  atoms=tmc_env%params%atoms)
341  END IF
342  END IF
343 
344  !-- set tree pointer
345  !-- set pointer of first global tree element
346  tmc_env%m_env%st_heads(i)%elem => global_tree%conf(i)%elem
347  tmc_env%m_env%st_clean_ends(i)%elem => global_tree%conf(i)%elem
348  !-- set initial pointer of result lists
349  tmc_env%m_env%result_list(i)%elem => global_tree%conf(i)%elem
350  END DO
351  tmc_env%m_env%tree_node_count(:) = 0 ! initializing the tree node numbering
352 
353  !-- initial global tree element
354  tmc_env%m_env%gt_head => global_tree
355  tmc_env%m_env%gt_clean_end => global_tree
356  global_tree%nr = 0
357  global_tree%swaped = .false.
358  global_tree%mv_conf = 1
359  global_tree%mv_next_conf = modulo(global_tree%mv_conf, SIZE(global_tree%conf)) + 1
360  global_tree%conf_n_acc = .true.
361 
362  global_tree%stat = status_created
363  global_tree%prob_acc = 1.0_dp
364 
365  ! simulated annealing start temperature
366  global_tree%Temp = tmc_env%params%Temp(1)
367  IF (tmc_env%params%nr_temp .NE. 1 .AND. tmc_env%m_env%temp_decrease .NE. 1.0_dp) &
368  CALL cp_abort(__location__, &
369  "there is no parallel tempering implementation for simulated annealing implemented "// &
370  "(just one Temp per global tree element.")
371 
372  !-- IF program is restarted, read restart file
373  IF (tmc_env%m_env%restart_in_file_name .NE. "") THEN
374  CALL read_restart_file(tmc_env=tmc_env, job_counts=job_counts, &
375  timings=worker_timings, &
376  file_name=tmc_env%m_env%restart_in_file_name)
377 
378  tmc_env%m_env%tree_node_count(0) = global_tree%nr
379 
380  DO i = 1, SIZE(tmc_env%m_env%result_list(:))
381  tmc_env%m_env%tree_node_count(i) = tmc_env%m_env%result_list(i)%elem%nr
382  global_tree%conf(i)%elem%stat = status_accepted
383  END DO
384  global_tree%prob_acc = 1.0_dp ! accepted (re)start configuration
385  WRITE (tmc_env%m_env%io_unit, *) "TMC| restarting at Markov Chain element(s): ", &
386  tmc_env%m_env%result_count
387  !TODO enable calculation of the approx energy for case of fitting potential
388  ! and changing the potential in between
389  ! BUT check, there is no double counting (of the last/restarted elem) in the trajectory
390  !IF(tmc_env%params%NMC_inp_file.NE."") &
391  ! global_tree%conf(1)%elem%stat = status_calc_approx_ener
392  global_tree%stat = status_accepted_result
393  ELSE IF (tmc_env%params%NMC_inp_file .NE. "") THEN
394  global_tree%conf(1)%elem%stat = status_calc_approx_ener
395  ELSE
396  global_tree%conf(1)%elem%stat = status_created
397  END IF
398 
399  !-- set reference of global tree node
400  CALL add_to_references(gt_elem=global_tree)
401 
402  !-- draw the first global tree node
403  IF (tmc_env%params%DRAW_TREE) THEN
404  CALL create_global_tree_dot(new_element=global_tree, &
405  tmc_params=tmc_env%params)
406  CALL create_global_tree_dot_color(gt_tree_element=global_tree, &
407  tmc_params=tmc_env%params)
408  END IF
409 
410  ! end the timing
411  CALL timestop(handle)
412  END SUBROUTINE init_tree_mod
413 
414 ! **************************************************************************************************
415 !> \brief distributes the initial energy to all subtree (if no restart) and
416 !> call analysis for this element (write trajectory...)
417 !> \param gt_tree_ptr global tree head (initial configuration)
418 !> \param tmc_env master environment for restart
419 !> (if restart the subtree heads are not equal), result counts and lists
420 !> \author Mandes 12.2012
421 ! **************************************************************************************************
422  SUBROUTINE finalize_init(gt_tree_ptr, tmc_env)
423  TYPE(global_tree_type), POINTER :: gt_tree_ptr
424  TYPE(tmc_env_type), POINTER :: tmc_env
425 
426  CHARACTER(LEN=*), PARAMETER :: routinen = 'finalize_init'
427 
428  INTEGER :: handle, i
429 
430  cpassert(ASSOCIATED(gt_tree_ptr))
431  cpassert(.NOT. ASSOCIATED(gt_tree_ptr%parent))
432  cpassert(ASSOCIATED(tmc_env))
433  cpassert(ASSOCIATED(tmc_env%m_env))
434  cpassert(ASSOCIATED(tmc_env%params))
435 
436  ! start the timing
437  CALL timeset(routinen, handle)
438 
439  gt_tree_ptr%stat = status_accepted_result
440  !-- distribute energy of first element to all subtrees
441  DO i = 1, SIZE(gt_tree_ptr%conf)
442  gt_tree_ptr%conf(i)%elem%stat = status_accepted_result
443  IF (ASSOCIATED(gt_tree_ptr%conf(1)%elem%dipole)) &
444  gt_tree_ptr%conf(i)%elem%dipole = gt_tree_ptr%conf(1)%elem%dipole
445  IF (tmc_env%m_env%restart_in_file_name .EQ. "") &
446  gt_tree_ptr%conf(i)%elem%potential = gt_tree_ptr%conf(1)%elem%potential
447  END DO
448 
449  IF (tmc_env%m_env%restart_in_file_name .EQ. "") THEN
450  tmc_env%m_env%result_count(:) = tmc_env%m_env%result_count(:) + 1
451  tmc_env%m_env%result_list(:) = gt_tree_ptr%conf(:)
452  !-- write initial elements in result files
453  DO i = 1, SIZE(tmc_env%m_env%result_list)
454  CALL write_result_list_element(result_list=tmc_env%m_env%result_list, &
455  result_count=tmc_env%m_env%result_count, &
456  conf_updated=i, accepted=.true., &
457  tmc_params=tmc_env%params)
458  ! save for analysis
459  IF (tmc_env%tmc_comp_set%para_env_m_ana%num_pe .GT. 1) THEN
460  CALL add_to_list(elem=tmc_env%m_env%result_list(i)%elem, &
461  list=tmc_env%m_env%analysis_list, &
462  nr=tmc_env%m_env%result_count(i), &
463  temp_ind=i)
464  END IF
465  END DO
466  !CALL write_result_list_element(result_list=tmc_env%m_env%result_list, &
467  ! result_count=tmc_env%m_env%result_count,&
468  ! conf_updated=0, accepted=.TRUE., &
469  ! tmc_params=tmc_env%params)
470  END IF
471  ! end the timing
472  CALL timestop(handle)
473  END SUBROUTINE finalize_init
474 
475  !============================================================================
476  ! tree node creation
477  !============================================================================
478 ! **************************************************************************************************
479 !> \brief creates new global tree element and if needed new subtree element
480 !> \param tmc_env TMC environment with parameters and pointers to gt element
481 !> \param stat return status value
482 !> \param new_elem return gt element
483 !> \param reactivation_cc_count counting the reactivation of subtree elements
484 !> \author Mandes 12.2012
485 ! **************************************************************************************************
486  SUBROUTINE create_new_gt_tree_node(tmc_env, stat, new_elem, &
487  reactivation_cc_count)
488  TYPE(tmc_env_type), POINTER :: tmc_env
489  INTEGER, INTENT(OUT) :: stat
490  TYPE(global_tree_type), INTENT(OUT), POINTER :: new_elem
491  INTEGER :: reactivation_cc_count
492 
493  CHARACTER(LEN=*), PARAMETER :: routinen = 'create_new_gt_tree_node'
494 
495  INTEGER :: handle, swap_conf
496  LOGICAL :: keep_on, n_acc
497  REAL(kind=dp) :: prob, rnd, rnd2
498  TYPE(global_tree_type), POINTER :: tmp_elem
499  TYPE(tree_type), POINTER :: tree_elem
500 
501  NULLIFY (tmp_elem, tree_elem, new_elem)
502 
503  cpassert(ASSOCIATED(tmc_env))
504  cpassert(ASSOCIATED(tmc_env%params))
505  cpassert(ASSOCIATED(tmc_env%m_env))
506  cpassert(ASSOCIATED(tmc_env%m_env%gt_act))
507 
508  ! start the timing
509  CALL timeset(routinen, handle)
510 
511  stat = tmc_status_failed
512  !-- search most probable end in global tree for new element
513  tmp_elem => tmc_env%m_env%gt_act
514  n_acc = .true.
515 
516  !-- search most probable end to create new element
517  CALL most_prob_end(global_tree_elem=tmp_elem, prob=prob, n_acc=n_acc)
518 
519  keep_on = .true.
520  IF (ASSOCIATED(tmp_elem) .AND. (exp(prob) .LT. 1.0e-10)) THEN
521  new_elem => null()
522  stat = tmc_status_failed
523  keep_on = .false.
524  !-- if not found, do something else
525  !-- (posible if just one end for further calculations
526  ! and there a MD move is still calculated)
527  ELSE IF (.NOT. ASSOCIATED(tmp_elem)) THEN
528  new_elem => null()
529  stat = tmc_status_failed
530  keep_on = .false.
531  END IF
532 
533  IF (keep_on) THEN
534  ! if global tree element already exist use that one
535  ! (skip creating new element)
536  ! reactivation
537  IF ((n_acc .AND. ASSOCIATED(tmp_elem%acc)) .OR. &
538  ((.NOT. n_acc) .AND. ASSOCIATED(tmp_elem%nacc))) THEN
539 
540  !set pointer to the actual element
541  IF (n_acc) &
542  new_elem => tmp_elem%acc
543  IF (.NOT. n_acc) &
544  new_elem => tmp_elem%nacc
545 
546  ! check for existing subtree element
547  cpassert(ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem))
548  SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat)
549  CASE (status_cancel_nmc, status_cancel_ener, status_canceled_nmc, &
550  status_canceled_ener)
551  ! reactivating subtree element
552  ! (but global tree element already exist)
553  CALL add_to_references(gt_elem=new_elem)
554  reactivation_cc_count = reactivation_cc_count + 1
555  CASE DEFAULT
556  CALL cp_abort(__location__, &
557  "global tree node creation using existing sub tree element, "// &
558  "but is not a canceled one, gt elem "// &
559  cp_to_string(new_elem%nr)//" st elem "// &
560  cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%nr)// &
561  " with stat "// &
562  cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat))
563  END SELECT
564  ! change the status of the reactivated subtree element
565  ! move is only done by the master,
566  ! when standard MC moves with single potential are done
567  ! the Nested Monte Carlo routine needs to do the configuration
568  ! to have old configuration to see if change is accepted
569  SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%move_type)
570  CASE (mv_type_md)
571  new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_md
572  CASE (mv_type_nmc_moves)
573  IF (new_elem%conf(new_elem%mv_conf)%elem%stat .NE. status_canceled_nmc) &
574  CALL cp_warn(__location__, &
575  "reactivating tree element with wrong status"// &
576  cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat))
577  new_elem%conf(new_elem%mv_conf)%elem%stat = status_calculate_nmc_steps
578 
579  !IF(DEBUG.GE.1) WRITE(tmc_out_file_nr,*)"ATTENTION: reactivation of canceled subtree ", &
580  ! new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, "elem", new_elem%conf(new_elem%mv_conf)%elem%nr, &
581  ! " of existing gt elem ",new_elem%nr,", again calculate NMC steps"
582  CASE (mv_type_atom_trans, mv_type_mol_trans, mv_type_mol_rot, &
583  mv_type_proton_reorder)
584  CALL cp_abort(__location__, &
585  "reactivated st element has no NMC or MD move type, "// &
586  "but seems to be canceled. Move type"// &
587  cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%move_type))
588  CASE DEFAULT
589  cpabort("Unknown move type while reactivating subtree element.")
590  END SELECT
591  ELSE
592  !-- if end is found (NOT already existing element), create new elem at the end and if nessecarry new subtree element
593  ! set initial values
594  CALL allocate_new_global_tree_node(next_el=new_elem, &
595  nr_temp=tmc_env%params%nr_temp)
596  tmc_env%m_env%tree_node_count(0) = tmc_env%m_env%tree_node_count(0) + 1
597  new_elem%nr = tmc_env%m_env%tree_node_count(0)
598 
599  !-- set pointers to and from element one level up
600  !-- paste new gt tree node element at right end
601  IF (n_acc) THEN
602  IF (ASSOCIATED(tmp_elem%acc)) &
603  cpabort("creating new subtree element on an occupied acc branch")
604  tmp_elem%acc => new_elem
605  ELSE
606  IF (ASSOCIATED(tmp_elem%nacc)) &
607  cpabort("creating new subtree element on an occupied nacc branch")
608  tmp_elem%nacc => new_elem
609  END IF
610  new_elem%parent => tmp_elem
611 
612  !-- adopt acceptance flags of elements (old)
613  new_elem%conf_n_acc(:) = new_elem%parent%conf_n_acc
614  !-- set acceptance flag of modified configuration
615  ! depending on the direction of attaching new element
616  IF (.NOT. new_elem%parent%swaped) THEN
617  ! set the flag for the direction
618  ! (shows if the configuration is assumed to be acc or rej)
619  new_elem%conf_n_acc(new_elem%parent%conf( &
620  new_elem%parent%mv_conf)%elem%sub_tree_nr) = n_acc
621  ELSE
622  !-- in case of swapping the subtree element acceptance do not change
623  !-- in case of NOT accepted branch and swapping before,
624  !-- search last NOT swaped gt tree node to take configurations
625  IF (.NOT. n_acc) THEN
626  DO
627  IF (.NOT. ASSOCIATED(tmp_elem%parent)) EXIT
628  IF (ASSOCIATED(tmp_elem%parent%acc, tmp_elem)) THEN
629  tmp_elem => tmp_elem%parent
630  EXIT
631  END IF
632  tmp_elem => tmp_elem%parent
633  IF (.NOT. tmp_elem%swaped) EXIT
634  END DO
635  END IF
636  END IF
637 
638  !-- adapt "old" configurations
639  new_elem%conf(:) = tmp_elem%conf(:)
640 
641  !-- set rnd nr generator and set next conf to change
642  CALL tmc_env%rng_stream%set( &
643  bg=new_elem%parent%rng_seed(:, :, 1), &
644  cg=new_elem%parent%rng_seed(:, :, 2), &
645  ig=new_elem%parent%rng_seed(:, :, 3))
646  CALL tmc_env%rng_stream%reset_to_next_substream()
647  ! the random number for acceptance check
648  new_elem%rnd_nr = tmc_env%rng_stream%next()
649 
650  ! the next configuration index to move
651  !rnd = tmc_env%rng_stream%next()
652  !new_elem%mv_conf = 1+INT(size(new_elem%conf)*rnd)
653  ! one temperature after each other
654  new_elem%mv_conf = new_elem%parent%mv_next_conf
655  new_elem%mv_next_conf = modulo(new_elem%mv_conf, SIZE(new_elem%conf)) + 1
656 
657  ! simulated annealing temperature decrease
658  new_elem%Temp = tmp_elem%Temp
659  IF (n_acc) new_elem%Temp = tmp_elem%Temp*(1 - tmc_env%m_env%temp_decrease)
660 
661  !-- rnd for swap
662  rnd = tmc_env%rng_stream%next()
663  rnd2 = tmc_env%rng_stream%next()
664  CALL tmc_env%rng_stream%get(bg=new_elem%rng_seed(:, :, 1), &
665  cg=new_elem%rng_seed(:, :, 2), &
666  ig=new_elem%rng_seed(:, :, 3))
667 
668  ! swap moves are not part of the subtree structure,
669  ! because existing elements from DIFFERENT subtrees are swaped
670  ! -- do swap ?!
671  IF (tmc_env%params%move_types%mv_weight(mv_type_swap_conf) .GE. rnd) THEN
672  ! set the index for the swaping element
673  ! and the conf to move in next move
674  new_elem%mv_next_conf = new_elem%mv_conf
675  ! do swap with conf swap_conf and swap_conf+1
676  swap_conf = 1 + int((tmc_env%params%nr_temp - 1)*rnd2)
677  new_elem%mv_conf = swap_conf
678  !-- swaping pointers to subtree elements
679  ! exchange the pointer to the sub tree elements
680  tree_elem => new_elem%conf(new_elem%mv_conf)%elem
681  new_elem%conf(new_elem%mv_conf)%elem => &
682  new_elem%conf(new_elem%mv_conf + 1)%elem
683  new_elem%conf(new_elem%mv_conf + 1)%elem => tree_elem
684 
685  new_elem%stat = status_calculated
686  new_elem%swaped = .true.
687  new_elem%prob_acc = tmc_env%params%move_types%acc_prob( &
688  mv_type_swap_conf, new_elem%mv_conf)
689  CALL add_to_references(gt_elem=new_elem)
690  IF (tmc_env%params%DRAW_TREE) &
691  CALL create_global_tree_dot(new_element=new_elem, &
692  tmc_params=tmc_env%params)
693  ! nothing to do for the workers
694  stat = status_calculated
695  keep_on = .false.
696  ELSE
697 
698  !-- considered subtree node can already exist,
699  ! calculated somewhere else in the global tree
700  !-- so check if new sub tree node exists, if not, create it
701  !-- check if considered configuration is assumed to be
702  ! on accepted or rejected branch
703  IF (new_elem%conf_n_acc(new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr)) THEN
704  !-- check if child element in ACCEPTED direction already exist
705  IF (ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem%acc)) THEN
706  new_elem%conf(new_elem%mv_conf)%elem => &
707  new_elem%conf(new_elem%mv_conf)%elem%acc
708  stat = status_calculated
709  ELSE
710  !-- if not exist create new subtree element
711  CALL create_new_subtree_node(act_gt_el=new_elem, &
712  tmc_env=tmc_env)
713  IF (tmc_env%params%DRAW_TREE) &
714  CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, &
715  conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, &
716  tmc_params=tmc_env%params)
717  END IF
718  ELSE
719  !-- check if child element in REJECTED direction already exist
720  IF (ASSOCIATED(new_elem%conf(new_elem%mv_conf)%elem%nacc)) THEN
721  new_elem%conf(new_elem%mv_conf)%elem => &
722  new_elem%conf(new_elem%mv_conf)%elem%nacc
723  stat = status_calculated
724  ELSE
725  !-- if not exist create new subtree element
726  CALL create_new_subtree_node(act_gt_el=new_elem, &
727  tmc_env=tmc_env)
728  IF (tmc_env%params%DRAW_TREE) &
729  CALL create_dot(new_element=new_elem%conf(new_elem%mv_conf)%elem, &
730  conf=new_elem%conf(new_elem%mv_conf)%elem%sub_tree_nr, &
731  tmc_params=tmc_env%params)
732  END IF
733  END IF
734  ! set approximate probability of acceptance
735  ! (initialization with calculated values from
736  ! (#acc elem in traj)/(#elem in traj))
737  new_elem%prob_acc = tmc_env%params%move_types%acc_prob( &
738  new_elem%conf(new_elem%mv_conf)%elem%move_type, new_elem%mv_conf)
739  ! add refence and dot
740  CALL add_to_references(gt_elem=new_elem)
741  IF (tmc_env%params%DRAW_TREE) &
742  CALL create_global_tree_dot(new_element=new_elem, &
743  tmc_params=tmc_env%params)
744  END IF ! swap or no swap
745  END IF ! global tree node already exist. Hence the Subtree node also (it is speculative canceled)
746  END IF ! keep on (checking and creating)
747 
748  IF (keep_on) THEN ! status changes
749  IF (new_elem%stat .EQ. status_accepted_result .OR. &
750  new_elem%stat .EQ. status_accepted .OR. &
751  new_elem%stat .EQ. status_rejected .OR. &
752  new_elem%stat .EQ. status_rejected_result) &
753  cpabort("selected existing RESULT gt node")
754  !-- set status of global tree element for decision in master routine
755  SELECT CASE (new_elem%conf(new_elem%mv_conf)%elem%stat)
756  CASE (status_rejected_result, status_rejected, status_accepted, &
757  status_accepted_result, status_calculated)
758  ! energy is already calculated
759  new_elem%stat = status_calculated
760  stat = new_elem%conf(new_elem%mv_conf)%elem%stat
761  IF (tmc_env%params%DRAW_TREE) &
762  CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, &
763  tmc_params=tmc_env%params)
764  CASE (status_calc_approx_ener)
765  new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat
766  IF (stat .NE. status_calculated) THEN
767  stat = new_elem%conf(new_elem%mv_conf)%elem%stat
768  IF (tmc_env%params%DRAW_TREE) &
769  CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, &
770  tmc_params=tmc_env%params)
771  END IF
772  CASE (status_calculate_md, status_calculate_energy, &
773  status_calculate_nmc_steps, status_created)
774  ! if not already in progress, set status for new task message
775  new_elem%stat = new_elem%conf(new_elem%mv_conf)%elem%stat
776  IF (stat .NE. status_calculated) THEN
777  stat = new_elem%conf(new_elem%mv_conf)%elem%stat
778  IF (tmc_env%params%DRAW_TREE) &
779  CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, &
780  tmc_params=tmc_env%params)
781  END IF
782  CASE (status_cancel_ener, status_canceled_ener)
783  ! configuration is already created,
784  ! but energy has to be calculated (again)
785  new_elem%conf(new_elem%mv_conf)%elem%stat = status_created
786  new_elem%stat = status_created
787  ! creation complete, handle energy calculation at a different position
788  ! (for different worker group)
789  stat = status_calculated
790  IF (tmc_env%params%DRAW_TREE) &
791  CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, &
792  tmc_params=tmc_env%params)
793  CASE (status_cancel_nmc, status_canceled_nmc)
794  ! reactivation canceled element (but with new global tree element)
795  new_elem%conf(new_elem%mv_conf)%elem%stat = &
796  status_calculate_nmc_steps
797  new_elem%stat = status_calculate_nmc_steps
798  stat = new_elem%conf(new_elem%mv_conf)%elem%stat
799  reactivation_cc_count = reactivation_cc_count + 1
800  IF (tmc_env%params%DRAW_TREE) &
801  CALL create_dot_color(tree_element=new_elem%conf(new_elem%mv_conf)%elem, &
802  tmc_params=tmc_env%params)
803  CASE DEFAULT
804  CALL cp_abort(__location__, &
805  "unknown stat "// &
806  cp_to_string(new_elem%conf(new_elem%mv_conf)%elem%stat)// &
807  "of subtree element "// &
808  "for creating new gt element")
809  END SELECT
810 
811  ! set stat TMC_STATUS_WAIT_FOR_NEW_TASK if no new calculation necessary
812  ! (energy calculation nodes searched by different routine)
813  IF (stat .EQ. tmc_status_failed) stat = tmc_status_wait_for_new_task
814  IF (stat .EQ. status_calculated) stat = tmc_status_wait_for_new_task
815  END IF
816  ! end the timing
817  CALL timestop(handle)
818 
819  END SUBROUTINE create_new_gt_tree_node
820 
821 ! **************************************************************************************************
822 !> \brief create new subtree element using pointer of global tree
823 !> \param act_gt_el global tree element
824 !> \param tmc_env ...
825 !> \author Mandes 12.2012
826 ! **************************************************************************************************
827  SUBROUTINE create_new_subtree_node(act_gt_el, tmc_env)
828  TYPE(global_tree_type), POINTER :: act_gt_el
829  TYPE(tmc_env_type), POINTER :: tmc_env
830 
831  CHARACTER(LEN=*), PARAMETER :: routinen = 'create_new_subtree_node'
832 
833  INTEGER :: conf, handle, itmp
834  LOGICAL :: mv_rejected, new_subbox
835  REAL(kind=dp) :: rnd
836  TYPE(tree_type), POINTER :: new_elem, parent_elem
837 
838  NULLIFY (new_elem, parent_elem)
839 
840  cpassert(ASSOCIATED(act_gt_el))
841  cpassert(ASSOCIATED(act_gt_el%conf(act_gt_el%mv_conf)%elem))
842  cpassert(ASSOCIATED(tmc_env))
843  cpassert(ASSOCIATED(tmc_env%params))
844 
845  ! start the timing
846  CALL timeset(routinen, handle)
847 
848  conf = act_gt_el%mv_conf
849  CALL allocate_new_sub_tree_node(tmc_params=tmc_env%params, &
850  next_el=new_elem, nr_dim=SIZE(act_gt_el%parent%conf(conf)%elem%pos))
851 
852  !-- node one level up
853  parent_elem => act_gt_el%conf(conf)%elem
854  new_elem%parent => parent_elem
855 
856  !-- set initial values
857  parent_elem%next_elem_nr = parent_elem%next_elem_nr + 1
858  new_elem%nr = parent_elem%next_elem_nr
859  new_elem%rng_seed = parent_elem%rng_seed
860 
861  !-- change to real parent element
862  IF (act_gt_el%conf_n_acc(act_gt_el%conf(act_gt_el%mv_conf)%elem%sub_tree_nr)) THEN
863  parent_elem%acc => new_elem
864  ELSE
865  parent_elem%nacc => new_elem
866  END IF
867 
868  !-- real parent node (taking the configuration from)
869  ! search parent
870  parent_elem => search_parent_element(current=new_elem)
871  new_elem%pos(:) = parent_elem%pos(:)
872  new_elem%mol(:) = parent_elem%mol(:)
873  new_elem%vel(:) = parent_elem%vel(:)
874  new_elem%ekin = parent_elem%ekin
875  new_elem%e_pot_approx = parent_elem%e_pot_approx
876  new_elem%next_elem_nr => parent_elem%next_elem_nr
877  new_elem%sub_tree_nr = parent_elem%sub_tree_nr
878  new_elem%box_scale = parent_elem%box_scale
879  IF (tmc_env%params%task_type .EQ. task_type_gaussian_adaptation) THEN
880  new_elem%frc(:) = parent_elem%frc(:)
881  new_elem%potential = parent_elem%potential
882  new_elem%ekin_before_md = parent_elem%ekin_before_md
883  ELSE
884  new_elem%potential = 97589.0_dp
885  END IF
886 
887  ! set new substream of random number generator
888  CALL tmc_env%rng_stream%set( &
889  bg=new_elem%rng_seed(:, :, 1), &
890  cg=new_elem%rng_seed(:, :, 2), &
891  ig=new_elem%rng_seed(:, :, 3))
892  CALL tmc_env%rng_stream%reset_to_next_substream()
893 
894  ! set the temperature for the NMC moves
895  rnd = tmc_env%rng_stream%next()
896  IF (tmc_env%params%NMC_inp_file .NE. "") THEN
897  new_elem%temp_created = int(tmc_env%params%nr_temp*rnd) + 1
898  ELSE
899  new_elem%temp_created = act_gt_el%mv_conf
900  END IF
901 
902  ! rnd nr for selecting move
903  rnd = tmc_env%rng_stream%next()
904  !-- set move type
905  new_elem%move_type = select_random_move_type( &
906  move_types=tmc_env%params%move_types, &
907  rnd=rnd)
908  CALL tmc_env%rng_stream%get( &
909  bg=new_elem%rng_seed(:, :, 1), &
910  cg=new_elem%rng_seed(:, :, 2), &
911  ig=new_elem%rng_seed(:, :, 3))
912 
913  ! move is only done by the master,
914  ! when standard MC moves with single potential are done
915  ! the Nested Monte Carlo routine needs the old configuration
916  ! to see if change is accepted
917  SELECT CASE (new_elem%move_type)
918  CASE (mv_type_md)
919  ! velocity change have to be done on workers,
920  ! because of velocity change for NMC acceptance check
921  new_elem%stat = status_calculate_md
922  ! set the temperature for creating MD
923  new_elem%temp_created = act_gt_el%mv_conf
924  !-- set the subbox (elements in subbox)
925  CALL elements_in_new_subbox(tmc_params=tmc_env%params, &
926  rng_stream=tmc_env%rng_stream, elem=new_elem, &
927  nr_of_sub_box_elements=itmp)
928  ! the move is performed on a worker group
929  CASE (mv_type_nmc_moves)
930  new_elem%stat = status_calculate_nmc_steps
931  !-- set the subbox (elements in subbox)
932  CALL elements_in_new_subbox(tmc_params=tmc_env%params, &
933  rng_stream=tmc_env%rng_stream, elem=new_elem, &
934  nr_of_sub_box_elements=itmp)
935  ! the move is performed on a worker group
936  ! the following moves new no force_env and can be performed on the master directly
937  CASE (mv_type_atom_trans, mv_type_atom_swap, mv_type_mol_trans, &
938  mv_type_mol_rot, mv_type_proton_reorder, &
939  mv_type_volume_move)
940  new_subbox = .true.
941  ! volume move on whole cell
942  IF (new_elem%move_type .EQ. mv_type_volume_move) THEN
943  new_subbox = .false.
944  END IF
945  CALL change_pos(tmc_params=tmc_env%params, &
946  move_types=tmc_env%params%move_types, &
947  rng_stream=tmc_env%rng_stream, elem=new_elem, &
948  mv_conf=conf, new_subbox=new_subbox, &
949  move_rejected=mv_rejected)
950  IF (mv_rejected) THEN
951  new_elem%potential = huge(new_elem%potential)
952  new_elem%e_pot_approx = huge(new_elem%e_pot_approx)
953  new_elem%stat = status_calculated
954  ELSE
955  new_elem%stat = status_created
956  IF (tmc_env%params%NMC_inp_file .NE. "") &
957  new_elem%stat = status_calc_approx_ener
958  END IF
959  CASE (mv_type_gausian_adapt)
960  ! still could be implemented
961  CASE DEFAULT
962  CALL cp_abort(__location__, &
963  "unknown move type ("//cp_to_string(new_elem%move_type)// &
964  "), while creating subtree element.")
965  END SELECT
966  act_gt_el%conf(act_gt_el%mv_conf)%elem => new_elem
967 
968  ! end the timing
969  CALL timestop(handle)
970  cpassert(ASSOCIATED(act_gt_el%conf(act_gt_el%mv_conf)%elem))
971  END SUBROUTINE create_new_subtree_node
972 
973  !============================================================================
974  ! tree node deallocation
975  !============================================================================
976 ! **************************************************************************************************
977 !> \brief prepares for deallocation of global tree element
978 !> (checks status and set pointers of neighboring elements)
979 !> \param gt_ptr the global tree element
980 !> \param draw if present, changes the coleor in the dot file
981 !> \param tmc_env tmc environment
982 !> \author Mandes 12.2012
983 ! **************************************************************************************************
984  SUBROUTINE remove_gt_elem(gt_ptr, draw, tmc_env)
985  TYPE(global_tree_type), POINTER :: gt_ptr
986  LOGICAL, OPTIONAL :: draw
987  TYPE(tmc_env_type), POINTER :: tmc_env
988 
989  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_gt_elem'
990 
991  INTEGER :: handle
992 
993  cpassert(ASSOCIATED(gt_ptr))
994  cpassert(ASSOCIATED(tmc_env))
995 
996  ! start the timing
997  CALL timeset(routinen, handle)
998 
999  CALL remove_gt_references(gt_ptr=gt_ptr, tmc_env=tmc_env)
1000 
1001  ! set status and draw in tree
1002  IF ((gt_ptr%stat .EQ. status_accepted_result) .OR. (gt_ptr%stat .EQ. status_rejected_result)) THEN
1003  gt_ptr%stat = status_deleted_result
1004  ELSE
1005  gt_ptr%stat = status_deleted
1006  END IF
1007  IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) &
1008  CALL create_global_tree_dot_color(gt_tree_element=gt_ptr, tmc_params=tmc_env%params)
1009 
1010  !remove pointer from tree parent
1011  IF (ASSOCIATED(gt_ptr%parent)) THEN
1012  IF (ASSOCIATED(gt_ptr%parent%acc, gt_ptr)) THEN
1013  gt_ptr%parent%acc => null()
1014  END IF
1015  IF (ASSOCIATED(gt_ptr%parent%nacc, gt_ptr)) THEN
1016  gt_ptr%parent%nacc => null()
1017  END IF
1018  END IF
1019 
1020  !remove pointer from tree childs
1021  IF (ASSOCIATED(gt_ptr%acc)) THEN
1022  gt_ptr%acc%parent => null()
1023  END IF
1024 
1025  IF (ASSOCIATED(gt_ptr%nacc)) THEN
1026  gt_ptr%nacc%parent => null()
1027  END IF
1028 
1029  CALL deallocate_global_tree_node(gt_elem=gt_ptr)
1030  ! end the timing
1031  CALL timestop(handle)
1032 
1033  cpassert(.NOT. ASSOCIATED(gt_ptr))
1034  END SUBROUTINE remove_gt_elem
1035 
1036 ! **************************************************************************************************
1037 !> \brief prepares for deallocation of sub tree element
1038 !> (checks status and set pointers of neighboring elements)
1039 !> \param ptr the sub tree element
1040 !> \param draw if present, changes the coleor in the dot file
1041 !> \param tmc_env tmc environment
1042 !> \author Mandes 12.2012
1043 ! **************************************************************************************************
1044  SUBROUTINE remove_st_elem(ptr, draw, tmc_env)
1045  TYPE(tree_type), POINTER :: ptr
1046  LOGICAL, OPTIONAL :: draw
1047  TYPE(tmc_env_type), POINTER :: tmc_env
1048 
1049  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_st_elem'
1050 
1051  INTEGER :: handle
1052  LOGICAL :: ready
1053 
1054  ready = .true.
1055  cpassert(ASSOCIATED(ptr))
1056  cpassert(ASSOCIATED(tmc_env))
1057 
1058  ! start the timing
1059  CALL timeset(routinen, handle)
1060 
1061  ! if there is still e reference to a global tree pointer, do not deallocate element
1062  IF (ASSOCIATED(ptr%gt_nodes_references)) THEN
1063  IF (ASSOCIATED(ptr%parent)) &
1064  CALL cp_warn(__location__, &
1065  "try to deallocate subtree element"// &
1066  cp_to_string(ptr%sub_tree_nr)//cp_to_string(ptr%nr)// &
1067  " still with global tree element references e.g."// &
1068  cp_to_string(ptr%gt_nodes_references%gt_elem%nr))
1069  cpassert(ASSOCIATED(ptr%gt_nodes_references%gt_elem))
1070  ELSE
1071  SELECT CASE (ptr%stat)
1072  ! if element is still in progress, do not delete, wait for responding
1073  CASE (status_calculate_energy, &
1074  status_calculate_nmc_steps, status_calculate_md)
1075  ! in case of speculative canceling: should be already canceled
1076  ! try to deallocate subtree element (still in progress)
1077  cpassert(tmc_env%params%SPECULATIVE_CANCELING)
1078  CASE (status_cancel_nmc, status_cancel_ener)
1079  ! do not return in case of finalizing (do not wait for canceling receipt)
1080  IF (PRESENT(draw)) ready = .false.
1081  CASE DEFAULT
1082  END SELECT
1083 
1084  ! check if real top to bottom or bottom to top deallocation (no middle element deallocation)
1085  IF (ASSOCIATED(ptr%parent) .AND. &
1086  (ASSOCIATED(ptr%acc) .OR. ASSOCIATED(ptr%nacc))) THEN
1087  cpabort("")
1088  END IF
1089 
1090  IF (ready) THEN
1091  ! set status and draw in tree
1092  IF ((ptr%stat .EQ. status_accepted_result) .OR. &
1093  (ptr%stat .EQ. status_rejected_result)) THEN
1094  ptr%stat = status_deleted_result
1095  ELSE
1096  ptr%stat = status_deleted
1097  END IF
1098  IF (tmc_env%params%DRAW_TREE .AND. PRESENT(draw)) &
1099  CALL create_dot_color(tree_element=ptr, tmc_params=tmc_env%params)
1100 
1101  !remove pointer from tree parent
1102  IF (ASSOCIATED(ptr%parent)) THEN
1103  IF (ASSOCIATED(ptr%parent%acc, ptr)) ptr%parent%acc => null()
1104  IF (ASSOCIATED(ptr%parent%nacc, ptr)) ptr%parent%nacc => null()
1105  END IF
1106 
1107  !remove pointer from tree childs
1108  IF (ASSOCIATED(ptr%acc)) ptr%acc%parent => null()
1109  IF (ASSOCIATED(ptr%nacc)) ptr%nacc%parent => null()
1110 
1111  ! deallocate
1112  CALL deallocate_sub_tree_node(tree_elem=ptr)
1113  END IF
1114  END IF
1115  ! end the timing
1116  CALL timestop(handle)
1117  END SUBROUTINE remove_st_elem
1118 
1119 ! **************************************************************************************************
1120 !> \brief deletes the no more used global tree nodes beside the result nodes
1121 !> from begin_ptr to end_ptr
1122 !> \param begin_ptr start of the tree region to be cleaned
1123 !> \param end_ptr end of the tree region to be cleaned
1124 !> \param removed retun value if brance is clean
1125 !> \param tmc_env tmc environment
1126 !> \author Mandes 12.2012
1127 ! **************************************************************************************************
1128  RECURSIVE SUBROUTINE remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env)
1129  TYPE(global_tree_type), POINTER :: begin_ptr, end_ptr
1130  LOGICAL :: removed
1131  TYPE(tmc_env_type), POINTER :: tmc_env
1132 
1133  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_unused_g_tree'
1134 
1135  INTEGER :: handle
1136  LOGICAL :: acc_removed, nacc_removed
1137  TYPE(global_tree_type), POINTER :: acc_ptr, nacc_ptr, tmp_ptr
1138 
1139  NULLIFY (acc_ptr, nacc_ptr, tmp_ptr)
1140 
1141  cpassert(ASSOCIATED(begin_ptr))
1142  cpassert(ASSOCIATED(end_ptr))
1143  cpassert(ASSOCIATED(tmc_env))
1144 
1145  ! start the timing
1146  CALL timeset(routinen, handle)
1147 
1148  removed = .false.
1149  acc_removed = .false.
1150  nacc_removed = .false.
1151 
1152  IF (.NOT. ASSOCIATED(begin_ptr, end_ptr)) THEN
1153  !-- go until the ends ot he tree, to deallocate revese
1154  !-- check if child nodes exist and possibly deallocate child node
1155  IF (ASSOCIATED(begin_ptr%acc)) THEN
1156  acc_ptr => begin_ptr%acc
1157  CALL remove_unused_g_tree(acc_ptr, end_ptr, acc_removed, tmc_env)
1158  ELSE
1159  acc_removed = .true.
1160  END IF
1161  IF (ASSOCIATED(begin_ptr%nacc)) THEN
1162  nacc_ptr => begin_ptr%nacc
1163  CALL remove_unused_g_tree(nacc_ptr, end_ptr, nacc_removed, tmc_env)
1164  ELSE
1165  nacc_removed = .true.
1166  END IF
1167 
1168  !-- deallocate node if no child node exist
1169  IF (acc_removed .AND. nacc_removed) THEN
1170  SELECT CASE (begin_ptr%stat)
1171  CASE (status_accepted, status_rejected, status_calculated, status_created, &
1172  status_calculate_energy, status_calculate_md, status_calculate_nmc_steps, status_calc_approx_ener, &
1173  status_cancel_nmc, status_cancel_ener, status_canceled_nmc, status_canceled_ener)
1174  ! delete references, cancel elements calculation and deallocate global tree element
1175  tmp_ptr => begin_ptr
1176 
1177  CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.true., tmc_env=tmc_env)
1178  IF (.NOT. ASSOCIATED(tmp_ptr)) removed = .true.
1179  CASE (status_accepted_result, status_rejected_result)
1180  CASE DEFAULT
1181  CALL cp_abort(__location__, &
1182  "try to dealloc unused tree element with status of begin element" &
1183  //cp_to_string(begin_ptr%stat))
1184  END SELECT
1185  END IF
1186  END IF
1187  ! end the timing
1188  CALL timestop(handle)
1189  cpassert(ASSOCIATED(end_ptr))
1190  END SUBROUTINE remove_unused_g_tree
1191 
1192 ! **************************************************************************************************
1193 !> \brief deletes the no more used sub tree nodes beside the result nodes
1194 !> from begin_ptr to end_ptr
1195 !> \param begin_ptr start of the tree region to be cleaned
1196 !> \param end_ptr end of the tree region to be cleaned
1197 !> \param working_elem_list ...
1198 !> \param removed retun value if brance is clean
1199 !> \param tmc_env tmc environment
1200 !> \author Mandes 12.2012
1201 ! **************************************************************************************************
1202  RECURSIVE SUBROUTINE remove_unused_s_tree(begin_ptr, end_ptr, working_elem_list, &
1203  removed, tmc_env)
1204  TYPE(tree_type), POINTER :: begin_ptr
1205  TYPE(tree_type), INTENT(IN), POINTER :: end_ptr
1206  TYPE(elem_array_type), DIMENSION(:), POINTER :: working_elem_list
1207  LOGICAL :: removed
1208  TYPE(tmc_env_type), POINTER :: tmc_env
1209 
1210  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_unused_s_tree'
1211 
1212  INTEGER :: handle, i
1213  LOGICAL :: acc_removed, nacc_removed, remove_this
1214  TYPE(tree_type), POINTER :: acc_ptr, nacc_ptr, tmp_ptr
1215 
1216  NULLIFY (acc_ptr, nacc_ptr, tmp_ptr)
1217  remove_this = .false.
1218  removed = .false.
1219  acc_removed = .false.
1220  nacc_removed = .false.
1221 
1222  ! start the timing
1223  CALL timeset(routinen, handle)
1224 
1225  cpassert(ASSOCIATED(begin_ptr))
1226  cpassert(ASSOCIATED(end_ptr))
1227  cpassert(ASSOCIATED(working_elem_list))
1228  cpassert(ASSOCIATED(tmc_env))
1229 
1230  !-- if element is last checked in trajectory, go back
1231  IF (.NOT. ASSOCIATED(begin_ptr, end_ptr)) THEN
1232  !-- go until the ends on the tree, to deallocate revesely
1233  !-- check if child nodes exist and possibly deallocate child node
1234  IF (ASSOCIATED(begin_ptr%acc)) THEN
1235  acc_ptr => begin_ptr%acc
1236  CALL remove_unused_s_tree(acc_ptr, end_ptr, working_elem_list, &
1237  acc_removed, tmc_env)
1238  ELSE
1239  acc_removed = .true.
1240  END IF
1241  IF (ASSOCIATED(begin_ptr%nacc)) THEN
1242  nacc_ptr => begin_ptr%nacc
1243  CALL remove_unused_s_tree(nacc_ptr, end_ptr, working_elem_list, &
1244  nacc_removed, tmc_env)
1245  ELSE
1246  nacc_removed = .true.
1247  END IF
1248 
1249  !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"try to dealloc: node", begin_ptr%nr," sides are removed: ", &
1250  ! acc_removed, nacc_removed
1251 
1252  !-- deallocate node if NO child node exist
1253  ! unused trajectory is deleted when cleaned part is updated
1254  IF (acc_removed .AND. nacc_removed) THEN
1255  SELECT CASE (begin_ptr%stat)
1256  CASE (status_canceled_nmc, status_canceled_ener)
1257  remove_this = .true.
1258  CASE (status_accepted, status_rejected, status_calculated, &
1259  status_accepted_result, status_rejected_result, status_created)
1260  remove_this = .true.
1261  ! not to cancel, because still in progress
1262  CASE (status_calculate_energy, status_calculate_nmc_steps, &
1263  status_calculate_md, status_cancel_nmc, status_cancel_ener, &
1264  status_calc_approx_ener)
1265  remove_this = .false.
1266  ! -- delete when calculation is finished or aborted
1267  ! removed should still be .FALSE.
1268  CASE DEFAULT
1269  CALL cp_abort(__location__, &
1270  "unknown status "//cp_to_string(begin_ptr%stat)// &
1271  "of sub tree element "// &
1272  cp_to_string(begin_ptr%sub_tree_nr)//" "// &
1273  cp_to_string(begin_ptr%nr))
1274  END SELECT
1275 
1276  ! delete element
1277  IF (remove_this) THEN
1278  !-- mark as deleted and draw it in tree
1279  IF (.NOT. ASSOCIATED(begin_ptr%parent)) &
1280  CALL cp_abort(__location__, &
1281  "try to remove unused subtree element "// &
1282  cp_to_string(begin_ptr%sub_tree_nr)//" "// &
1283  cp_to_string(begin_ptr%nr)// &
1284  " but parent does not exist")
1285  tmp_ptr => begin_ptr
1286  ! check if a working group is still working on this element
1287  removed = .true.
1288  DO i = 1, SIZE(working_elem_list(:))
1289  IF (ASSOCIATED(working_elem_list(i)%elem)) THEN
1290  IF (ASSOCIATED(working_elem_list(i)%elem, tmp_ptr)) &
1291  removed = .false.
1292  END IF
1293  END DO
1294  IF (removed) THEN
1295  !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"deallocation of node ", begin_ptr%nr, "with status ", begin_ptr%stat
1296  ! if all groups are finished with this element, we can deallocate
1297  CALL remove_st_elem(ptr=tmp_ptr, draw=.true., tmc_env=tmc_env)
1298  IF (.NOT. ASSOCIATED(tmp_ptr)) THEN
1299  removed = .true.
1300  ELSE
1301  removed = .false.
1302  END IF
1303  END IF
1304  END IF
1305  END IF
1306  END IF
1307  ! end the timing
1308  CALL timestop(handle)
1309  END SUBROUTINE remove_unused_s_tree
1310 
1311 ! **************************************************************************************************
1312 !> \brief deallocates all result nodes (remaining Markov Chain)
1313 !> from the tree root to the end of clean tree of the global tree
1314 !> \param end_of_clean_tree ...
1315 !> \param actual_ptr ...
1316 !> \param tmc_env TMC environment for deallocation
1317 !> \author Mandes 12.2012
1318 ! **************************************************************************************************
1319  RECURSIVE SUBROUTINE remove_result_g_tree(end_of_clean_tree, actual_ptr, &
1320  tmc_env)
1321  TYPE(global_tree_type), POINTER :: end_of_clean_tree, actual_ptr
1322  TYPE(tmc_env_type), POINTER :: tmc_env
1323 
1324  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_result_g_tree'
1325 
1326  INTEGER :: handle
1327  TYPE(global_tree_type), POINTER :: tmp_ptr
1328 
1329  cpassert(ASSOCIATED(end_of_clean_tree))
1330  cpassert(ASSOCIATED(actual_ptr))
1331 
1332  ! start the timing
1333  CALL timeset(routinen, handle)
1334 
1335  !-- going up to the head ot the subtree
1336  IF (ASSOCIATED(actual_ptr%parent)) &
1337  CALL remove_result_g_tree(end_of_clean_tree=end_of_clean_tree, &
1338  actual_ptr=actual_ptr%parent, &
1339  tmc_env=tmc_env)
1340  !-- new tree head has no parent
1341  IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN
1342  !-- deallocate node
1343  !IF(DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"dealloc gt result tree element: ",actual_ptr%nr
1344  tmp_ptr => actual_ptr
1345  CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.true., tmc_env=tmc_env)
1346  actual_ptr => tmp_ptr
1347  END IF
1348  ! end the timing
1349  CALL timestop(handle)
1350  END SUBROUTINE remove_result_g_tree
1351 
1352 ! **************************************************************************************************
1353 !> \brief deallocates all result nodes (remaining Markov Chain)
1354 !> from the tree root to the end of clean tree of one sub tree
1355 !> top to buttom deallocation
1356 !> \param end_of_clean_tree ...
1357 !> \param actual_ptr ...
1358 !> \param tmc_env TMC environment for deallocation
1359 !> \author Mandes 12.2012
1360 ! **************************************************************************************************
1361  RECURSIVE SUBROUTINE remove_result_s_tree(end_of_clean_tree, actual_ptr, &
1362  tmc_env)
1363  TYPE(tree_type), POINTER :: end_of_clean_tree, actual_ptr
1364  TYPE(tmc_env_type), POINTER :: tmc_env
1365 
1366  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_result_s_tree'
1367 
1368  INTEGER :: handle
1369  TYPE(tree_type), POINTER :: tmp_ptr
1370 
1371  cpassert(ASSOCIATED(end_of_clean_tree))
1372  cpassert(ASSOCIATED(actual_ptr))
1373  cpassert(ASSOCIATED(tmc_env))
1374 
1375  ! start the timing
1376  CALL timeset(routinen, handle)
1377 
1378  !-- going up to the head ot the subtree
1379  IF (ASSOCIATED(actual_ptr%parent)) &
1380  CALL remove_result_s_tree(end_of_clean_tree, actual_ptr%parent, &
1381  tmc_env)
1382 
1383  !-- new tree head has no parent
1384  IF (.NOT. ASSOCIATED(actual_ptr, end_of_clean_tree)) THEN
1385  ! in trajectory just one direction should exist
1386  IF (ASSOCIATED(actual_ptr%acc) .AND. ASSOCIATED(actual_ptr%nacc)) THEN
1387  cpabort("")
1388  END IF
1389  ! the parent should be deleted already, but global tree is allocated to the second last accepted, &
1390  ! hence there could be still a reference to an element...
1391  IF (.NOT. ASSOCIATED(actual_ptr%parent)) THEN
1392  !-- deallocate node
1393  tmp_ptr => actual_ptr
1394  CALL remove_st_elem(ptr=tmp_ptr, draw=.true., tmc_env=tmc_env)
1395  actual_ptr => tmp_ptr
1396  END IF
1397  END IF
1398  ! end the timing
1399  CALL timestop(handle)
1400  END SUBROUTINE remove_result_s_tree
1401 
1402 ! **************************************************************************************************
1403 !> \brief deallocates the no more used tree nodes beside the result nodes
1404 !> from begin_ptr to end_ptr
1405 !> in global and subtrees
1406 !> \param working_elem_list list of actual calculating elements for canceling
1407 !> \param tmc_env TMC environment
1408 !> \author Mandes 12.2012
1409 ! **************************************************************************************************
1410  SUBROUTINE remove_all_trees(working_elem_list, tmc_env)
1411  TYPE(elem_array_type), DIMENSION(:), POINTER :: working_elem_list
1412  TYPE(tmc_env_type), POINTER :: tmc_env
1413 
1414  CHARACTER(LEN=*), PARAMETER :: routinen = 'remove_all_trees'
1415 
1416  INTEGER :: handle, i, tree
1417  LOGICAL :: change_trajec, flag
1418  TYPE(global_tree_type), POINTER :: tmp_gt_ptr
1419  TYPE(tree_type), POINTER :: last_acc_st_elem, tmp_ptr
1420 
1421  NULLIFY (last_acc_st_elem, tmp_ptr, tmp_gt_ptr)
1422 
1423  cpassert(ASSOCIATED(working_elem_list))
1424  cpassert(ASSOCIATED(tmc_env))
1425  cpassert(ASSOCIATED(tmc_env%m_env))
1426  cpassert(ASSOCIATED(tmc_env%m_env%gt_act))
1427  cpassert(ASSOCIATED(tmc_env%m_env%gt_clean_end))
1428  cpassert(ASSOCIATED(tmc_env%m_env%result_list))
1429  cpassert(ASSOCIATED(tmc_env%m_env%st_clean_ends))
1430 
1431  flag = .false.
1432  change_trajec = .false.
1433 
1434  ! start the timing
1435  CALL timeset(routinen, handle)
1436 
1437  !-- deallocate unused pt tree
1438  CALL remove_unused_g_tree(begin_ptr=tmc_env%m_env%gt_clean_end, &
1439  end_ptr=tmc_env%m_env%gt_act, removed=flag, &
1440  tmc_env=tmc_env)
1441  tmp_gt_ptr => tmc_env%m_env%gt_clean_end
1442  CALL search_end_of_clean_g_tree(last_acc=tmc_env%m_env%gt_clean_end, &
1443  tree_ptr=tmp_gt_ptr)
1444  !-- deallocate unused pt trajectory tree elements
1445  IF (tmc_env%params%USE_REDUCED_TREE) THEN
1446  tmp_gt_ptr => tmc_env%m_env%gt_clean_end
1447  CALL remove_result_g_tree(end_of_clean_tree=tmc_env%m_env%gt_clean_end, &
1448  actual_ptr=tmp_gt_ptr, tmc_env=tmc_env)
1449 
1450  !check if something changed, if not no deallocation of result subtree necessary
1451  IF (.NOT. ASSOCIATED(tmc_env%m_env%gt_head, tmc_env%m_env%gt_clean_end)) &
1452  change_trajec = .true.
1453  tmc_env%m_env%gt_head => tmc_env%m_env%gt_clean_end
1454  cpassert(.NOT. ASSOCIATED(tmc_env%m_env%gt_head%parent))
1455  !IF (DEBUG.GE.20) WRITE(tmc_out_file_nr,*)"new head of pt tree is ",tmc_env%m_env%gt_head%nr
1456  END IF
1457 
1458  !-- deallocate the subtrees
1459  ! do for all temperatures respectively all subtrees
1460  DO tree = 1, tmc_env%params%nr_temp
1461  ! get last checked element in trajectory related to the subtree (resultlist order is NOT subtree order)
1462  conf_loop: DO i = 1, SIZE(tmc_env%m_env%result_list)
1463  last_acc_st_elem => tmc_env%m_env%result_list(i)%elem
1464  IF (last_acc_st_elem%sub_tree_nr .EQ. tree) &
1465  EXIT conf_loop
1466  END DO conf_loop
1467  cpassert(last_acc_st_elem%sub_tree_nr .EQ. tree)
1468  CALL remove_unused_s_tree(begin_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, &
1469  end_ptr=last_acc_st_elem, working_elem_list=working_elem_list, &
1470  removed=flag, tmc_env=tmc_env)
1471  CALL search_end_of_clean_tree(tree_ptr=tmc_env%m_env%st_clean_ends(tree)%elem, &
1472  last_acc=last_acc_st_elem)
1473  END DO
1474  !-- deallocate the trajectory subtree elements
1475  IF (tmc_env%params%USE_REDUCED_TREE .AND. change_trajec) THEN
1476  DO tree = 1, tmc_env%params%nr_temp
1477  tmp_ptr => tmc_env%m_env%st_clean_ends(tree)%elem
1478  cpassert(tmp_ptr%sub_tree_nr .EQ. tree)
1479  CALL remove_result_s_tree(end_of_clean_tree=tmc_env%m_env%st_clean_ends(tree)%elem, &
1480  actual_ptr=tmp_ptr, tmc_env=tmc_env)
1481  tmc_env%m_env%st_heads(tree)%elem => tmc_env%m_env%st_clean_ends(tree)%elem
1482  !IF(DEBUG.GE.20) &
1483  ! WRITE(tmc_out_file_nr,*)"new head of tree ",tree," is ",&
1484  ! tmc_env%m_env%st_heads(tree)%elem%nr
1485  END DO
1486  END IF
1487 
1488  ! end the timing
1489  CALL timestop(handle)
1490  cpassert(ASSOCIATED(tmc_env%m_env%gt_act))
1491  cpassert(ASSOCIATED(tmc_env%m_env%gt_clean_end))
1492  END SUBROUTINE remove_all_trees
1493 
1494 ! **************************************************************************************************
1495 !> \brief deallocates the whole global tree, to clean up
1496 !> \param begin_ptr pointer to global tree head
1497 !> \param removed flag, if the this element is removed
1498 !> \param tmc_env ...
1499 !> \author Mandes 01.2013
1500 ! **************************************************************************************************
1501  RECURSIVE SUBROUTINE dealloc_whole_g_tree(begin_ptr, removed, tmc_env)
1502  TYPE(global_tree_type), POINTER :: begin_ptr
1503  LOGICAL :: removed
1504  TYPE(tmc_env_type), POINTER :: tmc_env
1505 
1506  LOGICAL :: acc_removed, nacc_removed
1507  TYPE(global_tree_type), POINTER :: acc_ptr, nacc_ptr, tmp_ptr
1508 
1509  cpassert(ASSOCIATED(begin_ptr))
1510  cpassert(ASSOCIATED(tmc_env))
1511 
1512  IF (ASSOCIATED(begin_ptr%acc)) THEN
1513  acc_ptr => begin_ptr%acc
1514  CALL dealloc_whole_g_tree(acc_ptr, acc_removed, tmc_env)
1515  ELSE
1516  acc_removed = .true.
1517  END IF
1518  IF (ASSOCIATED(begin_ptr%nacc)) THEN
1519  nacc_ptr => begin_ptr%nacc
1520  CALL dealloc_whole_g_tree(nacc_ptr, nacc_removed, tmc_env)
1521  ELSE
1522  nacc_removed = .true.
1523  END IF
1524 
1525  !-- deallocate node if no child node exist
1526  IF (acc_removed .AND. nacc_removed) THEN
1527  CALL search_and_remove_reference_in_list(gt_ptr=begin_ptr, &
1528  elem=begin_ptr%conf(begin_ptr%mv_conf)%elem, tmc_env=tmc_env)
1529  tmp_ptr => begin_ptr
1530  CALL remove_gt_elem(gt_ptr=tmp_ptr, draw=.false., tmc_env=tmc_env)
1531  !CALL deallocate_global_tree_node(gt_elem=tmp_ptr)
1532  removed = .true.
1533  END IF
1534  END SUBROUTINE dealloc_whole_g_tree
1535 ! **************************************************************************************************
1536 !> \brief deallocates the whole sub tree, to clean up
1537 !> \param begin_ptr pointer to sub tree head
1538 !> \param removed flag, if the this element is removed
1539 !> \param tmc_params ...
1540 !> \author Mandes 01.2013
1541 ! **************************************************************************************************
1542  RECURSIVE SUBROUTINE dealloc_whole_subtree(begin_ptr, removed, tmc_params)
1543  TYPE(tree_type), POINTER :: begin_ptr
1544  LOGICAL :: removed
1545  TYPE(tmc_param_type), POINTER :: tmc_params
1546 
1547  LOGICAL :: acc_removed, nacc_removed
1548  TYPE(tree_type), POINTER :: acc_ptr, nacc_ptr, tmp_ptr
1549 
1550  cpassert(ASSOCIATED(begin_ptr))
1551  cpassert(ASSOCIATED(tmc_params))
1552 
1553  IF (ASSOCIATED(begin_ptr%acc)) THEN
1554  acc_ptr => begin_ptr%acc
1555  CALL dealloc_whole_subtree(acc_ptr, acc_removed, tmc_params)
1556  ELSE
1557  acc_removed = .true.
1558  END IF
1559  IF (ASSOCIATED(begin_ptr%nacc)) THEN
1560  nacc_ptr => begin_ptr%nacc
1561  CALL dealloc_whole_subtree(nacc_ptr, nacc_removed, tmc_params)
1562  ELSE
1563  nacc_removed = .true.
1564  END IF
1565 
1566  !-- deallocate node if no child node exist
1567  IF (acc_removed .AND. nacc_removed) THEN
1568  tmp_ptr => begin_ptr
1569  CALL deallocate_sub_tree_node(tree_elem=begin_ptr)
1570  removed = .true.
1571  END IF
1572  END SUBROUTINE dealloc_whole_subtree
1573 
1574  !============================================================================
1575  ! finalizing module (deallocating everything)
1576  !============================================================================
1577 ! **************************************************************************************************
1578 !> \brief deallocating every tree node of every trees (clean up)
1579 !> \param tmc_env TMC environment structure
1580 !> \author Mandes 01.2013
1581 ! **************************************************************************************************
1582  SUBROUTINE finalize_trees(tmc_env)
1583  TYPE(tmc_env_type), POINTER :: tmc_env
1584 
1585  INTEGER :: i
1586  LOGICAL :: flag
1587  TYPE(global_tree_type), POINTER :: global_tree
1588 
1589  cpassert(ASSOCIATED(tmc_env))
1590  cpassert(ASSOCIATED(tmc_env%m_env))
1591 
1592  global_tree => tmc_env%m_env%gt_act
1593  !-- deallocate pt tree
1594  ! start with searching the head
1595  DO WHILE (ASSOCIATED(global_tree%parent))
1596  global_tree => global_tree%parent
1597  END DO
1598  CALL dealloc_whole_g_tree(begin_ptr=global_tree, removed=flag, &
1599  tmc_env=tmc_env)
1600 
1601  !-- deallocate subtrees
1602  trees_loop: DO i = 1, SIZE(tmc_env%m_env%st_clean_ends(:))
1603  DO WHILE (ASSOCIATED(tmc_env%m_env%st_clean_ends(i)%elem%parent))
1604  tmc_env%m_env%st_clean_ends(i)%elem => &
1605  tmc_env%m_env%st_clean_ends(i)%elem%parent
1606  END DO
1607  CALL dealloc_whole_subtree(begin_ptr=tmc_env%m_env%st_clean_ends(i)%elem, &
1608  removed=flag, tmc_params=tmc_env%params)
1609  END DO trees_loop
1610  DEALLOCATE (tmc_env%params%atoms)
1611  END SUBROUTINE finalize_trees
1612 
1613 END MODULE tmc_tree_build
modulo
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Definition: grid_common.h:117
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
kinds
Defines the basic variable types.
Definition: kinds.F:23
kinds::dp
integer, parameter, public dp
Definition: kinds.F:34
list
An array-based list which grows on demand. When the internal array is full, a new array of twice the ...
Definition: list.F:24
timings
Timing routines for accounting.
Definition: timings.F:17
tmc_calculations
calculation section for TreeMonteCarlo
Definition: tmc_calculations.F:15
tmc_calculations::init_vel
subroutine, public init_vel(vel, atoms, temerature, rng_stream, rnd_seed)
routine sets initial velocity, using the Box-Muller Method for Normal (Gaussian) Deviates
Definition: tmc_calculations.F:348
tmc_calculations::calc_e_kin
real(kind=dp) function, public calc_e_kin(vel, atoms)
routine calculates the kinetic energy, using the velocities and atom mass, both in atomic units
Definition: tmc_calculations.F:385
tmc_dot_tree
module for printing tree structures in GraphViz dot files for visualizing the trees
Definition: tmc_dot_tree.F:19
tmc_dot_tree::create_dot
subroutine, public create_dot(new_element, conf, tmc_params)
interfaces the creating of a branch for subtree elements
Definition: tmc_dot_tree.F:277
tmc_dot_tree::create_global_tree_dot_color
subroutine, public create_global_tree_dot_color(gt_tree_element, tmc_params)
interfaces the change of color for global tree node on the basis of the element status
Definition: tmc_dot_tree.F:417
tmc_dot_tree::create_global_tree_dot
subroutine, public create_global_tree_dot(new_element, tmc_params)
creates new dot and arrow from element one level up (for subtree) additional handling of nodes with s...
Definition: tmc_dot_tree.F:299
tmc_dot_tree::create_dot_color
subroutine, public create_dot_color(tree_element, tmc_params)
interfaces the change of color for subtree elements on the basis of the element status
Definition: tmc_dot_tree.F:376
tmc_file_io
writing and printing the files, trajectory (pos, cell, dipoles) as well as restart files
Definition: tmc_file_io.F:20
tmc_file_io::write_result_list_element
subroutine, public write_result_list_element(result_list, result_count, conf_updated, accepted, tmc_params)
select the correct configuration to print out the (coordinates, forces, cell ...)
Definition: tmc_file_io.F:365
tmc_file_io::read_restart_file
subroutine, public read_restart_file(tmc_env, job_counts, timings, file_name)
reads the TMC restart file with all last configurations and counters etc.
Definition: tmc_file_io.F:277
tmc_move_handle
acceptance ratio handling of the different Monte Carlo Moves types For each move type and each temper...
Definition: tmc_move_handle.F:27
tmc_move_handle::select_random_move_type
integer function, public select_random_move_type(move_types, rnd)
selects a move type related to the weighings and the entered rnd nr
Definition: tmc_move_handle.F:869
tmc_move_types
tree nodes creation, searching, deallocation, references etc.
Definition: tmc_move_types.F:15
tmc_move_types::mv_type_mol_rot
integer, parameter, public mv_type_mol_rot
Definition: tmc_move_types.F:31
tmc_move_types::mv_type_volume_move
integer, parameter, public mv_type_volume_move
Definition: tmc_move_types.F:35
tmc_move_types::mv_type_proton_reorder
integer, parameter, public mv_type_proton_reorder
Definition: tmc_move_types.F:32
tmc_move_types::mv_type_swap_conf
integer, parameter, public mv_type_swap_conf
Definition: tmc_move_types.F:28
tmc_move_types::mv_type_md
integer, parameter, public mv_type_md
Definition: tmc_move_types.F:34
tmc_move_types::mv_type_mol_trans
integer, parameter, public mv_type_mol_trans
Definition: tmc_move_types.F:30
tmc_move_types::mv_type_atom_swap
integer, parameter, public mv_type_atom_swap
Definition: tmc_move_types.F:33
tmc_move_types::mv_type_gausian_adapt
integer, parameter, public mv_type_gausian_adapt
Definition: tmc_move_types.F:36
tmc_move_types::mv_type_atom_trans
integer, parameter, public mv_type_atom_trans
Definition: tmc_move_types.F:29
tmc_move_types::mv_type_nmc_moves
integer, parameter, public mv_type_nmc_moves
Definition: tmc_move_types.F:37
tmc_move_types::mv_type_none
integer, parameter, public mv_type_none
Definition: tmc_move_types.F:27
tmc_moves
different move types are applied
Definition: tmc_moves.F:15
tmc_moves::elements_in_new_subbox
subroutine, public elements_in_new_subbox(tmc_params, rng_stream, elem, nr_of_sub_box_elements)
set a new random sub box center and counte the number of atoms in it
Definition: tmc_moves.F:466
tmc_moves::change_pos
subroutine, public change_pos(tmc_params, move_types, rng_stream, elem, mv_conf, new_subbox, move_rejected)
applying the preselected move type
Definition: tmc_moves.F:70
tmc_stati
tree nodes creation, searching, deallocation, references etc.
Definition: tmc_stati.F:15
tmc_stati::tmc_status_failed
integer, parameter, public tmc_status_failed
Definition: tmc_stati.F:57
tmc_stati::task_type_gaussian_adaptation
integer, parameter, public task_type_gaussian_adaptation
Definition: tmc_stati.F:47
tmc_stati::tmc_status_wait_for_new_task
integer, parameter, public tmc_status_wait_for_new_task
Definition: tmc_stati.F:52
tmc_stati::task_type_mc
integer, parameter, public task_type_mc
Definition: tmc_stati.F:44
tmc_tree_build
tree nodes creation, deallocation, references etc.
Definition: tmc_tree_build.F:35
tmc_tree_build::init_tree_mod
subroutine, public init_tree_mod(start_elem, tmc_env, job_counts, worker_timings)
routine initiate the global and subtrees with the first elements
Definition: tmc_tree_build.F:263
tmc_tree_build::deallocate_sub_tree_node
subroutine, public deallocate_sub_tree_node(tree_elem)
deallocates an elements of the subtree element structure
Definition: tmc_tree_build.F:220
tmc_tree_build::create_new_gt_tree_node
subroutine, public create_new_gt_tree_node(tmc_env, stat, new_elem, reactivation_cc_count)
creates new global tree element and if needed new subtree element
Definition: tmc_tree_build.F:488
tmc_tree_build::finalize_init
subroutine, public finalize_init(gt_tree_ptr, tmc_env)
distributes the initial energy to all subtree (if no restart) and call analysis for this element (wri...
Definition: tmc_tree_build.F:423
tmc_tree_build::remove_unused_g_tree
recursive subroutine, public remove_unused_g_tree(begin_ptr, end_ptr, removed, tmc_env)
deletes the no more used global tree nodes beside the result nodes from begin_ptr to end_ptr
Definition: tmc_tree_build.F:1129
tmc_tree_build::remove_all_trees
subroutine, public remove_all_trees(working_elem_list, tmc_env)
deallocates the no more used tree nodes beside the result nodes from begin_ptr to end_ptr in global a...
Definition: tmc_tree_build.F:1411
tmc_tree_build::finalize_trees
subroutine, public finalize_trees(tmc_env)
deallocating every tree node of every trees (clean up)
Definition: tmc_tree_build.F:1583
tmc_tree_build::allocate_new_sub_tree_node
subroutine, public allocate_new_sub_tree_node(tmc_params, next_el, nr_dim)
allocates an elements of the subtree element structure
Definition: tmc_tree_build.F:160
tmc_tree_references
global tree references
Definition: tmc_tree_references.F:22
tmc_tree_references::search_and_remove_reference_in_list
subroutine, public search_and_remove_reference_in_list(gt_ptr, elem, tmc_env)
removes the global tree references of this actual global tree element from all related sub tree eleme...
Definition: tmc_tree_references.F:202
tmc_tree_references::add_to_references
subroutine, public add_to_references(gt_elem)
adds global tree reference to the modified sub tree element(s)
Definition: tmc_tree_references.F:49
tmc_tree_references::remove_subtree_element_of_all_references
subroutine, public remove_subtree_element_of_all_references(ptr)
removes the pointers to a certain subtree element from every related global tree element
Definition: tmc_tree_references.F:130
tmc_tree_references::remove_gt_references
subroutine, public remove_gt_references(gt_ptr, tmc_env)
removes the global tree references of this actual global tree element from all related sub tree eleme...
Definition: tmc_tree_references.F:98
tmc_tree_search
tree nodes search etc.
Definition: tmc_tree_search.F:15
tmc_tree_search::search_end_of_clean_g_tree
recursive subroutine, public search_end_of_clean_g_tree(last_acc, tree_ptr)
searches last element on trajectory, until where the sides of the tree are deleted (of global tree) a...
Definition: tmc_tree_search.F:416
tmc_tree_search::search_parent_element
recursive type(tree_type) function, pointer, public search_parent_element(current)
searching the parent element (last accepted configuration before)
Definition: tmc_tree_search.F:280
tmc_tree_search::most_prob_end
recursive subroutine, public most_prob_end(global_tree_elem, prob, n_acc, search_energy_node)
search most probable end in global tree to create a new tree node using the acceptance probabilities ...
Definition: tmc_tree_search.F:68
tmc_tree_search::search_end_of_clean_tree
recursive subroutine, public search_end_of_clean_tree(tree_ptr, last_acc)
searches last element on trajectory, until where the sides of the tree are deleted (in sub tree) also...
Definition: tmc_tree_search.F:467
tmc_tree_types
module handles definition of the tree nodes for the global and the subtrees binary tree parent elemen...
Definition: tmc_tree_types.F:32
tmc_tree_types::status_deleted
integer, parameter, public status_deleted
Definition: tmc_tree_types.F:66
tmc_tree_types::status_accepted
integer, parameter, public status_accepted
Definition: tmc_tree_types.F:57
tmc_tree_types::status_calculate_energy
integer, parameter, public status_calculate_energy
Definition: tmc_tree_types.F:49
tmc_tree_types::status_calculate_md
integer, parameter, public status_calculate_md
Definition: tmc_tree_types.F:53
tmc_tree_types::add_to_list
subroutine, public add_to_list(elem, list, temp_ind, nr)
add a certain element to the specified element list at the beginning
Definition: tmc_tree_types.F:180
tmc_tree_types::status_canceled_ener
integer, parameter, public status_canceled_ener
Definition: tmc_tree_types.F:64
tmc_tree_types::status_calculated
integer, parameter, public status_calculated
Definition: tmc_tree_types.F:54
tmc_tree_types::status_cancel_ener
integer, parameter, public status_cancel_ener
Definition: tmc_tree_types.F:62
tmc_tree_types::status_cancel_nmc
integer, parameter, public status_cancel_nmc
Definition: tmc_tree_types.F:61
tmc_tree_types::status_canceled_nmc
integer, parameter, public status_canceled_nmc
Definition: tmc_tree_types.F:63
tmc_tree_types::status_calc_approx_ener
integer, parameter, public status_calc_approx_ener
Definition: tmc_tree_types.F:50
tmc_tree_types::status_ok
integer, parameter, public status_ok
Definition: tmc_tree_types.F:70
tmc_tree_types::status_rejected
integer, parameter, public status_rejected
Definition: tmc_tree_types.F:58
tmc_tree_types::status_calculate_nmc_steps
integer, parameter, public status_calculate_nmc_steps
Definition: tmc_tree_types.F:52
tmc_tree_types::status_accepted_result
integer, parameter, public status_accepted_result
Definition: tmc_tree_types.F:56
tmc_tree_types::status_deleted_result
integer, parameter, public status_deleted_result
Definition: tmc_tree_types.F:67
tmc_tree_types::status_created
integer, parameter, public status_created
Definition: tmc_tree_types.F:48
tmc_tree_types::status_rejected_result
integer, parameter, public status_rejected_result
Definition: tmc_tree_types.F:59
tmc_types
module handles definition of the tree nodes for the global and the subtrees binary tree parent elemen...
Definition: tmc_types.F:32