|
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 ! ***************************************************************************** 00015 MODULE cp_result_methods 00016 USE cp_para_types, ONLY: cp_para_env_type 00017 USE cp_result_types, ONLY: & 00018 cp_result_clean, cp_result_copy, cp_result_create, cp_result_release, & 00019 cp_result_type, cp_result_value_copy, cp_result_value_create, & 00020 cp_result_value_init, cp_result_value_p_reallocate 00021 USE f77_blas 00022 USE input_val_types, ONLY: integer_t,& 00023 logical_t,& 00024 real_t 00025 USE kinds, ONLY: default_string_length,& 00026 dp 00027 USE memory_utilities, ONLY: reallocate 00028 USE message_passing, ONLY: mp_bcast 00029 #include "cp_common_uses.h" 00030 00031 IMPLICIT NONE 00032 PRIVATE 00033 00034 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'cp_result_methods' 00035 00036 PUBLIC :: put_results,& 00037 get_results,& 00038 cp_results_erase,& 00039 cp_results_mp_bcast 00040 00041 INTERFACE put_results 00042 MODULE PROCEDURE put_result_r1, put_result_r2 00043 END INTERFACE 00044 00045 INTERFACE get_results 00046 MODULE PROCEDURE get_result_r1, get_result_r2, get_nreps 00047 END INTERFACE 00048 00049 CONTAINS 00050 00051 ! ***************************************************************************** 00058 SUBROUTINE put_result_r1(results,description,values,error) 00059 TYPE(cp_result_type), POINTER :: results 00060 CHARACTER(LEN=default_string_length) :: description 00061 REAL(KIND=dp), DIMENSION(:) :: values 00062 TYPE(cp_error_type), INTENT(inout) :: error 00063 00064 CHARACTER(len=*), PARAMETER :: routineN = 'put_result_r1', 00065 routineP = moduleN//':'//routineN 00066 00067 INTEGER :: isize, jsize 00068 LOGICAL :: check, failure 00069 00070 failure=.FALSE. 00071 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00072 CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) 00073 check = SIZE(results%result_label)==SIZE(results%result_value) 00074 CPPostcondition(check,cp_failure_level,routineP,error,failure) 00075 isize=SIZE(results%result_label) 00076 jsize=SIZE(values) 00077 00078 CALL reallocate(results%result_label,1,isize+1) 00079 CALL cp_result_value_p_reallocate(results%result_value,1,isize+1,error) 00080 00081 results%result_label(isize+1) = description 00082 CALL cp_result_value_init(results%result_value(isize+1)%value, real_t, jsize, error) 00083 results%result_value(isize+1)%value%real_type = values 00084 00085 END SUBROUTINE put_result_r1 00086 00087 ! ***************************************************************************** 00094 SUBROUTINE put_result_r2(results,description,values,error) 00095 TYPE(cp_result_type), POINTER :: results 00096 CHARACTER(LEN=default_string_length) :: description 00097 REAL(KIND=dp), DIMENSION(:, :) :: values 00098 TYPE(cp_error_type), INTENT(inout) :: error 00099 00100 CHARACTER(len=*), PARAMETER :: routineN = 'put_result_r2', 00101 routineP = moduleN//':'//routineN 00102 00103 INTEGER :: isize, jsize 00104 LOGICAL :: check, failure 00105 00106 failure=.FALSE. 00107 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00108 CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) 00109 check = SIZE(results%result_label)==SIZE(results%result_value) 00110 CPPostcondition(check,cp_failure_level,routineP,error,failure) 00111 isize=SIZE(results%result_label) 00112 jsize=SIZE(values,1)*SIZE(values,2) 00113 00114 CALL reallocate(results%result_label,1,isize+1) 00115 CALL cp_result_value_p_reallocate(results%result_value,1,isize+1,error) 00116 00117 results%result_label(isize+1) = description 00118 CALL cp_result_value_init(results%result_value(isize+1)%value, real_t, jsize, error) 00119 results%result_value(isize+1)%value%real_type = RESHAPE(values,(/jsize/)) 00120 00121 END SUBROUTINE put_result_r2 00122 00123 ! ***************************************************************************** 00134 SUBROUTINE get_result_r1(results,description,values,nval,n_rep,n_entries,error) 00135 TYPE(cp_result_type), POINTER :: results 00136 CHARACTER(LEN=default_string_length) :: description 00137 REAL(KIND=dp), DIMENSION(:) :: values 00138 INTEGER, OPTIONAL :: nval, n_rep, n_entries 00139 TYPE(cp_error_type), INTENT(inout) :: error 00140 00141 CHARACTER(len=*), PARAMETER :: routineN = 'get_result_r1', 00142 routineP = moduleN//':'//routineN 00143 00144 INTEGER :: i, k, nlist, nrep, size_res, 00145 size_values 00146 LOGICAL :: failure 00147 00148 failure = .FALSE. 00149 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00150 nlist=SIZE(results%result_value) 00151 CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) 00152 CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,error,failure) 00153 nrep = 0 00154 DO i = 1, nlist 00155 IF(TRIM(results%result_label(i))==TRIM(description)) nrep = nrep + 1 00156 END DO 00157 00158 IF(PRESENT(n_rep))THEN 00159 n_rep=nrep 00160 END IF 00161 00162 CALL cp_assert(nrep.GT.0,cp_failure_level,cp_assertion_failed,routineP,& 00163 " Trying to access result ("//TRIM(description)//") which was never stored! "//& 00164 CPSourceFileRef,& 00165 only_ionode=.TRUE.) 00166 00167 DO i=1,nlist 00168 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00169 CALL cp_assert(results%result_value(i)%value%type_in_use==real_t,& 00170 cp_failure_level,cp_assertion_failed,routineP,& 00171 "Attempt to retrieve a RESULT which is not a REAL! "//& 00172 CPSourceFileRef,& 00173 only_ionode=.TRUE.) 00174 00175 size_res=SIZE(results%result_value(i)%value%real_type) 00176 EXIT 00177 END IF 00178 END DO 00179 IF(PRESENT(n_entries)) n_entries = size_res 00180 size_values = SIZE(values,1) 00181 IF(PRESENT(nval))THEN 00182 CPPostcondition(size_res==size_values,cp_failure_level,routineP,error,failure) 00183 ELSE 00184 CPPostcondition(nrep*size_res==size_values,cp_failure_level,routineP,error,failure) 00185 END IF 00186 k=0 00187 DO i = 1,nlist 00188 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00189 k = k + 1 00190 IF(PRESENT(nval))THEN 00191 IF(k==nval)THEN 00192 values = results%result_value(i)%value%real_type 00193 EXIT 00194 END IF 00195 ELSE 00196 values((k-1)*size_res+1:k*size_res) = results%result_value(i)%value%real_type 00197 END IF 00198 END IF 00199 END DO 00200 00201 END SUBROUTINE get_result_r1 00202 00203 ! ***************************************************************************** 00214 SUBROUTINE get_result_r2(results,description,values,nval,n_rep,n_entries,error) 00215 TYPE(cp_result_type), POINTER :: results 00216 CHARACTER(LEN=default_string_length) :: description 00217 REAL(KIND=dp), DIMENSION(:, :) :: values 00218 INTEGER, OPTIONAL :: nval, n_rep, n_entries 00219 TYPE(cp_error_type), INTENT(inout) :: error 00220 00221 CHARACTER(len=*), PARAMETER :: routineN = 'get_result_r2', 00222 routineP = moduleN//':'//routineN 00223 00224 INTEGER :: i, k, nlist, nrep, size_res, 00225 size_values 00226 LOGICAL :: failure 00227 00228 failure = .FALSE. 00229 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00230 nlist=SIZE(results%result_value) 00231 CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) 00232 CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,error,failure) 00233 nrep = 0 00234 DO i = 1, nlist 00235 IF(TRIM(results%result_label(i))==TRIM(description)) nrep = nrep + 1 00236 END DO 00237 00238 IF(PRESENT(n_rep))THEN 00239 n_rep=nrep 00240 END IF 00241 00242 CALL cp_assert(nrep.GT.0,cp_failure_level,cp_assertion_failed,routineP,& 00243 " Trying to access result ("//TRIM(description)//") which was never stored! "//& 00244 CPSourceFileRef,& 00245 only_ionode=.TRUE.) 00246 00247 DO i=1,nlist 00248 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00249 CALL cp_assert(results%result_value(i)%value%type_in_use==real_t,& 00250 cp_failure_level,cp_assertion_failed,routineP,& 00251 "Attempt to retrieve a RESULT which is not a REAL! "//& 00252 CPSourceFileRef,& 00253 only_ionode=.TRUE.) 00254 00255 size_res=SIZE(results%result_value(i)%value%real_type) 00256 EXIT 00257 END IF 00258 END DO 00259 IF(PRESENT(n_entries)) n_entries = size_res 00260 size_values = SIZE(values,1)*SIZE(values,2) 00261 IF(PRESENT(nval))THEN 00262 CPPostcondition(size_res==size_values,cp_failure_level,routineP,error,failure) 00263 ELSE 00264 CPPostcondition(nrep*size_res==size_values,cp_failure_level,routineP,error,failure) 00265 END IF 00266 k=0 00267 DO i = 1,nlist 00268 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00269 k = k + 1 00270 IF(PRESENT(nval))THEN 00271 IF(k==nval)THEN 00272 values = RESHAPE(results%result_value(i)%value%real_type,(/SIZE(values,1),SIZE(values,2)/)) 00273 EXIT 00274 END IF 00275 ELSE 00276 values((k-1)*size_res+1:k*size_res,:) = RESHAPE(results%result_value(i)%value%real_type,& 00277 (/SIZE(values,1),SIZE(values,2)/)) 00278 END IF 00279 END IF 00280 END DO 00281 00282 END SUBROUTINE get_result_r2 00283 00284 ! ***************************************************************************** 00293 SUBROUTINE get_nreps(results,description,n_rep,n_entries,type_in_use,error) 00294 TYPE(cp_result_type), POINTER :: results 00295 CHARACTER(LEN=default_string_length) :: description 00296 INTEGER, OPTIONAL :: n_rep, n_entries, type_in_use 00297 TYPE(cp_error_type), INTENT(inout) :: error 00298 00299 CHARACTER(len=*), PARAMETER :: routineN = 'get_nreps', 00300 routineP = moduleN//':'//routineN 00301 00302 INTEGER :: I, nlist 00303 LOGICAL :: failure 00304 00305 failure = .FALSE. 00306 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00307 nlist=SIZE(results%result_value) 00308 CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) 00309 CPPostcondition(SIZE(results%result_label)==nlist,cp_failure_level,routineP,error,failure) 00310 IF(PRESENT(n_rep))THEN 00311 n_rep=0 00312 DO i=1,nlist 00313 IF(TRIM(results%result_label(i))==TRIM(description)) n_rep = n_rep + 1 00314 END DO 00315 END IF 00316 IF(PRESENT(n_entries))THEN 00317 n_entries = 0 00318 DO i=1,nlist 00319 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00320 SELECT CASE(results%result_value(i)%value%type_in_use) 00321 CASE(real_t) 00322 n_entries = n_entries + SIZE(results%result_value(i)%value%real_type) 00323 CASE(integer_t) 00324 n_entries = n_entries + SIZE(results%result_value(i)%value%integer_type) 00325 CASE(logical_t) 00326 n_entries = n_entries + SIZE(results%result_value(i)%value%logical_type) 00327 CASE DEFAULT 00328 ! Type not implemented in cp_result_type 00329 CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) 00330 END SELECT 00331 EXIT 00332 END IF 00333 END DO 00334 END IF 00335 IF (PRESENT(type_in_use)) THEN 00336 DO i=1,nlist 00337 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00338 type_in_use = results%result_value(i)%value%type_in_use 00339 EXIT 00340 END IF 00341 END DO 00342 END IF 00343 END SUBROUTINE get_nreps 00344 00345 ! ***************************************************************************** 00354 SUBROUTINE cp_results_erase(results,description,nval,error) 00355 TYPE(cp_result_type), POINTER :: results 00356 CHARACTER(LEN=default_string_length), 00357 OPTIONAL :: description 00358 INTEGER, OPTIONAL :: nval 00359 TYPE(cp_error_type), INTENT(inout) :: error 00360 00361 CHARACTER(len=*), PARAMETER :: routineN = 'cp_results_erase', 00362 routineP = moduleN//':'//routineN 00363 00364 INTEGER :: entry_deleted, i, k, 00365 new_size, nlist, nrep, stat 00366 LOGICAL :: failure 00367 TYPE(cp_result_type), POINTER :: clean_results 00368 00369 failure = .FALSE. 00370 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00371 new_size = 0 00372 IF(PRESENT(description))THEN 00373 CPPostcondition(description(1:1)=='[',cp_failure_level,routineP,error,failure) 00374 nlist=SIZE(results%result_value) 00375 nrep=0 00376 DO i=1,nlist 00377 IF(TRIM(results%result_label(i))==TRIM(description)) nrep = nrep + 1 00378 END DO 00379 IF(nrep.NE.0)THEN 00380 k = 0 00381 entry_deleted = 0 00382 DO i=1,nlist 00383 IF(TRIM(results%result_label(i))==TRIM(description))THEN 00384 k = k + 1 00385 IF (PRESENT(nval)) THEN 00386 IF (nval==k) THEN 00387 entry_deleted = entry_deleted + 1 00388 EXIT 00389 END IF 00390 ELSE 00391 entry_deleted = entry_deleted + 1 00392 END IF 00393 END IF 00394 END DO 00395 CPPostcondition(nlist-entry_deleted>=0,cp_failure_level,routineP,error,failure) 00396 new_size = nlist-entry_deleted 00397 NULLIFY(clean_results) 00398 CALL cp_result_create(clean_results, error) 00399 CALL cp_result_clean(clean_results, error) 00400 ALLOCATE(clean_results%result_label(new_size), stat=stat) 00401 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00402 ALLOCATE(clean_results%result_value(new_size), stat=stat) 00403 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00404 DO i = 1, new_size 00405 NULLIFY(clean_results%result_value(i)%value) 00406 CALL cp_result_value_create(clean_results%result_value(i)%value, error) 00407 END DO 00408 k = 0 00409 DO i =1,nlist 00410 IF(TRIM(results%result_label(i))/=TRIM(description)) THEN 00411 k = k + 1 00412 clean_results%result_label(k) = results%result_label(i) 00413 CALL cp_result_value_copy(clean_results%result_value(k)%value,& 00414 results%result_value(i)%value, error) 00415 END IF 00416 END DO 00417 CALL cp_result_copy(clean_results, results, error) 00418 CALL cp_result_release(clean_results, error) 00419 END IF 00420 ELSE 00421 CALL cp_result_clean(results, error) 00422 ALLOCATE(results%result_label(new_size), stat=stat) 00423 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00424 ALLOCATE(results%result_value(new_size), stat=stat) 00425 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00426 END IF 00427 END SUBROUTINE cp_results_erase 00428 00429 ! ***************************************************************************** 00433 SUBROUTINE cp_results_mp_bcast(results, source, para_env, error) 00434 TYPE(cp_result_type), POINTER :: results 00435 INTEGER, INTENT(IN) :: source 00436 TYPE(cp_para_env_type), POINTER :: para_env 00437 TYPE(cp_error_type), INTENT(inout) :: error 00438 00439 CHARACTER(len=*), PARAMETER :: routineN = 'cp_results_mp_bcast', 00440 routineP = moduleN//':'//routineN 00441 00442 INTEGER :: i, nlist, stat 00443 INTEGER, ALLOCATABLE, DIMENSION(:) :: size_value, type_in_use 00444 LOGICAL :: failure 00445 00446 failure = .FALSE. 00447 CPPostcondition(ASSOCIATED(results),cp_failure_level,routineP,error,failure) 00448 nlist = 0 00449 IF (para_env%mepos==source) nlist = SIZE(results%result_value) 00450 CALL mp_bcast(nlist, source, para_env%group) 00451 00452 ALLOCATE(size_value(nlist), stat=stat) 00453 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00454 ALLOCATE(type_in_use(nlist), stat=stat) 00455 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00456 IF (para_env%mepos==source) THEN 00457 DO i = 1, nlist 00458 CALL get_nreps(results,description=results%result_label(i),& 00459 n_entries=size_value(i),type_in_use=type_in_use(i),& 00460 error=error) 00461 END DO 00462 END IF 00463 CALL mp_bcast(size_value, source, para_env%group) 00464 CALL mp_bcast(type_in_use, source, para_env%group) 00465 00466 IF (para_env%mepos/=source) THEN 00467 CALL cp_result_clean(results, error) 00468 ALLOCATE(results%result_value(nlist),stat=stat) 00469 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00470 ALLOCATE(results%result_label(nlist),stat=stat) 00471 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00472 DO i = 1, nlist 00473 results%result_label(i) = "" 00474 NULLIFY(results%result_value(i)%value) 00475 CALL cp_result_value_create(results%result_value(i)%value,error) 00476 CALL cp_result_value_init(results%result_value(i)%value,& 00477 type_in_use=type_in_use(i),size_value=size_value(i), error=error) 00478 END DO 00479 END IF 00480 DO i = 1, nlist 00481 CALL mp_bcast(results%result_label(i), source, para_env%group) 00482 SELECT CASE(results%result_value(i)%value%type_in_use) 00483 CASE(real_t) 00484 CALL mp_bcast(results%result_value(i)%value%real_type, source, para_env%group) 00485 CASE(integer_t) 00486 CALL mp_bcast(results%result_value(i)%value%integer_type, source, para_env%group) 00487 CASE(logical_t) 00488 CALL mp_bcast(results%result_value(i)%value%logical_type, source, para_env%group) 00489 CASE DEFAULT 00490 ! Type not implemented in cp_result_type 00491 CPPostcondition(.FALSE.,cp_failure_level,routineP,error,failure) 00492 END SELECT 00493 END DO 00494 DEALLOCATE(type_in_use, stat=stat) 00495 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00496 DEALLOCATE(size_value, stat=stat) 00497 CPPostcondition(stat==0,cp_failure_level,routineP,error,failure) 00498 END SUBROUTINE cp_results_mp_bcast 00499 00500 END MODULE cp_result_methods
1.7.3