|
CP2K 2.4 (Revision 12889)
|
00001 !-----------------------------------------------------------------------------! 00002 ! CP2K: A general program to perform molecular dynamics simulations ! 00003 ! Copyright (C) 2000 - 2013 CP2K developers group ! 00004 !-----------------------------------------------------------------------------! 00005 00006 ! ***************************************************************************** 00022 MODULE pw_pool_types 00023 USE cp_linked_list_3d_r, ONLY: cp_sll_3d_r_dealloc,& 00024 cp_sll_3d_r_get_first_el,& 00025 cp_sll_3d_r_get_length,& 00026 cp_sll_3d_r_insert_el,& 00027 cp_sll_3d_r_next,& 00028 cp_sll_3d_r_rm_first_el,& 00029 cp_sll_3d_r_type 00030 USE cp_linked_list_pw, ONLY: cp_sll_pw_dealloc,& 00031 cp_sll_pw_get_first_el,& 00032 cp_sll_pw_get_length,& 00033 cp_sll_pw_insert_el,& 00034 cp_sll_pw_insert_ordered,& 00035 cp_sll_pw_next,& 00036 cp_sll_pw_rm_first_el,& 00037 cp_sll_pw_type 00038 USE f77_blas 00039 USE kinds, ONLY: dp 00040 USE machine, ONLY: m_loc_r 00041 USE pw_grid_types, ONLY: pw_grid_type 00042 USE pw_grids, ONLY: pw_grid_compare,& 00043 pw_grid_release,& 00044 pw_grid_retain 00045 USE pw_methods, ONLY: pw_write 00046 USE pw_types, ONLY: COMPLEXDATA1D,& 00047 COMPLEXDATA3D,& 00048 REALDATA1D,& 00049 REALDATA3D,& 00050 pw_create,& 00051 pw_p_type,& 00052 pw_release,& 00053 pw_type 00054 USE timings, ONLY: print_stack,& 00055 timeset,& 00056 timestop 00057 #include "cp_common_uses.h" 00058 00059 IMPLICIT NONE 00060 PRIVATE 00061 00062 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.FALSE. 00063 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'pw_pool_types' 00064 INTEGER, SAVE, PRIVATE :: last_pw_pool_id_nr=0 00065 INTEGER, PARAMETER :: default_max_cache=75, max_max_cache=150 00066 00067 PUBLIC :: pw_pool_type, pw_pool_p_type 00068 PUBLIC :: pw_pool_create, pw_pool_retain, pw_pool_release,& 00069 pw_pool_create_pw, pw_pool_give_back_pw,& 00070 pw_pool_flush_cache, pw_pool_write,& 00071 pw_pool_create_cr3d, pw_pool_give_back_cr3d 00072 PUBLIC :: pw_pools_copy, pw_pools_dealloc, pw_pools_flush_cache,& 00073 pw_pools_create_pws, pw_pools_give_back_pws 00074 00075 ! ***************************************************************************** 00090 TYPE pw_pool_type 00091 INTEGER :: ref_count, id_nr, max_cache 00092 TYPE(pw_grid_type), POINTER :: pw_grid 00093 TYPE(cp_sll_pw_type), POINTER :: real1d_pw, real3d_pw, 00094 complex1d_pw, complex3d_pw 00095 TYPE(cp_sll_3d_r_type), POINTER :: real3d_array 00096 END TYPE pw_pool_type 00097 00098 ! ***************************************************************************** 00105 TYPE pw_pool_p_type 00106 TYPE(pw_pool_type), POINTER :: pool 00107 END TYPE pw_pool_p_type 00108 00109 CONTAINS 00110 00111 ! ***************************************************************************** 00121 SUBROUTINE pw_pool_create(pool, pw_grid, max_cache, error) 00122 TYPE(pw_pool_type), POINTER :: pool 00123 TYPE(pw_grid_type), POINTER :: pw_grid 00124 INTEGER, OPTIONAL :: max_cache 00125 TYPE(cp_error_type), INTENT(inout) :: error 00126 00127 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_create', 00128 routineP = moduleN//':'//routineN 00129 00130 INTEGER :: stat 00131 LOGICAL :: failure 00132 TYPE(cp_logger_type), POINTER :: logger 00133 00134 failure=.FALSE. 00135 logger => cp_error_get_logger(error) 00136 00137 ALLOCATE(pool, stat=stat) 00138 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00139 IF (.NOT.failure) THEN 00140 pool%pw_grid => pw_grid 00141 CALL pw_grid_retain(pw_grid,error=error) 00142 last_pw_pool_id_nr=last_pw_pool_id_nr+1 00143 pool%id_nr=last_pw_pool_id_nr 00144 pool%ref_count=1 00145 pool%max_cache=default_max_cache 00146 IF (PRESENT(max_cache)) pool%max_cache=max_cache 00147 pool%max_cache=MIN(max_max_cache,pool%max_cache) 00148 IF (debug_this_module) THEN 00149 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00150 fmt="(' *** pw_pool ',i4,' has been created')") pool%id_nr 00151 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00152 END IF 00153 NULLIFY(pool%real1d_pw, pool%real3d_pw, & 00154 pool%complex1d_pw, pool%complex3d_pw, pool%real3d_array) 00155 END IF 00156 END SUBROUTINE pw_pool_create 00157 00158 ! ***************************************************************************** 00167 SUBROUTINE pw_pool_retain(pool,error) 00168 TYPE(pw_pool_type), POINTER :: pool 00169 TYPE(cp_error_type), INTENT(inout) :: error 00170 00171 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_retain', 00172 routineP = moduleN//':'//routineN 00173 00174 LOGICAL :: failure 00175 TYPE(cp_logger_type), POINTER :: logger 00176 00177 failure=.FALSE. 00178 logger => cp_error_get_logger(error) 00179 00180 CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) 00181 IF (.NOT. failure) THEN 00182 CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) 00183 00184 pool%ref_count=pool%ref_count+1 00185 IF (debug_this_module) THEN 00186 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00187 fmt="(' *** pw_pool ',i4,' has been retained, ref_count=',i4)")& 00188 pool%id_nr, pool%ref_count 00189 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00190 END IF 00191 END IF 00192 END SUBROUTINE pw_pool_retain 00193 00194 ! ***************************************************************************** 00203 SUBROUTINE pw_pool_flush_cache(pool, error) 00204 TYPE(pw_pool_type), POINTER :: pool 00205 TYPE(cp_error_type), INTENT(inout) :: error 00206 00207 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_flush_cache', 00208 routineP = moduleN//':'//routineN 00209 00210 INTEGER :: stat 00211 LOGICAL :: failure 00212 REAL(kind=dp), DIMENSION(:, :, :), 00213 POINTER :: array_att 00214 TYPE(cp_logger_type), POINTER :: logger 00215 TYPE(cp_sll_3d_r_type), POINTER :: array_iterator 00216 TYPE(cp_sll_pw_type), POINTER :: iterator 00217 TYPE(pw_type), POINTER :: pw_el 00218 00219 failure=.FALSE. 00220 00221 CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) 00222 CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) 00223 NULLIFY(iterator,array_iterator,pw_el,array_att) 00224 logger => cp_error_get_logger(error) 00225 IF (.NOT.failure) THEN 00226 IF (debug_this_module) THEN 00227 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00228 fmt="(' *** pw_pool ',i4,' is flushing the cache')") pool%id_nr 00229 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00230 END IF 00231 00232 iterator => pool%real1d_pw 00233 DO 00234 IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT 00235 CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) 00236 pw_el%ref_count=1 00237 CALL pw_release(pw_el,error=error) 00238 END DO 00239 CALL cp_sll_pw_dealloc(pool%real1d_pw,error=error) 00240 00241 iterator => pool%real3d_pw 00242 DO 00243 IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT 00244 CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) 00245 pw_el%ref_count=1 00246 CALL pw_release(pw_el, error=error) 00247 END DO 00248 CALL cp_sll_pw_dealloc(pool%real3d_pw,error=error) 00249 00250 iterator => pool%complex1d_pw 00251 DO 00252 IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT 00253 CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) 00254 pw_el%ref_count=1 00255 CALL pw_release(pw_el, error=error) 00256 END DO 00257 CALL cp_sll_pw_dealloc(pool%complex1d_pw,error=error) 00258 00259 iterator => pool%complex3d_pw 00260 DO 00261 IF (.NOT.cp_sll_pw_next(iterator,el_att=pw_el,error=error)) EXIT 00262 CPPrecondition(pw_el%ref_count==0,cp_failure_level,routineP,error,failure) 00263 pw_el%ref_count=1 00264 CALL pw_release(pw_el, error=error) 00265 END DO 00266 CALL cp_sll_pw_dealloc(pool%complex3d_pw,error=error) 00267 00268 array_iterator => pool%real3d_array 00269 DO 00270 IF (.NOT.cp_sll_3d_r_next(array_iterator,el_att=array_att,& 00271 error=error)) EXIT 00272 DEALLOCATE(array_att,stat=stat) 00273 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00274 END DO 00275 CALL cp_sll_3d_r_dealloc(pool%real3d_array,error=error) 00276 00277 END IF 00278 END SUBROUTINE pw_pool_flush_cache 00279 00280 ! ***************************************************************************** 00289 SUBROUTINE pw_pool_release(pool,error) 00290 TYPE(pw_pool_type), POINTER :: pool 00291 TYPE(cp_error_type), INTENT(inout) :: error 00292 00293 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_release', 00294 routineP = moduleN//':'//routineN 00295 00296 INTEGER :: stat 00297 LOGICAL :: failure 00298 TYPE(cp_logger_type), POINTER :: logger 00299 00300 failure=.FALSE. 00301 logger => cp_error_get_logger(error) 00302 00303 IF (ASSOCIATED(pool)) THEN 00304 CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) 00305 pool%ref_count=pool%ref_count-1 00306 IF (debug_this_module) THEN 00307 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00308 fmt="(' *** pw_pool ',i4,' released ref_count=',i4)") & 00309 pool%id_nr, pool%ref_count 00310 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00311 END IF 00312 IF (pool%ref_count==0) THEN 00313 pool%ref_count=1 00314 CALL pw_pool_flush_cache(pool,error=error) 00315 pool%ref_count=0 00316 CPPrecondition(ASSOCIATED(pool%pw_grid),cp_warning_level,routineP,error,failure) 00317 IF (.NOT.failure) THEN 00318 CALL pw_grid_release(pool%pw_grid,error=error) 00319 END IF 00320 00321 DEALLOCATE(pool,stat=stat) 00322 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00323 END IF 00324 END IF 00325 NULLIFY(pool) 00326 END SUBROUTINE pw_pool_release 00327 00328 ! ***************************************************************************** 00337 FUNCTION try_pop(list,error) RESULT(res) 00338 TYPE(cp_sll_pw_type), POINTER :: list 00339 TYPE(cp_error_type), INTENT(inout) :: error 00340 TYPE(pw_type), POINTER :: res 00341 00342 IF (ASSOCIATED(list)) THEN 00343 res => cp_sll_pw_get_first_el(list,error=error) 00344 CALL cp_sll_pw_rm_first_el(list,error=error) 00345 ELSE 00346 NULLIFY(res) 00347 END IF 00348 END FUNCTION try_pop 00349 00350 ! ***************************************************************************** 00363 SUBROUTINE pw_pool_create_pw(pool, pw, use_data, in_space, error) 00364 TYPE(pw_pool_type), POINTER :: pool 00365 TYPE(pw_type), POINTER :: pw 00366 INTEGER, INTENT(in) :: use_data 00367 INTEGER, INTENT(in), OPTIONAL :: in_space 00368 TYPE(cp_error_type), INTENT(inout) :: error 00369 00370 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_create_pw', 00371 routineP = moduleN//':'//routineN 00372 00373 INTEGER :: handle 00374 LOGICAL :: failure 00375 REAL(kind=dp), DIMENSION(:, :, :), 00376 POINTER :: cr3d_ptr 00377 TYPE(cp_logger_type), POINTER :: logger 00378 00379 failure=.FALSE. 00380 00381 CALL timeset(routineN,handle) 00382 NULLIFY(pw) 00383 NULLIFY(cr3d_ptr) 00384 logger => cp_error_get_logger(error) 00385 CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) 00386 CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) 00387 00388 SELECT CASE(use_data) 00389 CASE (REALDATA1D) 00390 pw => try_pop(pool%real1d_pw,error=error) 00391 CASE (REALDATA3D) 00392 pw => try_pop(pool%real3d_pw,error=error) 00393 IF (.NOT.ASSOCIATED(pw)) THEN 00394 IF (ASSOCIATED(pool%real3d_array)) THEN 00395 cr3d_ptr => cp_sll_3d_r_get_first_el(pool%real3d_array,error=error) 00396 CALL cp_sll_3d_r_rm_first_el(pool%real3d_array,error=error) 00397 END IF 00398 END IF 00399 CASE (COMPLEXDATA1D) 00400 pw => try_pop(pool%complex1d_pw,error=error) 00401 CASE (COMPLEXDATA3D) 00402 pw => try_pop(pool%complex3d_pw,error=error) 00403 CASE default 00404 ! unknown use_data 00405 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00406 END SELECT 00407 00408 IF (.NOT.ASSOCIATED(pw)) THEN 00409 CALL pw_create(pw, pool%pw_grid, use_data=use_data, & 00410 cr3d_ptr=cr3d_ptr,error=error) 00411 IF (debug_this_module) THEN 00412 IF (ASSOCIATED(cr3d_ptr)) THEN 00413 WRITE(unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00414 fmt="(' *** pw_pool ',i4,' created pw ',i4,'reusing 3dr array')")& 00415 pool%id_nr,pw%id_nr 00416 ELSE 00417 WRITE(unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00418 fmt="(' *** pw_pool ',i4,' created pw ',i4)")& 00419 pool%id_nr,pw%id_nr 00420 END IF 00421 CALL pw_write(& 00422 unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00423 pw=pw, error=error) 00424 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00425 END IF 00426 ELSE 00427 CPPrecondition(pw%ref_count==0,cp_failure_level,routineP,error,failure) 00428 pw%ref_count=1 00429 IF (debug_this_module) THEN 00430 WRITE(unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00431 fmt="(' *** pw_pool ',i4,' created pw reusing old ',i4)")& 00432 pool%id_nr,pw%id_nr 00433 CALL pw_write(& 00434 unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00435 pw=pw, error=error) 00436 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00437 END IF 00438 END IF 00439 00440 pw%in_space=0 00441 IF (PRESENT(in_space)) pw%in_space=in_space 00442 00443 CALL timestop(handle) 00444 00445 END SUBROUTINE pw_pool_create_pw 00446 00447 ! ***************************************************************************** 00460 SUBROUTINE pw_pool_give_back_pw(pool, pw, accept_non_compatible, error) 00461 TYPE(pw_pool_type), POINTER :: pool 00462 TYPE(pw_type), POINTER :: pw 00463 LOGICAL, INTENT(in), OPTIONAL :: accept_non_compatible 00464 TYPE(cp_error_type), INTENT(inout) :: error 00465 00466 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_give_back_pw', 00467 routineP = moduleN//':'//routineN 00468 00469 INTEGER :: handle 00470 LOGICAL :: did_insert, failure, 00471 my_accept_non_compatible 00472 TYPE(cp_logger_type), POINTER :: logger 00473 00474 failure=.FALSE. 00475 my_accept_non_compatible=.FALSE. 00476 logger => cp_error_get_logger(error) 00477 IF (PRESENT(accept_non_compatible)) my_accept_non_compatible=accept_non_compatible 00478 00479 CALL timeset(routineN,handle) 00480 CPPrecondition(ASSOCIATED(pool),cp_failure_level,routineP,error,failure) 00481 CPPrecondition(pool%ref_count>0,cp_failure_level,routineP,error,failure) 00482 IF (.NOT.ASSOCIATED(pw)) THEN 00483 CPPrecondition(my_accept_non_compatible,cp_warning_level,routineP,error,failure) 00484 failure=.TRUE. 00485 END IF 00486 IF (.NOT. failure) THEN 00487 CPPrecondition(pw%ref_count==1,cp_failure_level,routineP,error,failure) 00488 IF (.NOT.pw_grid_compare(pw%pw_grid,pool%pw_grid)) THEN 00489 IF (debug_this_module) THEN 00490 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00491 fmt="(' *** pw_pool ',i4,' giving back incompatible pw ',i4)")& 00492 pool%id_nr, pw%id_nr 00493 CALL pw_write(unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00494 pw=pw,error=error) 00495 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00496 END IF 00497 00498 CALL cp_assert(my_accept_non_compatible,& 00499 cp_failure_level, cp_assertion_failed, routineP,& 00500 "pool cannot reuse pw of another grid "//& 00501 CPSourceFileRef,& 00502 error=error,failure=failure) 00503 CALL pw_release(pw,error=error) 00504 failure=.TRUE. 00505 END IF 00506 END IF 00507 00508 IF (.NOT. failure) THEN 00509 00510 IF (debug_this_module) THEN 00511 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00512 fmt="(' *** pw_pool ',i4,' giving back pw ',i4)")& 00513 pool%id_nr, pw%id_nr 00514 CALL pw_write(unit_nr=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00515 pw=pw,error=error) 00516 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00517 END IF 00518 00519 SELECT CASE(pw%in_use) 00520 CASE(REALDATA1D) 00521 IF (cp_sll_pw_get_length(pool%real1d_pw,error=error)<pool%max_cache) THEN 00522 IF (cp_debug) THEN 00523 CALL cp_sll_pw_insert_ordered(pool%real1d_pw, el=pw,& 00524 insert_equals=.FALSE., did_insert=did_insert,error=error) 00525 CPAssert(did_insert,cp_failure_level,routineP,error,failure) 00526 ELSE 00527 CALL cp_sll_pw_insert_el(pool%real1d_pw, el=pw,error=error) 00528 END IF 00529 ELSE 00530 CALL cp_assert(max_max_cache<0,cp_warning_level,cp_assertion_failed,& 00531 routineP,"hit max_cache"//& 00532 CPSourceFileRef,& 00533 error) 00534 CALL pw_release(pw,error=error) 00535 END IF 00536 CASE(REALDATA3D) 00537 IF (ASSOCIATED(pw%cr3d)) THEN 00538 IF (cp_sll_pw_get_length(pool%real3d_pw,error=error)<pool%max_cache) THEN 00539 IF (cp_debug) THEN 00540 CALL cp_sll_pw_insert_ordered(pool%real3d_pw, el=pw,& 00541 insert_equals=.FALSE., did_insert=did_insert,error=error) 00542 CPAssert(did_insert,cp_failure_level,routineP,error,failure) 00543 ELSE 00544 CALL cp_sll_pw_insert_el(pool%real3d_pw, el=pw, error=error) 00545 END IF 00546 ELSE 00547 CALL cp_assert(max_max_cache<0,cp_warning_level,cp_assertion_failed,& 00548 routineP,"hit max_cache"//& 00549 CPSourceFileRef,& 00550 error) 00551 CALL pw_release(pw,error=error) 00552 END IF 00553 ELSE 00554 IF (debug_this_module) THEN 00555 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00556 fmt="(' *** pw_pool ',i4,' pw ',i4,' cr3d is not associated, discarding')")& 00557 pool%id_nr, pw%id_nr 00558 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00559 END IF 00560 CPAssert(my_accept_non_compatible,cp_failure_level,routineP,error,failure) 00561 CALL pw_release(pw, error=error) 00562 END IF 00563 CASE(COMPLEXDATA1D) 00564 IF (cp_sll_pw_get_length(pool%complex1d_pw,error=error)<pool%max_cache) THEN 00565 IF (cp_debug) THEN 00566 CALL cp_sll_pw_insert_ordered(pool%complex1d_pw, el=pw,& 00567 insert_equals=.FALSE., did_insert=did_insert,error=error) 00568 CPAssert(did_insert,cp_failure_level,routineP,error,failure) 00569 ELSE 00570 CALL cp_sll_pw_insert_el(pool%complex1d_pw, el=pw,error=error) 00571 END IF 00572 ELSE 00573 CALL cp_assert(max_max_cache<0,cp_warning_level,cp_assertion_failed,& 00574 routineP,"hit max_cache"//& 00575 CPSourceFileRef,& 00576 error) 00577 CALL pw_release(pw,error=error) 00578 END IF 00579 CASE(COMPLEXDATA3D) 00580 IF (cp_sll_pw_get_length(pool%complex3d_pw,error=error)<pool%max_cache) THEN 00581 IF (cp_debug) THEN 00582 CALL cp_sll_pw_insert_ordered(pool%complex3d_pw, el=pw,& 00583 insert_equals=.FALSE., did_insert=did_insert,error=error) 00584 CPAssert(did_insert,cp_failure_level,routineP,error,failure) 00585 ELSE 00586 CALL cp_sll_pw_insert_el(pool%complex3d_pw, el=pw,error=error) 00587 END IF 00588 ELSE 00589 CALL cp_assert(max_max_cache<0,cp_warning_level,cp_assertion_failed,& 00590 routineP,"hit max_cache"//& 00591 CPSourceFileRef,& 00592 error) 00593 CALL pw_release(pw,error=error) 00594 END IF 00595 CASE default 00596 ! unknown in_use 00597 CPAssert(.FALSE.,cp_failure_level,routineP,error,failure) 00598 END SELECT 00599 IF (ASSOCIATED(pw)) pw%ref_count=0 00600 !FM so that if someone tries to use a pw that is in the pool 00601 !FM (s)he gets problems 00602 END IF 00603 NULLIFY(pw) 00604 CALL timestop(handle) 00605 END SUBROUTINE pw_pool_give_back_pw 00606 00607 ! ***************************************************************************** 00618 SUBROUTINE pw_pool_create_cr3d(pw_pool,cr3d,error) 00619 TYPE(pw_pool_type), POINTER :: pw_pool 00620 REAL(kind=dp), DIMENSION(:, :, :), 00621 POINTER :: cr3d 00622 TYPE(cp_error_type), INTENT(inout) :: error 00623 00624 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_create_cr3d', 00625 routineP = moduleN//':'//routineN 00626 00627 INTEGER :: stat 00628 LOGICAL :: failure 00629 TYPE(cp_logger_type), POINTER :: logger 00630 TYPE(pw_type), POINTER :: pw 00631 00632 failure=.FALSE. 00633 NULLIFY(pw) 00634 logger => cp_error_get_logger(error) 00635 00636 CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) 00637 CPPrecondition(pw_pool%ref_count>0,cp_failure_level,routineP,error,failure) 00638 CPPrecondition(.NOT.ASSOCIATED(cr3d),cp_failure_level,routineP,error,failure) 00639 IF (.NOT. failure) THEN 00640 IF (ASSOCIATED(pw_pool%real3d_array)) THEN 00641 cr3d => cp_sll_3d_r_get_first_el(pw_pool%real3d_array,error=error) 00642 CALL cp_sll_3d_r_rm_first_el(pw_pool%real3d_array,error=error) 00643 ELSE 00644 pw => try_pop(pw_pool%real3d_pw,error=error) 00645 IF (ASSOCIATED(pw)) THEN 00646 CPPrecondition(pw%ref_count==0,cp_failure_level,routineP,error,failure) 00647 pw%ref_count=1 00648 cr3d => pw%cr3d 00649 NULLIFY(pw%cr3d) 00650 CALL pw_release(pw, error=error) 00651 END IF 00652 END IF 00653 IF (.NOT.ASSOCIATED(cr3d)) THEN 00654 ALLOCATE(cr3d(pw_pool%pw_grid%bounds_local(1,1):pw_pool%pw_grid%bounds_local(2,1),& 00655 pw_pool%pw_grid%bounds_local(1,2):pw_pool%pw_grid%bounds_local(2,2),& 00656 pw_pool%pw_grid%bounds_local(1,3):pw_pool%pw_grid%bounds_local(2,3)),& 00657 stat=stat) 00658 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00659 IF (debug_this_module) THEN 00660 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00661 fmt="(' *** pw_pool ',i4,' created cr3d at 0x',z16.16)")& 00662 pw_pool%id_nr, m_loc_r(cr3d) 00663 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00664 END IF 00665 ELSEIF (debug_this_module) THEN 00666 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00667 fmt="(' *** pw_pool ',i4,' created cr3d reusing the one at 0x',z16.16)")& 00668 pw_pool%id_nr, m_loc_r(cr3d) 00669 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00670 END IF 00671 END IF 00672 END SUBROUTINE pw_pool_create_cr3d 00673 00674 ! ***************************************************************************** 00687 SUBROUTINE pw_pool_give_back_cr3d(pw_pool,cr3d,accept_non_compatible,error) 00688 TYPE(pw_pool_type), POINTER :: pw_pool 00689 REAL(kind=dp), DIMENSION(:, :, :), 00690 POINTER :: cr3d 00691 LOGICAL, INTENT(in), OPTIONAL :: accept_non_compatible 00692 TYPE(cp_error_type), INTENT(inout) :: error 00693 00694 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_give_back_cr3d', 00695 routineP = moduleN//':'//routineN 00696 00697 INTEGER :: stat 00698 LOGICAL :: compatible, failure, 00699 my_accept_non_compatible 00700 TYPE(cp_logger_type), POINTER :: logger 00701 00702 failure=.FALSE. 00703 my_accept_non_compatible=.FALSE. 00704 logger => cp_error_get_logger(error) 00705 IF (PRESENT(accept_non_compatible)) my_accept_non_compatible=accept_non_compatible 00706 00707 CPPrecondition(ASSOCIATED(pw_pool),cp_failure_level,routineP,error,failure) 00708 CPPrecondition(pw_pool%ref_count>0,cp_failure_level,routineP,error,failure) 00709 IF (.NOT. failure) THEN 00710 IF (ASSOCIATED(cr3d)) THEN 00711 IF (debug_this_module) THEN 00712 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00713 fmt="(' *** pw_pool ',i4,' received back a cr3d at 0x',z16.16)")& 00714 pw_pool%id_nr, m_loc_r(cr3d) 00715 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00716 END IF 00717 compatible=ALL( MERGE( pw_pool%pw_grid%bounds_local(1,:)==LBOUND(cr3d).AND. & 00718 pw_pool%pw_grid%bounds_local(2,:)==UBOUND(cr3d), & 00719 pw_pool%pw_grid%bounds_local(2,:)<pw_pool%pw_grid%bounds_local(1,:), & 00720 UBOUND(cr3d)>=LBOUND(cr3d) ) ) 00721 CPPrecondition(compatible.OR.my_accept_non_compatible,cp_failure_level,routineP,error,failure) 00722 IF (compatible) THEN 00723 IF (cp_sll_3d_r_get_length(pw_pool%real3d_array,error=error)<pw_pool%max_cache) THEN 00724 CALL cp_sll_3d_r_insert_el(pw_pool%real3d_array, el=cr3d, error=error) 00725 ELSE 00726 CALL cp_assert(max_max_cache<0,cp_warning_level,cp_assertion_failed,& 00727 routineP,"hit max_cache"//& 00728 CPSourceFileRef,& 00729 error) 00730 DEALLOCATE(cr3d, stat=stat) 00731 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00732 END IF 00733 ELSE 00734 IF (debug_this_module) THEN 00735 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00736 fmt="(' *** pw_pool ',i4,' cr3d not accepted, deallocating')")& 00737 pw_pool%id_nr 00738 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00739 END IF 00740 DEALLOCATE(cr3d, stat=stat) 00741 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00742 END IF 00743 ELSE 00744 IF (debug_this_module) THEN 00745 WRITE (unit=cp_logger_get_default_unit_nr(logger,local=.TRUE.),& 00746 fmt="(' *** pw_pool ',i4,' received back a null cr3d')")& 00747 pw_pool%id_nr 00748 CALL print_stack(cp_logger_get_default_unit_nr(logger,local=.TRUE.)) 00749 END IF 00750 CPPrecondition(my_accept_non_compatible,cp_failure_level,routineP,error,failure) 00751 END IF 00752 END IF 00753 NULLIFY(cr3d) 00754 END SUBROUTINE pw_pool_give_back_cr3d 00755 00756 ! ***************************************************************************** 00768 SUBROUTINE pw_pools_create_pws(pools, pws, use_data, in_space, error) 00769 TYPE(pw_pool_p_type), DIMENSION(:), 00770 POINTER :: pools 00771 TYPE(pw_p_type), DIMENSION(:), POINTER :: pws 00772 INTEGER, INTENT(in) :: use_data 00773 INTEGER, INTENT(in), OPTIONAL :: in_space 00774 TYPE(cp_error_type), INTENT(inout) :: error 00775 00776 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_create_pws', 00777 routineP = moduleN//':'//routineN 00778 00779 INTEGER :: i, stat 00780 LOGICAL :: failure 00781 00782 failure=.FALSE. 00783 00784 CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) 00785 ALLOCATE(pws(SIZE(pools)),stat=stat) 00786 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00787 IF (.NOT. failure) THEN 00788 DO i=1,SIZE(pools) 00789 NULLIFY(pws(i)%pw) 00790 CALL pw_pool_create_pw(pools(i)%pool,pws(i)%pw,use_data,& 00791 in_space=in_space,error=error) 00792 END DO 00793 END IF 00794 END SUBROUTINE pw_pools_create_pws 00795 00796 ! ***************************************************************************** 00806 SUBROUTINE pw_pools_give_back_pws(pools, pws, error) 00807 TYPE(pw_pool_p_type), DIMENSION(:), 00808 POINTER :: pools 00809 TYPE(pw_p_type), DIMENSION(:), POINTER :: pws 00810 TYPE(cp_error_type), INTENT(inout) :: error 00811 00812 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_give_back_pws', 00813 routineP = moduleN//':'//routineN 00814 00815 INTEGER :: i, stat 00816 LOGICAL :: failure 00817 00818 failure=.FALSE. 00819 00820 CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) 00821 CPPrecondition(ASSOCIATED(pws),cp_failure_level,routineP,error,failure) 00822 CPPrecondition(SIZE(pws)==SIZE(pools),cp_failure_level,routineP,error,failure) 00823 IF (.NOT. failure) THEN 00824 DO i=1,SIZE(pools) 00825 CALL pw_pool_give_back_pw(pools(i)%pool,pws(i)%pw,error=error) 00826 END DO 00827 DEALLOCATE(pws,stat=stat) 00828 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00829 END IF 00830 END SUBROUTINE pw_pools_give_back_pws 00831 00832 ! ***************************************************************************** 00842 SUBROUTINE pw_pools_copy(source_pools, target_pools, error) 00843 TYPE(pw_pool_p_type), DIMENSION(:), 00844 POINTER :: source_pools, target_pools 00845 TYPE(cp_error_type), INTENT(inout) :: error 00846 00847 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_copy', 00848 routineP = moduleN//':'//routineN 00849 00850 INTEGER :: i, stat 00851 LOGICAL :: failure 00852 00853 failure=.FALSE. 00854 00855 CPPrecondition(ASSOCIATED(source_pools),cp_failure_level,routineP,error,failure) 00856 IF (.NOT. failure) THEN 00857 ALLOCATE(target_pools(SIZE(source_pools)), stat=stat) 00858 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00859 END IF 00860 IF (.NOT.failure) THEN 00861 DO i=1,SIZE(source_pools) 00862 target_pools(i)%pool => source_pools(i)%pool 00863 CALL pw_pool_retain(source_pools(i)%pool, error=error) 00864 END DO 00865 END IF 00866 END SUBROUTINE pw_pools_copy 00867 00868 ! ***************************************************************************** 00878 SUBROUTINE pw_pools_dealloc(pools,error) 00879 TYPE(pw_pool_p_type), DIMENSION(:), 00880 POINTER :: pools 00881 TYPE(cp_error_type), INTENT(inout) :: error 00882 00883 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_dealloc', 00884 routineP = moduleN//':'//routineN 00885 00886 INTEGER :: i, stat 00887 LOGICAL :: failure 00888 00889 failure=.FALSE. 00890 00891 IF (ASSOCIATED(pools)) THEN 00892 DO i=1,SIZE(pools) 00893 CALL pw_pool_release(pools(i)%pool, error=error) 00894 END DO 00895 DEALLOCATE(pools,stat=stat) 00896 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00897 END IF 00898 NULLIFY(pools) 00899 END SUBROUTINE pw_pools_dealloc 00900 00901 ! ***************************************************************************** 00910 SUBROUTINE pw_pools_flush_cache(pools,error) 00911 TYPE(pw_pool_p_type), DIMENSION(:), 00912 POINTER :: pools 00913 TYPE(cp_error_type), INTENT(inout) :: error 00914 00915 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pools_flush_cache', 00916 routineP = moduleN//':'//routineN 00917 00918 INTEGER :: i 00919 LOGICAL :: failure 00920 00921 failure=.FALSE. 00922 00923 CPPrecondition(ASSOCIATED(pools),cp_failure_level,routineP,error,failure) 00924 IF (.NOT. failure) THEN 00925 DO i=1,SIZE(pools) 00926 CALL pw_pool_flush_cache(pools(i)%pool,error=error) 00927 END DO 00928 END IF 00929 END SUBROUTINE pw_pools_flush_cache 00930 00931 ! ***************************************************************************** 00939 SUBROUTINE pw_pool_write(pw_pool,unit_nr,error) 00940 TYPE(pw_pool_type), POINTER :: pw_pool 00941 INTEGER :: unit_nr 00942 TYPE(cp_error_type), INTENT(inout) :: error 00943 00944 CHARACTER(len=*), PARAMETER :: routineN = 'pw_pool_write', 00945 routineP = moduleN//':'//routineN 00946 00947 LOGICAL :: failure 00948 TYPE(cp_sll_pw_type), POINTER :: iter 00949 TYPE(pw_type), POINTER :: pw_att 00950 00951 failure=.FALSE. 00952 00953 IF (ASSOCIATED(pw_pool)) THEN 00954 WRITE (unit=unit_nr, & 00955 fmt="(' <pw_pool>{ id_nr=',i8,', ref_count=',i8,', max_cache=',i8,',')")& 00956 pw_pool%id_nr,pw_pool%ref_count,pw_pool%max_cache 00957 00958 WRITE (unit=unit_nr, fmt="('real1d_pw=(')",advance="no") 00959 iter => pw_pool%real1d_pw 00960 DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) 00961 WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr 00962 END DO 00963 WRITE (unit=unit_nr, fmt="('),')") 00964 00965 WRITE (unit=unit_nr, fmt="('real3d_pw=(')",advance="no") 00966 iter => pw_pool%real3d_pw 00967 DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) 00968 WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr 00969 END DO 00970 WRITE (unit=unit_nr, fmt="('),')") 00971 00972 WRITE (unit=unit_nr, fmt="('complex1d_pw=(')",advance="no") 00973 iter => pw_pool%complex1d_pw 00974 DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) 00975 WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr 00976 END DO 00977 WRITE (unit=unit_nr, fmt="('),')") 00978 00979 WRITE (unit=unit_nr, fmt="('complex3d_pw=(')",advance="no") 00980 iter => pw_pool%complex3d_pw 00981 DO WHILE(cp_sll_pw_next(iter,el_att=pw_att,error=error)) 00982 WRITE (unit=unit_nr, fmt="(i8,',')",advance="no") pw_att%id_nr 00983 END DO 00984 WRITE (unit=unit_nr, fmt="(')')") 00985 00986 WRITE (unit=unit_nr, fmt="('}')") 00987 ELSE 00988 WRITE (unit=unit_nr, fmt="('<pw_pool *null*>')") 00989 END IF 00990 END SUBROUTINE pw_pool_write 00991 00992 END MODULE pw_pool_types
1.7.3