|
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 ! ***************************************************************************** 00012 MODULE qs_matrix_pools 00013 USE cp_fm_pool_types, ONLY: cp_fm_pool_p_type,& 00014 cp_fm_pool_type,& 00015 fm_pool_create,& 00016 fm_pool_get_el_struct,& 00017 fm_pool_release,& 00018 fm_pool_retain,& 00019 fm_pools_copy,& 00020 fm_pools_dealloc 00021 USE cp_fm_struct, ONLY: cp_fm_struct_create,& 00022 cp_fm_struct_get,& 00023 cp_fm_struct_release,& 00024 cp_fm_struct_type 00025 USE cp_para_types, ONLY: cp_blacs_env_type,& 00026 cp_para_env_type 00027 USE f77_blas 00028 USE qs_mo_types, ONLY: get_mo_set,& 00029 mo_set_p_type 00030 USE timings, ONLY: timeset,& 00031 timestop 00032 #include "cp_common_uses.h" 00033 00034 IMPLICIT NONE 00035 PRIVATE 00036 00037 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. 00038 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_matrix_pools' 00039 INTEGER, SAVE, PRIVATE :: last_mpools_id=0 00040 00041 PUBLIC :: qs_matrix_pools_type 00042 PUBLIC :: mpools_retain, mpools_release, mpools_set, mpools_get,& 00043 mpools_create, mpools_rebuild_fm_pools 00044 00045 ! ***************************************************************************** 00070 TYPE qs_matrix_pools_type 00071 INTEGER :: id_nr, ref_count 00072 TYPE(cp_fm_pool_p_type), DIMENSION(:), POINTER :: ao_mo_fm_pools, 00073 ao_ao_fm_pools,mo_mo_fm_pools 00074 TYPE(cp_fm_pool_p_type), DIMENSION(:), POINTER :: ao_mosub_fm_pools, 00075 mosub_mosub_fm_pools 00076 END TYPE qs_matrix_pools_type 00077 00078 CONTAINS 00079 00080 ! ***************************************************************************** 00089 SUBROUTINE mpools_retain(mpools, error) 00090 TYPE(qs_matrix_pools_type), POINTER :: mpools 00091 TYPE(cp_error_type), INTENT(inout) :: error 00092 00093 CHARACTER(len=*), PARAMETER :: routineN = 'mpools_retain', 00094 routineP = moduleN//':'//routineN 00095 00096 LOGICAL :: failure 00097 00098 failure=.FALSE. 00099 00100 CPPrecondition(ASSOCIATED(mpools),cp_failure_level,routineP,error,failure) 00101 IF (.NOT.failure) THEN 00102 CPPreconditionNoFail(mpools%ref_count>0,cp_failure_level,routineP,error) 00103 mpools%ref_count=mpools%ref_count+1 00104 END IF 00105 END SUBROUTINE mpools_retain 00106 00107 ! ***************************************************************************** 00116 SUBROUTINE mpools_release(mpools,error) 00117 TYPE(qs_matrix_pools_type), POINTER :: mpools 00118 TYPE(cp_error_type), INTENT(inout) :: error 00119 00120 CHARACTER(len=*), PARAMETER :: routineN = 'mpools_release', 00121 routineP = moduleN//':'//routineN 00122 00123 INTEGER :: stat 00124 LOGICAL :: failure 00125 00126 failure=.FALSE. 00127 00128 IF (ASSOCIATED(mpools)) THEN 00129 CPPreconditionNoFail(mpools%ref_count>0,cp_failure_level,routineP,error) 00130 mpools%ref_count=mpools%ref_count-1 00131 IF (mpools%ref_count==0) THEN 00132 CALL fm_pools_dealloc(mpools%ao_mo_fm_pools, error=error) 00133 CALL fm_pools_dealloc(mpools%ao_ao_fm_pools, error=error) 00134 CALL fm_pools_dealloc(mpools%mo_mo_fm_pools, error=error) 00135 IF (ASSOCIATED(mpools%ao_mosub_fm_pools)) THEN 00136 CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools,error=error) 00137 END IF 00138 IF (ASSOCIATED(mpools%mosub_mosub_fm_pools)) THEN 00139 CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools,error=error) 00140 END IF 00141 DEALLOCATE(mpools, stat=stat) 00142 CPPostconditionNoFail(stat==0,cp_warning_level,routineP,error) 00143 END IF 00144 END IF 00145 NULLIFY(mpools) 00146 END SUBROUTINE mpools_release 00147 00148 ! ***************************************************************************** 00156 SUBROUTINE mpools_set(mpools,ao_mo_fm_pools,ao_ao_fm_pools,& 00157 mo_mo_fm_pools,ao_mosub_fm_pools,mosub_mosub_fm_pools,& 00158 error) 00159 TYPE(qs_matrix_pools_type), POINTER :: mpools 00160 TYPE(cp_fm_pool_p_type), DIMENSION(:), OPTIONAL, POINTER :: 00161 ao_mo_fm_pools, ao_ao_fm_pools, mo_mo_fm_pools, ao_mosub_fm_pools, 00162 mosub_mosub_fm_pools 00163 TYPE(cp_error_type), INTENT(inout) :: error 00164 00165 CHARACTER(len=*), PARAMETER :: routineN = 'mpools_set', 00166 routineP = moduleN//':'//routineN 00167 00168 LOGICAL :: failure 00169 TYPE(cp_fm_pool_p_type), DIMENSION(:), 00170 POINTER :: new_fm_pools 00171 00172 failure=.FALSE. 00173 NULLIFY(new_fm_pools ) 00174 00175 CPPrecondition(ASSOCIATED(mpools),cp_failure_level,routineP,error,failure) 00176 CPPrecondition(mpools%ref_count>0,cp_failure_level,routineP,error,failure) 00177 IF (.NOT.failure) THEN 00178 IF (PRESENT(ao_mo_fm_pools)) THEN 00179 IF (ASSOCIATED(ao_mo_fm_pools)) THEN 00180 CALL fm_pools_copy(ao_mo_fm_pools,new_fm_pools,error=error) 00181 END IF 00182 CALL fm_pools_dealloc(mpools%ao_mo_fm_pools,error=error) 00183 mpools%ao_mo_fm_pools => new_fm_pools 00184 END IF 00185 IF (PRESENT(ao_ao_fm_pools)) THEN 00186 IF (ASSOCIATED(ao_ao_fm_pools)) THEN 00187 CALL fm_pools_copy(ao_ao_fm_pools,new_fm_pools,error=error) 00188 END IF 00189 CALL fm_pools_dealloc(mpools%ao_ao_fm_pools,error=error) 00190 mpools%ao_ao_fm_pools => new_fm_pools 00191 END IF 00192 IF (PRESENT(mo_mo_fm_pools)) THEN 00193 IF (ASSOCIATED(mo_mo_fm_pools)) THEN 00194 CALL fm_pools_copy(mo_mo_fm_pools,new_fm_pools,error=error) 00195 END IF 00196 CALL fm_pools_dealloc(mpools%mo_mo_fm_pools,error=error) 00197 mpools%mo_mo_fm_pools => new_fm_pools 00198 END IF 00199 IF (PRESENT(ao_mosub_fm_pools)) THEN 00200 IF (ASSOCIATED(ao_mosub_fm_pools)) THEN 00201 CALL fm_pools_copy(ao_mosub_fm_pools,new_fm_pools,error=error) 00202 END IF 00203 CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools,error=error) 00204 mpools%ao_mosub_fm_pools => new_fm_pools 00205 END IF 00206 IF (PRESENT(mosub_mosub_fm_pools)) THEN 00207 IF (ASSOCIATED(mosub_mosub_fm_pools)) THEN 00208 CALL fm_pools_copy(mosub_mosub_fm_pools,new_fm_pools,error=error) 00209 END IF 00210 CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools,error=error) 00211 mpools%mosub_mosub_fm_pools => new_fm_pools 00212 END IF 00213 00214 END IF 00215 END SUBROUTINE mpools_set 00216 00217 ! ***************************************************************************** 00228 SUBROUTINE mpools_get(mpools,ao_mo_fm_pools,ao_ao_fm_pools,& 00229 mo_mo_fm_pools, ao_mosub_fm_pools, mosub_mosub_fm_pools,& 00230 maxao_maxmo_fm_pool, maxao_maxao_fm_pool, maxmo_maxmo_fm_pool,& 00231 error) 00232 TYPE(qs_matrix_pools_type), POINTER :: mpools 00233 TYPE(cp_fm_pool_p_type), DIMENSION(:), OPTIONAL, POINTER :: 00234 ao_mo_fm_pools, ao_ao_fm_pools, mo_mo_fm_pools, ao_mosub_fm_pools, 00235 mosub_mosub_fm_pools 00236 TYPE(cp_fm_pool_type), OPTIONAL, POINTER :: maxao_maxmo_fm_pool, 00237 maxao_maxao_fm_pool, 00238 maxmo_maxmo_fm_pool 00239 TYPE(cp_error_type), INTENT(inout) :: error 00240 00241 CHARACTER(len=*), PARAMETER :: routineN = 'mpools_get', 00242 routineP = moduleN//':'//routineN 00243 00244 LOGICAL :: failure 00245 00246 failure=.FALSE. 00247 00248 IF (.NOT.failure) THEN 00249 IF (PRESENT(ao_mo_fm_pools)) ao_mo_fm_pools => mpools%ao_mo_fm_pools 00250 IF (PRESENT(maxao_maxmo_fm_pool)) THEN 00251 IF (ASSOCIATED(mpools%ao_mo_fm_pools)) THEN 00252 maxao_maxmo_fm_pool => mpools%ao_mo_fm_pools(1)%pool 00253 ELSE 00254 NULLIFY(maxao_maxmo_fm_pool) ! raise an error? 00255 END IF 00256 END IF 00257 IF (PRESENT(ao_ao_fm_pools)) ao_ao_fm_pools => mpools%ao_ao_fm_pools 00258 IF (PRESENT(maxao_maxao_fm_pool)) THEN 00259 IF (ASSOCIATED(mpools%ao_ao_fm_pools)) THEN 00260 maxao_maxao_fm_pool => mpools%ao_ao_fm_pools(1)%pool 00261 ELSE 00262 NULLIFY(maxao_maxao_fm_pool) ! raise an error? 00263 END IF 00264 END IF 00265 IF (PRESENT(mo_mo_fm_pools)) mo_mo_fm_pools => mpools%mo_mo_fm_pools 00266 IF (PRESENT(maxmo_maxmo_fm_pool)) THEN 00267 IF (ASSOCIATED(mpools%mo_mo_fm_pools)) THEN 00268 maxmo_maxmo_fm_pool => mpools%mo_mo_fm_pools(1)%pool 00269 ELSE 00270 NULLIFY(maxmo_maxmo_fm_pool) ! raise an error? 00271 END IF 00272 END IF 00273 IF (PRESENT(ao_mosub_fm_pools)) ao_mosub_fm_pools => mpools%ao_mosub_fm_pools 00274 IF (PRESENT(mosub_mosub_fm_pools)) mosub_mosub_fm_pools => mpools%mosub_mosub_fm_pools 00275 END IF 00276 END SUBROUTINE mpools_get 00277 00278 ! ***************************************************************************** 00287 SUBROUTINE mpools_create(mpools,error) 00288 TYPE(qs_matrix_pools_type), POINTER :: mpools 00289 TYPE(cp_error_type), INTENT(inout) :: error 00290 00291 CHARACTER(len=*), PARAMETER :: routineN = 'mpools_create', 00292 routineP = moduleN//':'//routineN 00293 00294 INTEGER :: stat 00295 LOGICAL :: failure 00296 00297 failure=.FALSE. 00298 00299 ALLOCATE(mpools, stat=stat) 00300 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00301 IF (.NOT.failure) THEN 00302 NULLIFY(mpools%ao_ao_fm_pools, mpools%ao_mo_fm_pools, & 00303 mpools%mo_mo_fm_pools, mpools%ao_mosub_fm_pools, & 00304 mpools%mosub_mosub_fm_pools) 00305 mpools%ref_count=1 00306 last_mpools_id=last_mpools_id+1 00307 mpools%id_nr=last_mpools_id 00308 END IF 00309 END SUBROUTINE mpools_create 00310 00311 ! ***************************************************************************** 00331 SUBROUTINE mpools_rebuild_fm_pools(mpools, mos, blacs_env, para_env,& 00332 nrow_block,ncol_block,nmosub,error) 00333 TYPE(qs_matrix_pools_type), POINTER :: mpools 00334 TYPE(mo_set_p_type), DIMENSION(:), 00335 POINTER :: mos 00336 TYPE(cp_blacs_env_type), POINTER :: blacs_env 00337 TYPE(cp_para_env_type), POINTER :: para_env 00338 INTEGER, INTENT(in) :: nrow_block, ncol_block 00339 INTEGER, DIMENSION(2), INTENT(IN), 00340 OPTIONAL :: nmosub 00341 TYPE(cp_error_type), INTENT(inout) :: error 00342 00343 CHARACTER(len=*), PARAMETER :: routineN = 'mpools_rebuild_fm_pools', 00344 routineP = moduleN//':'//routineN 00345 00346 INTEGER :: handle, ispin, max_nmo, 00347 min_nmo, nao, ncg, nmo, nrg, 00348 nspins, stat 00349 LOGICAL :: failure, prepare_subset, 00350 should_rebuild 00351 TYPE(cp_fm_pool_type), POINTER :: p_att 00352 TYPE(cp_fm_struct_type), POINTER :: fmstruct 00353 00354 CALL timeset(routineN,handle) 00355 00356 failure=.FALSE. 00357 NULLIFY(fmstruct, p_att) 00358 prepare_subset = .FALSE. 00359 IF(PRESENT(nmosub)) THEN 00360 IF(nmosub(1) > 0) prepare_subset = .TRUE. 00361 END IF 00362 00363 CPPrecondition(ASSOCIATED(mos),cp_failure_level,routineP,error,failure) 00364 IF (.NOT.ASSOCIATED(mpools)) THEN 00365 CALL mpools_create(mpools,error=error) 00366 END IF 00367 IF (.NOT.failure) THEN 00368 nspins=SIZE(mos) 00369 00370 IF (ASSOCIATED(mpools%ao_mo_fm_pools)) THEN 00371 IF (nspins/=SIZE(mpools%ao_mo_fm_pools)) THEN 00372 CALL fm_pools_dealloc(mpools%ao_mo_fm_pools,error=error) 00373 END IF 00374 END IF 00375 IF (.NOT.ASSOCIATED(mpools%ao_mo_fm_pools)) THEN 00376 ALLOCATE(mpools%ao_mo_fm_pools(nspins), stat=stat) 00377 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00378 DO ispin=1,nspins 00379 NULLIFY(mpools%ao_mo_fm_pools(ispin)%pool) 00380 END DO 00381 END IF 00382 00383 IF (ASSOCIATED(mpools%ao_ao_fm_pools)) THEN 00384 IF (nspins/=SIZE(mpools%ao_ao_fm_pools)) THEN 00385 CALL fm_pools_dealloc(mpools%ao_ao_fm_pools,error=error) 00386 END IF 00387 END IF 00388 IF (.NOT.ASSOCIATED(mpools%ao_ao_fm_pools)) THEN 00389 ALLOCATE(mpools%ao_ao_fm_pools(nspins), stat=stat) 00390 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00391 DO ispin=1,nspins 00392 NULLIFY(mpools%ao_ao_fm_pools(ispin)%pool) 00393 END DO 00394 END IF 00395 00396 IF (ASSOCIATED(mpools%mo_mo_fm_pools)) THEN 00397 IF (nspins/=SIZE(mpools%mo_mo_fm_pools)) THEN 00398 CALL fm_pools_dealloc(mpools%mo_mo_fm_pools,error=error) 00399 END IF 00400 END IF 00401 IF (.NOT.ASSOCIATED(mpools%mo_mo_fm_pools)) THEN 00402 ALLOCATE(mpools%mo_mo_fm_pools(nspins), stat=stat) 00403 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00404 DO ispin=1,nspins 00405 NULLIFY(mpools%mo_mo_fm_pools(ispin)%pool) 00406 END DO 00407 END IF 00408 00409 IF(prepare_subset) THEN 00410 00411 IF (ASSOCIATED(mpools%ao_mosub_fm_pools)) THEN 00412 IF (nspins/=SIZE(mpools%ao_mosub_fm_pools)) THEN 00413 CALL fm_pools_dealloc(mpools%ao_mosub_fm_pools,error=error) 00414 END IF 00415 END IF 00416 IF (.NOT.ASSOCIATED(mpools%ao_mosub_fm_pools)) THEN 00417 ALLOCATE(mpools%ao_mosub_fm_pools(nspins), stat=stat) 00418 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00419 DO ispin=1,nspins 00420 NULLIFY(mpools%ao_mosub_fm_pools(ispin)%pool) 00421 END DO 00422 END IF 00423 00424 IF (ASSOCIATED(mpools%mosub_mosub_fm_pools)) THEN 00425 IF (nspins/=SIZE(mpools%mosub_mosub_fm_pools)) THEN 00426 CALL fm_pools_dealloc(mpools%mosub_mosub_fm_pools,error=error) 00427 END IF 00428 END IF 00429 IF (.NOT.ASSOCIATED(mpools%mosub_mosub_fm_pools)) THEN 00430 ALLOCATE(mpools%mosub_mosub_fm_pools(nspins), stat=stat) 00431 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00432 DO ispin=1,nspins 00433 NULLIFY(mpools%mosub_mosub_fm_pools(ispin)%pool) 00434 END DO 00435 END IF 00436 00437 END IF ! prepare_subset 00438 00439 END IF 00440 00441 00442 IF (.NOT.failure) THEN 00443 CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=min_nmo) 00444 max_nmo=min_nmo 00445 DO ispin=2,SIZE(mos) 00446 CALL get_mo_set(mos(ispin)%mo_set,nmo=nmo) 00447 IF (max_nmo<nmo) THEN 00448 CALL cp_assert(.FALSE.,cp_failure_level,cp_assertion_failed,& 00449 routineP,& 00450 "the mo with the most orbitals must be the first "//& 00451 CPSourceFileRef,& 00452 error=error,& 00453 failure=failure) 00454 END IF 00455 min_nmo=MIN(min_nmo,nmo) 00456 END DO 00457 END IF 00458 00459 IF (.NOT.failure) THEN 00460 ! aoao pools 00461 should_rebuild=.FALSE. 00462 DO ispin=1,nspins 00463 p_att => mpools%ao_ao_fm_pools(ispin)%pool 00464 should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) 00465 IF (.NOT.should_rebuild) THEN 00466 fmstruct => fm_pool_get_el_struct(mpools%ao_ao_fm_pools(ispin)%pool,& 00467 error=error) 00468 CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& 00469 ncol_global=ncg,error=error) 00470 CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=nmo) 00471 should_rebuild = nao/=nrg.OR.nao/=ncg 00472 END IF 00473 END DO 00474 IF (should_rebuild) THEN 00475 DO ispin=1,nspins 00476 CALL fm_pool_release(mpools%ao_ao_fm_pools(ispin)%pool,error=error) 00477 END DO 00478 00479 CALL cp_fm_struct_create(fmstruct, nrow_global=nao,& 00480 ncol_global=nao, para_env=para_env,& 00481 context=blacs_env,& 00482 nrow_block=nrow_block,& 00483 ncol_block=ncol_block,error=error) 00484 CALL fm_pool_create(mpools%ao_ao_fm_pools(1)%pool,fmstruct,error=error) 00485 CALL cp_fm_struct_release(fmstruct,error=error) 00486 DO ispin=2,SIZE(mos) 00487 mpools%ao_ao_fm_pools(ispin)%pool => mpools%ao_ao_fm_pools(1)%pool 00488 CALL fm_pool_retain(mpools%ao_ao_fm_pools(1)%pool,error=error) 00489 END DO 00490 END IF 00491 00492 ! aomo pools 00493 should_rebuild=.FALSE. 00494 DO ispin=1,nspins 00495 p_att => mpools%ao_mo_fm_pools(ispin)%pool 00496 should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) 00497 IF (.NOT.should_rebuild) THEN 00498 fmstruct => fm_pool_get_el_struct(mpools%ao_mo_fm_pools(ispin)& 00499 %pool,error=error) 00500 CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& 00501 ncol_global=ncg,error=error) 00502 CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=nmo) 00503 should_rebuild = nao/=nrg.OR.nmo/=ncg 00504 END IF 00505 END DO 00506 IF (should_rebuild) THEN 00507 DO ispin=1,nspins 00508 CALL fm_pool_release(mpools%ao_mo_fm_pools(ispin)%pool,error=error) 00509 END DO 00510 00511 IF (max_nmo==min_nmo) THEN 00512 CALL cp_fm_struct_create(fmstruct, nrow_global=nao,& 00513 ncol_global=max_nmo, para_env=para_env,& 00514 context=blacs_env,& 00515 nrow_block=nrow_block,& 00516 ncol_block=ncol_block,error=error) 00517 CALL fm_pool_create(mpools%ao_mo_fm_pools(1)%pool,fmstruct,error=error) 00518 CALL cp_fm_struct_release(fmstruct,error=error) 00519 DO ispin=2,SIZE(mos) 00520 mpools%ao_mo_fm_pools(ispin)%pool => mpools%ao_mo_fm_pools(1)%pool 00521 CALL fm_pool_retain(mpools%ao_mo_fm_pools(1)%pool,error=error) 00522 END DO 00523 ELSE 00524 DO ispin=1,SIZE(mos) 00525 CALL get_mo_set(mos(ispin)%mo_set,nmo=nmo,nao=nao) 00526 CALL cp_fm_struct_create(fmstruct, nrow_global=nao,& 00527 ncol_global=nmo, para_env=para_env,& 00528 context=blacs_env,& 00529 nrow_block=nrow_block,& 00530 ncol_block=ncol_block,error=error) 00531 CALL fm_pool_create(mpools%ao_mo_fm_pools(ispin)%pool,& 00532 fmstruct,error=error) 00533 CALL cp_fm_struct_release(fmstruct,error=error) 00534 END DO 00535 END IF 00536 END IF 00537 00538 ! momo pools 00539 should_rebuild=.FALSE. 00540 DO ispin=1,nspins 00541 p_att => mpools%mo_mo_fm_pools(ispin)%pool 00542 should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) 00543 IF (.NOT.should_rebuild) THEN 00544 fmstruct => fm_pool_get_el_struct(p_att,error=error) 00545 CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& 00546 ncol_global=ncg,error=error) 00547 CALL get_mo_set(mos(1)%mo_set,nao=nao,nmo=nmo) 00548 should_rebuild = nmo/=nrg.OR.nmo/=ncg 00549 END IF 00550 END DO 00551 IF (should_rebuild) THEN 00552 DO ispin=1,nspins 00553 CALL fm_pool_release(mpools%mo_mo_fm_pools(ispin)%pool,error=error) 00554 END DO 00555 00556 IF (max_nmo==min_nmo) THEN 00557 CALL cp_fm_struct_create(fmstruct, nrow_global=max_nmo,& 00558 ncol_global=max_nmo, para_env=para_env,& 00559 context=blacs_env,& 00560 nrow_block=nrow_block,& 00561 ncol_block=ncol_block,error=error) 00562 CALL fm_pool_create(mpools%mo_mo_fm_pools(1)%pool,& 00563 fmstruct,error=error) 00564 CALL cp_fm_struct_release(fmstruct,error=error) 00565 DO ispin=2,SIZE(mos) 00566 mpools%mo_mo_fm_pools(ispin)%pool => mpools%mo_mo_fm_pools(1)%pool 00567 CALL fm_pool_retain(mpools%mo_mo_fm_pools(1)%pool,error=error) 00568 END DO 00569 ELSE 00570 DO ispin=1,SIZE(mos) 00571 NULLIFY(mpools%mo_mo_fm_pools(ispin)%pool) 00572 CALL get_mo_set(mos(ispin)%mo_set,nmo=nmo,nao=nao) 00573 CALL cp_fm_struct_create(fmstruct, nrow_global=nmo,& 00574 ncol_global=nmo, para_env=para_env,& 00575 context=blacs_env,& 00576 nrow_block=nrow_block,& 00577 ncol_block=ncol_block,error=error) 00578 CALL fm_pool_create(mpools%mo_mo_fm_pools(ispin)%pool,& 00579 fmstruct,error=error) 00580 CALL cp_fm_struct_release(fmstruct,error=error) 00581 END DO 00582 END IF 00583 END IF 00584 00585 IF(prepare_subset) THEN 00586 ! aomosub pools 00587 should_rebuild=.FALSE. 00588 DO ispin=1,nspins 00589 p_att => mpools%ao_mosub_fm_pools(ispin)%pool 00590 should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) 00591 IF (.NOT.should_rebuild) THEN 00592 fmstruct => fm_pool_get_el_struct(mpools%ao_mosub_fm_pools(ispin)& 00593 %pool,error=error) 00594 CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& 00595 ncol_global=ncg,error=error) 00596 CALL get_mo_set(mos(1)%mo_set,nao=nao) 00597 should_rebuild = nao/=nrg .OR. nmosub(ispin)/=ncg 00598 END IF 00599 END DO 00600 IF (should_rebuild) THEN 00601 DO ispin=1,nspins 00602 CALL fm_pool_release(mpools%ao_mosub_fm_pools(ispin)%pool,error=error) 00603 END DO 00604 00605 IF (nspins==1 .OR. nmosub(1)==nmosub(2)) THEN 00606 CALL cp_fm_struct_create(fmstruct, nrow_global=nao,& 00607 ncol_global=nmosub(1), para_env=para_env,& 00608 context=blacs_env,& 00609 nrow_block=nrow_block,& 00610 ncol_block=ncol_block,error=error) 00611 CALL fm_pool_create(mpools%ao_mosub_fm_pools(1)%pool,fmstruct,error=error) 00612 CALL cp_fm_struct_release(fmstruct,error=error) 00613 DO ispin=2,SIZE(mos) 00614 mpools%ao_mosub_fm_pools(ispin)%pool => mpools%ao_mosub_fm_pools(1)%pool 00615 CALL fm_pool_retain(mpools%ao_mosub_fm_pools(1)%pool,error=error) 00616 END DO 00617 ELSE 00618 DO ispin=1,SIZE(mos) 00619 CALL get_mo_set(mos(ispin)%mo_set,nao=nao) 00620 CALL cp_fm_struct_create(fmstruct, nrow_global=nao,& 00621 ncol_global=nmosub(1), para_env=para_env,& 00622 context=blacs_env,& 00623 nrow_block=nrow_block,& 00624 ncol_block=ncol_block,error=error) 00625 CALL fm_pool_create(mpools%ao_mosub_fm_pools(ispin)%pool,& 00626 fmstruct,error=error) 00627 CALL cp_fm_struct_release(fmstruct,error=error) 00628 END DO 00629 END IF 00630 END IF ! should_rebuild 00631 00632 ! mosubmosub pools 00633 should_rebuild=.FALSE. 00634 DO ispin=1,nspins 00635 p_att => mpools%mosub_mosub_fm_pools(ispin)%pool 00636 should_rebuild = (should_rebuild.OR.(.NOT.ASSOCIATED(p_att))) 00637 IF (.NOT.should_rebuild) THEN 00638 fmstruct => fm_pool_get_el_struct(p_att,error=error) 00639 CALL cp_fm_struct_get(fmstruct, nrow_global=nrg,& 00640 ncol_global=ncg,error=error) 00641 should_rebuild = nmosub(ispin)/=nrg .OR. nmosub(ispin)/=ncg 00642 END IF 00643 END DO 00644 IF (should_rebuild) THEN 00645 DO ispin=1,nspins 00646 CALL fm_pool_release(mpools%mosub_mosub_fm_pools(ispin)%pool,error=error) 00647 END DO 00648 00649 IF ( nspins ==1 .OR. nmosub(1)==nmosub(2)) THEN 00650 CALL cp_fm_struct_create(fmstruct, nrow_global=nmosub(1),& 00651 ncol_global=nmosub(1), para_env=para_env,& 00652 context=blacs_env,& 00653 nrow_block=nrow_block,& 00654 ncol_block=ncol_block,error=error) 00655 CALL fm_pool_create(mpools%mosub_mosub_fm_pools(1)%pool,& 00656 fmstruct,error=error) 00657 CALL cp_fm_struct_release(fmstruct,error=error) 00658 DO ispin=2,SIZE(mos) 00659 mpools%mosub_mosub_fm_pools(ispin)%pool => mpools%mosub_mosub_fm_pools(1)%pool 00660 CALL fm_pool_retain(mpools%mosub_mosub_fm_pools(1)%pool,error=error) 00661 END DO 00662 ELSE 00663 DO ispin=1,SIZE(mos) 00664 NULLIFY(mpools%mosub_mosub_fm_pools(ispin)%pool) 00665 CALL cp_fm_struct_create(fmstruct, nrow_global=nmosub(ispin),& 00666 ncol_global=nmosub(ispin), para_env=para_env,& 00667 context=blacs_env,& 00668 nrow_block=nrow_block,& 00669 ncol_block=ncol_block,error=error) 00670 CALL fm_pool_create(mpools%mosub_mosub_fm_pools(ispin)%pool,& 00671 fmstruct,error=error) 00672 CALL cp_fm_struct_release(fmstruct,error=error) 00673 END DO 00674 END IF 00675 END IF ! should_rebuild 00676 END IF ! prepare_subset 00677 00678 END IF 00679 00680 CALL timestop(handle) 00681 END SUBROUTINE mpools_rebuild_fm_pools 00682 00683 ! ***************************************************************************** 00684 00685 END MODULE qs_matrix_pools 00686
1.7.3