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