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