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