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 search etc.
10 : !> \par History
11 : !> 11.2012 created [Mandes Schoenherr]
12 : !> \author Mandes
13 : ! **************************************************************************************************
14 :
15 : MODULE tmc_tree_search
16 : USE cp_log_handling, ONLY: cp_to_string
17 : USE kinds, ONLY: dp
18 : USE tmc_stati, ONLY: TMC_STATUS_WAIT_FOR_NEW_TASK
19 : USE tmc_tree_references, ONLY: add_to_references,&
20 : search_and_remove_reference_in_list
21 : USE tmc_tree_types, ONLY: &
22 : elem_array_type, global_tree_type, status_accepted, status_accepted_result, &
23 : status_calc_approx_ener, status_calculate_MD, status_calculate_NMC_steps, &
24 : status_calculate_energy, status_calculated, status_cancel_ener, status_cancel_nmc, &
25 : status_canceled_ener, status_canceled_nmc, status_created, status_deleted, &
26 : status_deleted_result, status_rejected, status_rejected_result, tree_type
27 : USE tmc_types, ONLY: tmc_env_type
28 : #include "../base/base_uses.f90"
29 :
30 : IMPLICIT NONE
31 :
32 : PRIVATE
33 :
34 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'tmc_tree_search'
35 :
36 : PUBLIC :: most_prob_end
37 : PUBLIC :: search_next_energy_calc
38 : PUBLIC :: search_canceling_elements
39 : PUBLIC :: search_parent_element, get_subtree_elements_to_check
40 : PUBLIC :: search_next_gt_element_to_check
41 : PUBLIC :: search_end_of_clean_g_tree, search_end_of_clean_tree
42 : PUBLIC :: count_prepared_nodes_in_trees, count_nodes_in_trees
43 : CONTAINS
44 :
45 : !============================================================================
46 : ! search tree node
47 : !============================================================================
48 : ! **************************************************************************************************
49 : !> \brief search most probable end in global tree to create a new tree node
50 : !> using the acceptance probabilities for each move type
51 : !> of each temperature
52 : !> routine distinguishes the search for most probable node
53 : !> for energy and most probable node with open end
54 : !> for new configuration
55 : !> In case of searching open end:
56 : !> routine stops in branch with canceled NMC,
57 : !> using this a one possibility
58 : !> \param global_tree_elem starting point for search
59 : !> \param prob return value, the probability of reaching the tree node
60 : !> \param n_acc drection of branch the next tree node should extend
61 : !> \param search_energy_node ...
62 : !> \parma search_energy_node flag if configuration for calculating exact
63 : !> energy should be searched
64 : !> \author Mandes 12.2012
65 : ! **************************************************************************************************
66 341374 : RECURSIVE SUBROUTINE most_prob_end(global_tree_elem, prob, n_acc, &
67 : search_energy_node)
68 : TYPE(global_tree_type), POINTER :: global_tree_elem
69 : REAL(KIND=dp), INTENT(OUT) :: prob
70 : LOGICAL, INTENT(INOUT) :: n_acc
71 : LOGICAL, OPTIONAL :: search_energy_node
72 :
73 : CHARACTER(LEN=*), PARAMETER :: routineN = 'most_prob_end'
74 :
75 : INTEGER :: handle
76 : LOGICAL :: check_accepted, check_rejected, keep_on, &
77 : tmp_acc, tmp_nacc
78 : REAL(KIND=dp) :: prob_n_acc, prob_n_nacc
79 : TYPE(global_tree_type), POINTER :: ptr_acc, ptr_nacc
80 : TYPE(tree_type), POINTER :: st_elem
81 :
82 170687 : NULLIFY (st_elem, ptr_acc, ptr_nacc)
83 :
84 170687 : prob_n_acc = -100000
85 170687 : prob_n_nacc = -100000
86 170687 : check_accepted = .FALSE.
87 170687 : check_rejected = .FALSE.
88 170687 : keep_on = .TRUE.
89 :
90 170687 : CPASSERT(ASSOCIATED(global_tree_elem))
91 170687 : st_elem => global_tree_elem%conf(global_tree_elem%mv_conf)%elem
92 170687 : CPASSERT(ASSOCIATED(st_elem))
93 :
94 : ! start the timing
95 170687 : CALL timeset(routineN, handle)
96 :
97 : !-- follow trajectory until end
98 : !-- evaluate following elements using status, and probabilites
99 170687 : SELECT CASE (global_tree_elem%stat)
100 : CASE (status_accepted, status_accepted_result)
101 : check_accepted = .TRUE.
102 : CASE (status_rejected, status_rejected_result)
103 21 : check_rejected = .TRUE.
104 : CASE DEFAULT
105 : !-- set directions of searching
106 170687 : SELECT CASE (st_elem%stat)
107 : CASE (status_created, status_canceled_ener)
108 : ! just for searching next element to calculate energy for (found)
109 21 : IF (PRESENT(search_energy_node)) THEN
110 21 : prob = 0.0_dp ! = log(1)
111 21 : n_acc = .FALSE. ! not needed, but maybe for initialisation
112 : keep_on = .FALSE.
113 : ELSE
114 : check_accepted = .TRUE.
115 : check_rejected = .TRUE.
116 : END IF
117 : CASE (status_canceled_nmc)
118 : ! just for search new element to create (found)
119 : ! canceled elements can be reactivated
120 : ! the parent element is returned,
121 : ! the create_new_pt_tree_node check for existing of this node
122 0 : IF (.NOT. PRESENT(search_energy_node)) THEN
123 0 : prob = 0.0_dp
124 0 : n_acc = ASSOCIATED(global_tree_elem%parent%acc, global_tree_elem)
125 0 : global_tree_elem => global_tree_elem%parent
126 : keep_on = .FALSE.
127 : END IF
128 : CASE (status_calculated, status_calculate_energy, &
129 : status_accepted_result, status_accepted, &
130 : status_rejected, status_rejected_result)
131 : ! status accepted and rejection needed for swapped
132 : ! configurations in parallel tempering
133 : check_accepted = .TRUE.
134 0 : check_rejected = .TRUE.
135 : CASE (status_calculate_MD, status_calculate_NMC_steps, &
136 : status_calc_approx_ener)
137 : ! just for searching next element to create
138 0 : IF (.NOT. PRESENT(search_energy_node)) THEN
139 : check_rejected = .TRUE.
140 : END IF
141 : CASE (status_cancel_nmc, status_cancel_ener)
142 : CASE DEFAULT
143 : CALL cp_abort(__LOCATION__, &
144 : "unknown sub tree element status "// &
145 21 : cp_to_string(st_elem%stat))
146 : END SELECT
147 : END SELECT
148 :
149 : IF (keep_on) THEN
150 : !-- recursive search, remembering lowest element (tree end),
151 : ! and multiply probabilities to go there
152 : !-- search in ACCEPTED branch
153 170666 : IF (check_accepted) THEN
154 : ! test if probable accepted child exist and is not rejected
155 8721 : IF (ASSOCIATED(global_tree_elem%acc)) THEN
156 7121 : ptr_acc => global_tree_elem%acc
157 7121 : IF (PRESENT(search_energy_node)) THEN
158 : CALL most_prob_end(global_tree_elem=ptr_acc, prob=prob_n_acc, &
159 : n_acc=tmp_acc, &
160 3565 : search_energy_node=search_energy_node)
161 : ELSE
162 : CALL most_prob_end(global_tree_elem=ptr_acc, prob=prob_n_acc, &
163 3556 : n_acc=tmp_acc)
164 : END IF
165 : !-- do probability multiplication
166 : ! (in logscale because of really small probabilities)
167 7121 : prob_n_acc = prob_n_acc + LOG(global_tree_elem%prob_acc)
168 : ELSE
169 : ! prob of going in acc or rej direction is
170 : ! calculated in parent element
171 1600 : prob_n_acc = LOG(global_tree_elem%prob_acc)
172 1600 : IF (PRESENT(search_energy_node)) prob_n_acc = -100000
173 1600 : ptr_acc => global_tree_elem
174 1600 : tmp_acc = .TRUE.
175 : END IF
176 : END IF
177 :
178 : !-- search in REJECTED branch
179 170666 : IF (check_rejected) THEN
180 : ! test if probabliy rejected child exist
181 161945 : IF (ASSOCIATED(global_tree_elem%nacc)) THEN
182 154833 : ptr_nacc => global_tree_elem%nacc
183 154833 : IF (PRESENT(search_energy_node)) THEN
184 : CALL most_prob_end(global_tree_elem=ptr_nacc, prob=prob_n_nacc, &
185 : n_acc=tmp_nacc, &
186 77425 : search_energy_node=search_energy_node)
187 : ELSE
188 : CALL most_prob_end(global_tree_elem=ptr_nacc, prob=prob_n_nacc, &
189 77408 : n_acc=tmp_nacc)
190 : END IF
191 : !-- do probability multiplication
192 : ! (in logscale because of really small probabilities)
193 154833 : prob_n_nacc = prob_n_nacc + LOG(1 - global_tree_elem%prob_acc)
194 : ELSE
195 : ! prob of going in acc or rej direction is
196 : ! calculated in parent element
197 7112 : prob_n_nacc = LOG(1 - global_tree_elem%prob_acc)
198 7112 : IF (PRESENT(search_energy_node)) prob_n_nacc = -100000
199 7112 : ptr_nacc => global_tree_elem
200 7112 : tmp_nacc = .FALSE.
201 : END IF
202 : END IF
203 : ! test which direction is more likely
204 : ! and set result pointer and probability,
205 : ! remembering the direction
206 170666 : IF (prob_n_acc >= prob_n_nacc) THEN
207 89685 : prob = prob_n_acc
208 89685 : global_tree_elem => ptr_acc
209 89685 : n_acc = tmp_acc
210 : ELSE
211 80981 : prob = prob_n_nacc
212 80981 : global_tree_elem => ptr_nacc
213 80981 : n_acc = tmp_nacc
214 : END IF
215 : END IF
216 : ! end the timing
217 170687 : CALL timestop(handle)
218 170687 : END SUBROUTINE most_prob_end
219 :
220 : ! **************************************************************************************************
221 : !> \brief gt_head head of the global tree
222 : !> \param gt_head ...
223 : !> \param new_gt_elem return value the energy should be calculated for
224 : !> \param stat routine status return value
225 : !> \param react_count reactivation counter
226 : !> \author Mandes 12.2012
227 : ! **************************************************************************************************
228 8754 : SUBROUTINE search_next_energy_calc(gt_head, new_gt_elem, stat, react_count)
229 : TYPE(global_tree_type), POINTER :: gt_head, new_gt_elem
230 : INTEGER :: stat, react_count
231 :
232 : CHARACTER(LEN=*), PARAMETER :: routineN = 'search_next_energy_calc'
233 : REAL(KIND=dp), PARAMETER :: eps_exp_prob = 1.0E-10_dp
234 :
235 : INTEGER :: handle
236 : LOGICAL :: flag
237 : REAL(KIND=dp) :: prob
238 :
239 : prob = 0.0_dp
240 4377 : flag = .FALSE.
241 4377 : CPASSERT(ASSOCIATED(gt_head))
242 :
243 : ! start the timing
244 4377 : CALL timeset(routineN, handle)
245 :
246 4377 : new_gt_elem => gt_head
247 :
248 : CALL most_prob_end(global_tree_elem=new_gt_elem, prob=prob, n_acc=flag, &
249 4377 : search_energy_node=.TRUE.)
250 :
251 4377 : stat = status_created
252 : ! set status for master
253 : ! (if TMC_STATUS_WAIT_FOR_NEW_TASK, no calculation necessary)
254 4377 : IF (.NOT. ASSOCIATED(new_gt_elem) .OR. (EXP(prob) < eps_exp_prob)) THEN
255 4356 : stat = TMC_STATUS_WAIT_FOR_NEW_TASK
256 : ELSE
257 : ! reactivate canceled elements
258 21 : IF (new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat == &
259 : status_canceled_ener) THEN
260 0 : CALL add_to_references(gt_elem=new_gt_elem)
261 0 : react_count = react_count + 1
262 0 : new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat = status_created
263 : END IF
264 : ! if elem status is not status_created
265 21 : IF (new_gt_elem%conf(new_gt_elem%mv_conf)%elem%stat /= status_created) THEN
266 0 : stat = TMC_STATUS_WAIT_FOR_NEW_TASK
267 : END IF
268 : END IF
269 : ! end the timing
270 4377 : CALL timestop(handle)
271 4377 : END SUBROUTINE search_next_energy_calc
272 :
273 : ! **************************************************************************************************
274 : !> \brief searching the parent element (last accepted configuration before)
275 : !> \param current actual tree element
276 : !> \return parent tree element (last accepted one)
277 : !> \author Mandes 12.2012
278 : !> \note routine searches last (assumed) accepted element in subtree
279 : ! **************************************************************************************************
280 2604696 : RECURSIVE FUNCTION search_parent_element(current) RESULT(parent)
281 : TYPE(tree_type), POINTER :: current, parent
282 :
283 : CHARACTER(LEN=*), PARAMETER :: routineN = 'search_parent_element'
284 :
285 : INTEGER :: handle
286 :
287 1302348 : CPASSERT(ASSOCIATED(current))
288 :
289 : ! start the timing
290 1302348 : CALL timeset(routineN, handle)
291 :
292 1302348 : IF (ASSOCIATED(current%parent)) THEN
293 : ! the result value if the child (we came from) is in acc direction
294 1288148 : parent => current%parent
295 1288148 : IF (ASSOCIATED(parent%nacc, current)) THEN
296 1053551 : parent => search_parent_element(parent)
297 : END IF
298 : ELSE
299 : ! if parent not exist, we are at the head of the tree
300 14200 : parent => current
301 : END IF
302 : ! end the timing
303 1302348 : CALL timestop(handle)
304 1302348 : CPASSERT(ASSOCIATED(parent))
305 1302348 : END FUNCTION search_parent_element
306 :
307 : ! **************************************************************************************************
308 : !> \brief search the next global element in the Markov Chain to check
309 : !> \param ptr start point for search, should be on the known Markov Chain
310 : !> \param found flag if routine was successful
311 : !> \author Mandes 12.2012
312 : ! **************************************************************************************************
313 2552868 : RECURSIVE SUBROUTINE search_next_gt_element_to_check(ptr, found)
314 : TYPE(global_tree_type), POINTER :: ptr
315 : LOGICAL :: found
316 :
317 : CHARACTER(LEN=*), PARAMETER :: routineN = 'search_next_gt_element_to_check'
318 :
319 : INTEGER :: handle
320 :
321 1276434 : found = .FALSE.
322 :
323 1276434 : CPASSERT(ASSOCIATED(ptr))
324 :
325 : ! start the timing
326 1276434 : CALL timeset(routineN, handle)
327 :
328 : ! -- global tree status is not updated after receiving calculations
329 : ! (not intrinsically), hence try to check elements with could be ready
330 1499174 : SELECT CASE (ptr%stat)
331 : CASE (status_accepted_result)
332 222740 : IF (ASSOCIATED(ptr%acc)) THEN
333 221927 : ptr => ptr%acc
334 221927 : CALL search_next_gt_element_to_check(ptr, found)
335 : END IF
336 : CASE (status_rejected_result)
337 817567 : IF (ASSOCIATED(ptr%nacc)) THEN
338 814011 : ptr => ptr%nacc
339 814011 : CALL search_next_gt_element_to_check(ptr, found)
340 : END IF
341 : CASE (status_calculate_energy, status_created, &
342 : status_calculate_MD, status_calculated, status_calculate_NMC_steps, &
343 : status_calc_approx_ener, status_accepted, status_rejected)
344 236127 : found = .TRUE.
345 : CASE (status_cancel_nmc, status_cancel_ener, status_canceled_nmc, &
346 : status_canceled_ener)
347 : ! nothing to do
348 : CASE DEFAULT
349 : CALL cp_abort(__LOCATION__, &
350 : "unexpected status "//cp_to_string(ptr%stat)// &
351 1276434 : "of global tree elem "//cp_to_string(ptr%nr))
352 : END SELECT
353 : ! end the timing
354 1276434 : CALL timestop(handle)
355 :
356 1276434 : CPASSERT(ASSOCIATED(ptr))
357 1276434 : END SUBROUTINE search_next_gt_element_to_check
358 :
359 : ! **************************************************************************************************
360 : !> \brief get the changed element of the actual global tree element and its
361 : !> related last accepted parent
362 : !> \param gt_act_elem actual global tree element
363 : !> \param elem1 two subtree elements which should be compared
364 : !> \param elem2 two subtree elements which should be compared
365 : !> \author Mandes 12.2012
366 : ! **************************************************************************************************
367 480964 : SUBROUTINE get_subtree_elements_to_check(gt_act_elem, elem1, elem2)
368 : TYPE(global_tree_type), POINTER :: gt_act_elem
369 : TYPE(tree_type), INTENT(OUT), POINTER :: elem1, elem2
370 :
371 : CHARACTER(LEN=*), PARAMETER :: routineN = 'get_subtree_elements_to_check'
372 :
373 : INTEGER :: handle
374 :
375 240482 : CPASSERT(ASSOCIATED(gt_act_elem))
376 :
377 : ! start the timing
378 240482 : CALL timeset(routineN, handle)
379 :
380 240482 : IF (gt_act_elem%swaped) THEN
381 : !------------------------------------------------------------
382 : !-- take the last accepted configurations for check of both configurations, because
383 : !-- in case of swapping, the last accepted elements have to be compared
384 336 : IF (gt_act_elem%conf_n_acc(gt_act_elem%conf(gt_act_elem%mv_conf)%elem%sub_tree_nr)) THEN
385 184 : elem1 => gt_act_elem%conf(gt_act_elem%mv_conf)%elem
386 : ELSE
387 152 : elem1 => search_parent_element(gt_act_elem%conf(gt_act_elem%mv_conf)%elem)
388 : END IF
389 : ! second element
390 336 : IF (gt_act_elem%conf_n_acc(gt_act_elem%conf(gt_act_elem%mv_conf + 1)%elem%sub_tree_nr)) THEN
391 212 : elem2 => gt_act_elem%conf(gt_act_elem%mv_conf + 1)%elem
392 : ELSE
393 124 : elem2 => search_parent_element(gt_act_elem%conf(gt_act_elem%mv_conf + 1)%elem)
394 : END IF
395 : ELSE
396 240146 : elem1 => gt_act_elem%conf(gt_act_elem%mv_conf)%elem
397 240146 : elem2 => search_parent_element(elem1)
398 : END IF
399 :
400 : ! end the timing
401 240482 : CALL timestop(handle)
402 :
403 240482 : CPASSERT(ASSOCIATED(gt_act_elem))
404 240482 : CPASSERT(ASSOCIATED(elem1))
405 240482 : CPASSERT(ASSOCIATED(elem2))
406 240482 : END SUBROUTINE get_subtree_elements_to_check
407 :
408 : ! **************************************************************************************************
409 : !> \brief searches last element on trajectory,
410 : !> until where the sides of the tree are deleted (of global tree)
411 : !> also found the last accepted element before
412 : !> \param last_acc returns last accepted element in cleaned tree part
413 : !> \param tree_ptr end point of search
414 : !> \author Mandes 12.2012
415 : ! **************************************************************************************************
416 187416 : RECURSIVE SUBROUTINE search_end_of_clean_g_tree(last_acc, tree_ptr)
417 : TYPE(global_tree_type), POINTER :: last_acc, tree_ptr
418 :
419 : CHARACTER(LEN=*), PARAMETER :: routineN = 'search_end_of_clean_g_tree'
420 :
421 : INTEGER :: handle
422 :
423 93708 : CPASSERT(ASSOCIATED(last_acc))
424 93708 : CPASSERT(ASSOCIATED(tree_ptr))
425 :
426 : ! start the timing
427 93708 : CALL timeset(routineN, handle)
428 :
429 99617 : SELECT CASE (tree_ptr%stat)
430 : CASE (status_accepted_result)
431 5909 : IF (ASSOCIATED(tree_ptr%acc) .AND. .NOT. ASSOCIATED(tree_ptr%nacc)) THEN
432 5123 : last_acc => tree_ptr
433 5123 : tree_ptr => tree_ptr%acc
434 5123 : CALL search_end_of_clean_g_tree(last_acc, tree_ptr)
435 : END IF
436 : CASE (status_rejected_result)
437 87799 : IF (ASSOCIATED(tree_ptr%nacc) .AND. .NOT. ASSOCIATED(tree_ptr%acc)) THEN
438 84243 : tree_ptr => tree_ptr%nacc
439 84243 : CALL search_end_of_clean_g_tree(last_acc, tree_ptr)
440 : END IF
441 : CASE (status_calculated, status_calculate_energy, status_created, status_accepted, status_rejected, &
442 : status_calculate_MD, status_calculate_NMC_steps, status_calc_approx_ener, &
443 : status_canceled_ener, status_canceled_nmc, &
444 : status_cancel_nmc, status_cancel_ener)
445 : ! nothing to do
446 : CASE DEFAULT
447 : CALL cp_abort(__LOCATION__, &
448 : "the global tree element "//cp_to_string(tree_ptr%nr)// &
449 93708 : " stat "//cp_to_string(tree_ptr%stat)//" is UNknown")
450 : END SELECT
451 : ! end the timing
452 93708 : CALL timestop(handle)
453 93708 : CPASSERT(ASSOCIATED(last_acc))
454 93708 : CPASSERT(ASSOCIATED(tree_ptr))
455 93708 : END SUBROUTINE search_end_of_clean_g_tree
456 :
457 : ! **************************************************************************************************
458 : !> \brief searches last element on trajectory,
459 : !> until where the sides of the tree are deleted (in sub tree)
460 : !> also found the last accepted element before.
461 : !> searches the last element which at least have ONE (not calculated)
462 : !> node in the tree branch
463 : !> \param tree_ptr ...
464 : !> \param last_acc ...
465 : !> \author Mandes 12.2012
466 : ! **************************************************************************************************
467 20360 : RECURSIVE SUBROUTINE search_end_of_clean_tree(tree_ptr, last_acc)
468 : TYPE(tree_type), POINTER :: tree_ptr
469 : TYPE(tree_type), INTENT(IN), POINTER :: last_acc
470 :
471 : CHARACTER(LEN=*), PARAMETER :: routineN = 'search_end_of_clean_tree'
472 :
473 : INTEGER :: handle
474 :
475 10180 : CPASSERT(ASSOCIATED(tree_ptr))
476 10180 : CPASSERT(ASSOCIATED(last_acc))
477 :
478 : ! start the timing
479 10180 : CALL timeset(routineN, handle)
480 :
481 10180 : IF (.NOT. ASSOCIATED(last_acc, tree_ptr)) THEN
482 4036 : IF (ASSOCIATED(tree_ptr%acc) .AND. .NOT. ASSOCIATED(tree_ptr%nacc)) THEN
483 660 : tree_ptr => tree_ptr%acc
484 660 : CALL search_end_of_clean_tree(tree_ptr, last_acc)
485 3376 : ELSE IF (ASSOCIATED(tree_ptr%nacc) .AND. .NOT. ASSOCIATED(tree_ptr%acc)) THEN
486 3376 : tree_ptr => tree_ptr%nacc
487 3376 : CALL search_end_of_clean_tree(tree_ptr, last_acc)
488 : END IF
489 : END IF
490 : ! end the timing
491 10180 : CALL timestop(handle)
492 10180 : CPASSERT(ASSOCIATED(tree_ptr))
493 10180 : CPASSERT(ASSOCIATED(last_acc))
494 10180 : END SUBROUTINE search_end_of_clean_tree
495 :
496 : ! **************************************************************************************************
497 : !> \brief searches in all branches down below the entered global tree element
498 : !> for elements to cancel, if prob is present start searching at the
499 : !> related tree child node
500 : !> \param pt_elem_in start search point
501 : !> \param prob the acceptance probability of the tree element to define
502 : !> the direction to start with
503 : !> \param tmc_env TMC environment
504 : !> \author Mandes 12.2012
505 : ! **************************************************************************************************
506 0 : RECURSIVE SUBROUTINE search_canceling_elements(pt_elem_in, prob, tmc_env)
507 : TYPE(global_tree_type), INTENT(IN), POINTER :: pt_elem_in
508 : REAL(KIND=dp), OPTIONAL :: prob
509 : TYPE(tmc_env_type), POINTER :: tmc_env
510 :
511 : CHARACTER(LEN=*), PARAMETER :: routineN = 'search_canceling_elements'
512 : REAL(KIND=dp), PARAMETER :: eps_prob = 1.0E-10_dp
513 :
514 : INTEGER :: handle
515 : LOGICAL :: ready
516 : TYPE(global_tree_type), POINTER :: act_pt_ptr, pt_elem
517 :
518 0 : NULLIFY (pt_elem, act_pt_ptr)
519 0 : CPASSERT(ASSOCIATED(pt_elem_in))
520 0 : CPASSERT(ASSOCIATED(tmc_env))
521 :
522 : ! start the timing
523 0 : CALL timeset(routineN, handle)
524 :
525 0 : ready = .TRUE.
526 : ! if prob present select the related branch
527 0 : IF (PRESENT(prob)) THEN
528 0 : IF (prob < eps_prob .AND. ASSOCIATED(pt_elem_in%acc)) THEN
529 0 : pt_elem => pt_elem_in%acc
530 0 : ELSE IF (prob > (1.0_dp - eps_prob) .AND. ASSOCIATED(pt_elem_in%nacc)) THEN
531 0 : pt_elem => pt_elem_in%nacc
532 : ELSE
533 : ready = .FALSE.
534 : END IF
535 : ELSE
536 0 : pt_elem => pt_elem_in
537 : END IF
538 :
539 : IF (ready) THEN
540 0 : IF (ASSOCIATED(pt_elem%conf(pt_elem%mv_conf)%elem)) THEN
541 0 : SELECT CASE (pt_elem%conf(pt_elem%mv_conf)%elem%stat)
542 : CASE (status_accepted_result, status_accepted, status_rejected_result, &
543 : status_rejected, status_created, status_cancel_nmc, &
544 : status_cancel_ener, status_canceled_nmc, status_canceled_ener, &
545 : status_calculated, status_deleted, status_deleted_result, &
546 : status_calc_approx_ener) ! no canceling
547 : CASE (status_calculate_NMC_steps, status_calculate_MD, &
548 : status_calculate_energy)
549 : CALL search_and_remove_reference_in_list(gt_ptr=pt_elem, &
550 0 : elem=pt_elem%conf(pt_elem%mv_conf)%elem, tmc_env=tmc_env)
551 :
552 : CASE DEFAULT
553 : CALL cp_abort(__LOCATION__, &
554 : "unknown status of subtree element"// &
555 0 : cp_to_string(pt_elem%conf(pt_elem%mv_conf)%elem%stat))
556 : END SELECT
557 : END IF
558 : !-- go until the ends ot he tree, to search for elements to cancel
559 : !-- check if child nodes exist
560 0 : IF (ASSOCIATED(pt_elem%acc)) THEN
561 0 : act_pt_ptr => pt_elem%acc
562 0 : CALL search_canceling_elements(pt_elem_in=act_pt_ptr, tmc_env=tmc_env)
563 : END IF
564 0 : IF (ASSOCIATED(pt_elem%nacc)) THEN
565 0 : act_pt_ptr => pt_elem%nacc
566 0 : CALL search_canceling_elements(pt_elem_in=act_pt_ptr, tmc_env=tmc_env)
567 : END IF
568 : END IF
569 : ! end the timing
570 0 : CALL timestop(handle)
571 0 : CPASSERT(ASSOCIATED(pt_elem_in))
572 0 : END SUBROUTINE search_canceling_elements
573 :
574 : ! **************************************************************************************************
575 : !> \brief searches for created configurations in all subtrees
576 : !> \param global_tree_ptr pointer to one global tree element
577 : !> \param counters array returning the counters for each subtree
578 : !> \author Mandes 01.2013
579 : ! **************************************************************************************************
580 56 : SUBROUTINE count_prepared_nodes_in_trees(global_tree_ptr, counters)
581 : TYPE(global_tree_type), INTENT(IN), POINTER :: global_tree_ptr
582 : INTEGER, DIMENSION(:), POINTER :: counters
583 :
584 : CHARACTER(len=*), PARAMETER :: routineN = 'count_prepared_nodes_in_trees'
585 :
586 : INTEGER :: handle, i
587 : TYPE(tree_type), POINTER :: begin_ptr
588 :
589 : NULLIFY (begin_ptr)
590 :
591 28 : CPASSERT(ASSOCIATED(global_tree_ptr))
592 28 : CPASSERT(ASSOCIATED(counters))
593 28 : CPASSERT(SIZE(counters(1:)) == SIZE(global_tree_ptr%conf(:)))
594 :
595 : ! start the timing
596 28 : CALL timeset(routineN, handle)
597 :
598 86 : counters(:) = 0
599 58 : DO i = 1, SIZE(global_tree_ptr%conf(:))
600 30 : begin_ptr => global_tree_ptr%conf(i)%elem
601 : CALL count_prepared_nodes_in_subtree(tree_ptr=begin_ptr, &
602 58 : counter=counters(i))
603 : END DO
604 :
605 : ! end the timing
606 28 : CALL timestop(handle)
607 28 : END SUBROUTINE count_prepared_nodes_in_trees
608 :
609 : ! **************************************************************************************************
610 : !> \brief counts the prepared tree nodes in subtrees
611 : !> \param tree_ptr pointer to one subtree element
612 : !> \param counter returning the amount of prepared
613 : !> (ready for energy calculation) elements ind certain sub tree
614 : !> \author Mandes 01.2013
615 : ! **************************************************************************************************
616 54 : RECURSIVE SUBROUTINE count_prepared_nodes_in_subtree(tree_ptr, counter)
617 : TYPE(tree_type), POINTER :: tree_ptr
618 : INTEGER :: counter
619 :
620 : TYPE(tree_type), POINTER :: tmp_ptr
621 :
622 54 : NULLIFY (tmp_ptr)
623 :
624 54 : CPASSERT(ASSOCIATED(tree_ptr))
625 :
626 77 : SELECT CASE (tree_ptr%stat)
627 : CASE (status_accepted, status_accepted_result)
628 23 : IF (ASSOCIATED(tree_ptr%acc)) THEN
629 23 : tmp_ptr => tree_ptr%acc
630 23 : CALL count_prepared_nodes_in_subtree(tmp_ptr, counter)
631 : END IF
632 : CASE (status_rejected, status_rejected_result)
633 1 : IF (ASSOCIATED(tree_ptr%nacc)) THEN
634 1 : tmp_ptr => tree_ptr%nacc
635 1 : CALL count_prepared_nodes_in_subtree(tmp_ptr, counter)
636 : END IF
637 : CASE (status_created, status_calculate_MD, status_calculate_NMC_steps, &
638 : status_calc_approx_ener, status_calculated, status_calculate_energy)
639 30 : IF (tree_ptr%stat == status_created) counter = counter + 1
640 30 : IF (ASSOCIATED(tree_ptr%acc)) THEN
641 0 : tmp_ptr => tree_ptr%acc
642 0 : CALL count_prepared_nodes_in_subtree(tmp_ptr, counter)
643 : END IF
644 30 : IF (ASSOCIATED(tree_ptr%nacc)) THEN
645 0 : tmp_ptr => tree_ptr%nacc
646 0 : CALL count_prepared_nodes_in_subtree(tmp_ptr, counter)
647 : END IF
648 : CASE (status_cancel_nmc, status_cancel_ener, status_canceled_nmc, &
649 : status_canceled_ener)
650 : !TODO maybe also count caneled confs for debug output
651 : CASE DEFAULT
652 : CALL cp_abort(__LOCATION__, &
653 : "stat "//cp_to_string(tree_ptr%stat)// &
654 : "of elem "//cp_to_string(tree_ptr%nr)// &
655 54 : "unknown.")
656 : END SELECT
657 54 : END SUBROUTINE count_prepared_nodes_in_subtree
658 :
659 : ! **************************************************************************************************
660 : !> \brief counts the number of existing nodes in global and subtrees
661 : !> \param global_tree_ptr pointer to one global tree element
662 : !> \param end_of_clean_trees points to the last elements of the clean sub trees
663 : !> \param counters array returning the counters for each subtree
664 : !> \param head_elements_nr node number of the existing
665 : !> global and sub tree heads
666 : !> \author Mandes 01.2013
667 : ! **************************************************************************************************
668 358 : SUBROUTINE count_nodes_in_trees(global_tree_ptr, end_of_clean_trees, &
669 : counters, head_elements_nr)
670 : TYPE(global_tree_type), POINTER :: global_tree_ptr
671 : TYPE(elem_array_type), DIMENSION(:), POINTER :: end_of_clean_trees
672 : INTEGER, DIMENSION(:), POINTER :: counters, head_elements_nr
673 :
674 : CHARACTER(len=*), PARAMETER :: routineN = 'count_nodes_in_trees'
675 :
676 : INTEGER :: handle, i
677 : TYPE(global_tree_type), POINTER :: begin_gt_ptr
678 : TYPE(tree_type), POINTER :: begin_ptr
679 :
680 : NULLIFY (begin_gt_ptr, begin_ptr)
681 :
682 179 : CPASSERT(ASSOCIATED(global_tree_ptr))
683 179 : CPASSERT(ASSOCIATED(end_of_clean_trees))
684 179 : CPASSERT(ASSOCIATED(counters))
685 179 : CPASSERT(SIZE(counters(1:)) == SIZE(global_tree_ptr%conf(:)))
686 :
687 : ! start the timing
688 179 : CALL timeset(routineN, handle)
689 :
690 179 : begin_gt_ptr => global_tree_ptr
691 773 : counters(:) = 0
692 135 : DO
693 314 : IF (.NOT. ASSOCIATED(begin_gt_ptr%parent)) EXIT
694 135 : begin_gt_ptr => begin_gt_ptr%parent
695 : END DO
696 179 : head_elements_nr(0) = begin_gt_ptr%nr
697 179 : CALL count_nodes_in_global_tree(begin_gt_ptr, counters(0))
698 594 : DO i = 1, SIZE(end_of_clean_trees(:))
699 415 : begin_ptr => end_of_clean_trees(i)%elem
700 61 : DO
701 476 : IF (.NOT. ASSOCIATED(begin_ptr%parent)) EXIT
702 61 : begin_ptr => begin_ptr%parent
703 : END DO
704 415 : head_elements_nr(i) = begin_ptr%nr
705 594 : CALL count_nodes_in_tree(begin_ptr, counters(i))
706 : END DO
707 :
708 : ! end the timing
709 179 : CALL timestop(handle)
710 179 : END SUBROUTINE count_nodes_in_trees
711 :
712 : ! **************************************************************************************************
713 : !> \brief counts existing nodes in global tree
714 : !> \param ptr global tree head
715 : !> \param counter return value with the amount of existing global tree elements
716 : !> \author Mandes 01.2013
717 : ! **************************************************************************************************
718 1256 : RECURSIVE SUBROUTINE count_nodes_in_global_tree(ptr, counter)
719 : TYPE(global_tree_type), INTENT(IN), POINTER :: ptr
720 : INTEGER, INTENT(INOUT) :: counter
721 :
722 1256 : CPASSERT(ASSOCIATED(ptr))
723 :
724 1256 : counter = counter + 1
725 :
726 1256 : IF (ASSOCIATED(ptr%acc)) THEN
727 259 : CALL count_nodes_in_global_tree(ptr%acc, counter)
728 : END IF
729 1256 : IF (ASSOCIATED(ptr%nacc)) THEN
730 818 : CALL count_nodes_in_global_tree(ptr%nacc, counter)
731 : END IF
732 1256 : END SUBROUTINE count_nodes_in_global_tree
733 :
734 : ! **************************************************************************************************
735 : !> \brief counts existing nodes in certain sub tree
736 : !> \param ptr subtree tree head
737 : !> \param counter return value with the amount of existing sub tree elements
738 : !> \author Mandes 01.2013
739 : ! **************************************************************************************************
740 1573 : RECURSIVE SUBROUTINE count_nodes_in_tree(ptr, counter)
741 : TYPE(tree_type), POINTER :: ptr
742 : INTEGER :: counter
743 :
744 1573 : CPASSERT(ASSOCIATED(ptr))
745 :
746 1573 : counter = counter + 1
747 :
748 1573 : IF (ASSOCIATED(ptr%acc)) THEN
749 294 : CALL count_nodes_in_tree(ptr%acc, counter)
750 : END IF
751 1573 : IF (ASSOCIATED(ptr%nacc)) THEN
752 864 : CALL count_nodes_in_tree(ptr%nacc, counter)
753 : END IF
754 1573 : END SUBROUTINE count_nodes_in_tree
755 : END MODULE tmc_tree_search
|
