|
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 dbcsr_data_methods 00016 00017 USE dbcsr_cuda_memory, ONLY: dbcsr_cuda_host_mem_alloc,& 00018 dbcsr_cuda_host_mem_dealloc 00019 USE dbcsr_error_handling, ONLY: & 00020 dbcsr_assert, dbcsr_caller_error, dbcsr_error_set, dbcsr_error_stop, & 00021 dbcsr_error_type, dbcsr_failure_level, dbcsr_fatal_level, & 00022 dbcsr_internal_error, dbcsr_postcondition_failed, & 00023 dbcsr_unimplemented_error_nr, dbcsr_warning_level, & 00024 dbcsr_wrong_args_error 00025 USE dbcsr_kinds, ONLY: real_4,& 00026 real_4_size,& 00027 real_8,& 00028 real_8_size 00029 USE dbcsr_message_passing, ONLY: mp_allocate,& 00030 mp_deallocate 00031 USE dbcsr_ptr_util, ONLY: dbcsr_ptr_remapping,& 00032 ensure_array_size,& 00033 memory_zero,& 00034 pointer_c_rank_remap2,& 00035 pointer_d_rank_remap2,& 00036 pointer_s_rank_remap2,& 00037 pointer_z_rank_remap2 00038 USE dbcsr_types, ONLY: & 00039 dbcsr_data_area_type, dbcsr_data_obj, dbcsr_memory_CUDA_host_pinned, & 00040 dbcsr_memory_MPI, dbcsr_memory_default, dbcsr_obj, dbcsr_scalar_type, & 00041 dbcsr_type_complex_4, dbcsr_type_complex_4_2d, dbcsr_type_complex_8, & 00042 dbcsr_type_complex_8_2d, dbcsr_type_real_4, dbcsr_type_real_4_2d, & 00043 dbcsr_type_real_8, dbcsr_type_real_8_2d 00044 00045 !$ USE OMP_LIB 00046 00047 IMPLICIT NONE 00048 00049 00050 PRIVATE 00051 00052 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_data_methods' 00053 00054 REAL, PARAMETER :: default_resize_factor = 1.618034 00055 INTEGER, SAVE :: id = 0 00056 00057 00058 PUBLIC :: dbcsr_type_is_2d, dbcsr_type_2d_to_1d, dbcsr_type_1d_to_2d 00059 PUBLIC :: dbcsr_scalar, dbcsr_scalar_one, dbcsr_scalar_i, dbcsr_scalar_zero,& 00060 dbcsr_scalar_are_equal, dbcsr_scalar_negative,& 00061 dbcsr_scalar_add, dbcsr_scalar_multiply,& 00062 dbcsr_scalar_get_type, dbcsr_scalar_set_type,& 00063 dbcsr_scalar_fill_all, dbcsr_scalar_get_value 00064 PUBLIC :: dbcsr_data_init, dbcsr_data_new, dbcsr_data_hold,& 00065 dbcsr_data_release, dbcsr_data_get_size, dbcsr_data_get_type,& 00066 dbcsr_data_reset_type, dbcsr_data_query_type,& 00067 dbcsr_data_get_type_size 00068 PUBLIC :: dbcsr_data_resize 00069 PUBLIC :: dbcsr_get_data, & 00070 dbcsr_data_set_pointer,& 00071 dbcsr_data_clear_pointer, dbcsr_data_set_2d_pointer,& 00072 dbcsr_data_clear_2d_pointer, dbcsr_data_ensure_size,& 00073 dbcsr_data_get_sizes, dbcsr_data_verify_bounds,& 00074 dbcsr_data_exists, dbcsr_data_valid, dbcsr_data_get_memory_type 00075 PUBLIC :: dbcsr_data_zero 00076 PUBLIC :: dbcsr_data_set_size_referenced, dbcsr_data_get_size_referenced 00077 PUBLIC :: dbcsr_get_data_p, dbcsr_get_data_p_s, dbcsr_get_data_p_c,& 00078 dbcsr_get_data_p_d, dbcsr_get_data_p_z,& 00079 dbcsr_get_data_p_2d_s, dbcsr_get_data_p_2d_d,& 00080 dbcsr_get_data_p_2d_c, dbcsr_get_data_p_2d_z 00082 INTERFACE dbcsr_scalar 00083 MODULE PROCEDURE dbcsr_scalar_s, dbcsr_scalar_d,& 00084 dbcsr_scalar_c, dbcsr_scalar_z 00085 END INTERFACE 00086 00088 INTERFACE dbcsr_scalar_get_value 00089 MODULE PROCEDURE dbcsr_scalar_get_value_s, dbcsr_scalar_get_value_d,& 00090 dbcsr_scalar_get_value_c, dbcsr_scalar_get_value_z 00091 END INTERFACE 00092 00093 INTERFACE dbcsr_data_set_pointer 00094 MODULE PROCEDURE set_data_p_s, set_data_p_d, set_data_p_c, set_data_p_z 00095 MODULE PROCEDURE set_data_p_2d_s, set_data_p_2d_d,& 00096 set_data_p_2d_c, set_data_p_2d_z 00097 MODULE PROCEDURE set_data_area_area 00098 END INTERFACE 00099 00100 INTERFACE dbcsr_get_data 00101 MODULE PROCEDURE get_data_s, get_data_d, get_data_c, get_data_z 00102 MODULE PROCEDURE get_data_m_s, get_data_m_d, get_data_m_c, get_data_m_z 00103 MODULE PROCEDURE get_data_2d_s, get_data_2d_d, get_data_2d_c, get_data_2d_z 00104 END INTERFACE 00105 00106 00107 INTERFACE dbcsr_get_data_p 00108 MODULE PROCEDURE dbcsr_get_data_c_s, dbcsr_get_data_c_c,& 00109 dbcsr_get_data_c_d, dbcsr_get_data_c_z 00110 END INTERFACE 00111 00112 INTERFACE dbcsr_data_get_sizes 00113 MODULE PROCEDURE dbcsr_data_get_sizes_any 00114 MODULE PROCEDURE dbcsr_data_get_sizes_1, dbcsr_data_get_sizes_2 00115 END INTERFACE 00116 00117 INTERFACE dbcsr_data_query_type 00118 MODULE PROCEDURE query_type_s_1d, query_type_d_1d,& 00119 query_type_c_1d, query_type_z_1d 00120 MODULE PROCEDURE query_type_s_2d, query_type_d_2d,& 00121 query_type_c_2d, query_type_z_2d 00122 END INTERFACE 00123 00124 LOGICAL, PARAMETER :: careful_mod = .FALSE. 00125 LOGICAL, PARAMETER :: debug_mod = .FALSE. 00126 00127 CONTAINS 00128 00129 00130 ! ***************************************************************************** 00135 PURE FUNCTION dbcsr_data_get_type (area) RESULT (data_type) 00136 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00137 INTEGER :: data_type 00138 00139 data_type = area%d%data_type 00140 END FUNCTION dbcsr_data_get_type 00141 00142 00143 PURE FUNCTION dbcsr_data_get_memory_type (area) RESULT (memory_type) 00144 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00145 INTEGER :: memory_type 00146 00147 memory_type = area%d%memory_type 00148 END FUNCTION dbcsr_data_get_memory_type 00149 00150 ! ***************************************************************************** 00155 PURE FUNCTION dbcsr_data_get_type_size (area) RESULT (type_size) 00156 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00157 INTEGER :: type_size 00158 00159 SELECT CASE (dbcsr_type_2d_to_1d(area%d%data_type)) 00160 CASE (dbcsr_type_real_4) 00161 type_size = real_4_size 00162 CASE (dbcsr_type_real_8) 00163 type_size = real_8_size 00164 CASE (dbcsr_type_complex_4) 00165 type_size = 2*real_4_size 00166 CASE (dbcsr_type_complex_8) 00167 type_size = 2*real_8_size 00168 END SELECT 00169 END FUNCTION dbcsr_data_get_type_size 00170 00171 00172 ! Data type transformations 00173 FUNCTION data_type_2d_from_1d (type_1d) RESULT (type_2d) 00174 INTEGER, INTENT(in) :: type_1d 00175 INTEGER :: type_2d 00176 00177 CHARACTER(len=*), PARAMETER :: routineN = 'data_type_2d_from_1d', 00178 routineP = moduleN//':'//routineN 00179 00180 TYPE(dbcsr_error_type) :: error 00181 00182 SELECT CASE (type_1d) 00183 CASE (dbcsr_type_real_4) 00184 type_2d = dbcsr_type_real_4_2d 00185 CASE (dbcsr_type_real_8) 00186 type_2d = dbcsr_type_real_8_2d 00187 CASE (dbcsr_type_complex_4) 00188 type_2d = dbcsr_type_complex_4_2d 00189 CASE (dbcsr_type_complex_8) 00190 type_2d = dbcsr_type_complex_8_2d 00191 CASE default 00192 CALL dbcsr_assert (.FALSE., dbcsr_failure_level, dbcsr_caller_error,& 00193 routineN, "Invalid data type.",__LINE__,error) 00194 END SELECT 00195 END FUNCTION data_type_2d_from_1d 00196 00197 ! Data type transformations 00198 FUNCTION data_type_1d_from_2d (type_2d) RESULT (type_1d) 00199 INTEGER, INTENT(IN) :: type_2d 00200 INTEGER :: type_1d 00201 00202 CHARACTER(len=*), PARAMETER :: routineN = 'data_type_1d_from_2d', 00203 routineP = moduleN//':'//routineN 00204 00205 TYPE(dbcsr_error_type) :: error 00206 00207 SELECT CASE (type_2d) 00208 CASE (dbcsr_type_real_4_2d) 00209 type_1d = dbcsr_type_real_4 00210 CASE (dbcsr_type_real_8_2d) 00211 type_1d = dbcsr_type_real_8 00212 CASE (dbcsr_type_complex_4_2d) 00213 type_1d = dbcsr_type_complex_4 00214 CASE (dbcsr_type_complex_8_2d) 00215 type_1d = dbcsr_type_complex_8 00216 CASE default 00217 CALL dbcsr_assert (.FALSE., dbcsr_failure_level, dbcsr_caller_error,& 00218 routineN, "Invalid data type.",__LINE__,error) 00219 END SELECT 00220 END FUNCTION data_type_1d_from_2d 00221 00222 00223 ! ***************************************************************************** 00227 SUBROUTINE dbcsr_data_init (area) 00228 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00229 00230 NULLIFY (area%d) 00231 END SUBROUTINE dbcsr_data_init 00232 00233 ! ***************************************************************************** 00241 SUBROUTINE internal_data_allocate (area, data_type, sizes,& 00242 memory_type, error) 00243 TYPE(dbcsr_data_area_type), 00244 INTENT(INOUT) :: area 00245 INTEGER, INTENT(IN) :: data_type 00246 INTEGER, DIMENSION(:), INTENT(IN) :: sizes 00247 INTEGER, INTENT(IN) :: memory_type 00248 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 00249 00250 CHARACTER(len=*), PARAMETER :: routineN = 'internal_data_allocate', 00251 routineP = moduleN//':'//routineN 00252 00253 INTEGER :: d, error_handle, stat 00254 00255 ! --------------------------------------------------------------------------- 00256 00257 CALL dbcsr_error_set (routineN, error_handle, error) 00258 IF (debug_mod) & 00259 WRITE(*,*)routineN//" Setting to sizes", sizes 00260 IF (dbcsr_type_is_2d (data_type)) THEN 00261 CALL dbcsr_assert (SIZE(sizes), "EQ", 2, dbcsr_fatal_level,& 00262 dbcsr_wrong_args_error, routineN,& 00263 "Sizes must have 2 elements for 2-D data", __LINE__, error=error) 00264 ELSE 00265 CALL dbcsr_assert (SIZE(sizes), "EQ", 1, dbcsr_fatal_level,& 00266 dbcsr_wrong_args_error, routineN,& 00267 "Sizes must have 1 elements for 1-D data", __LINE__, error=error) 00268 ENDIF 00269 ! 00270 stat = 0 00271 SELECT CASE (memory_type) 00272 CASE (dbcsr_memory_MPI) 00273 SELECT CASE (data_type) 00274 CASE (dbcsr_type_real_4) 00275 CALL mp_allocate (area%r_sp, sizes(1), stat=stat) 00276 CASE (dbcsr_type_real_8) 00277 CALL mp_allocate (area%r_dp, sizes(1), stat=stat) 00278 CASE (dbcsr_type_complex_4) 00279 CALL mp_allocate (area%c_sp, sizes(1), stat=stat) 00280 CASE (dbcsr_type_complex_8) 00281 CALL mp_allocate (area%c_dp, sizes(1), stat=stat) 00282 CASE (dbcsr_type_real_8_2d, dbcsr_type_real_4_2d,& 00283 dbcsr_type_complex_8_2d, dbcsr_type_complex_4_2d) 00284 CALL dbcsr_assert (.FALSE.,& 00285 dbcsr_fatal_level, dbcsr_caller_error, routineN,& 00286 "Can not use MPI memory with 2D data areas.",& 00287 __LINE__, error=error) 00288 CASE default 00289 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00290 routineN, "Invalid data type.",__LINE__,error) 00291 END SELECT 00292 CASE (dbcsr_memory_CUDA_host_pinned) 00293 SELECT CASE (data_type) 00294 CASE (dbcsr_type_real_4) 00295 CALL dbcsr_cuda_host_mem_alloc (area%r_sp, sizes(1), error=error) 00296 CASE (dbcsr_type_real_8) 00297 CALL dbcsr_cuda_host_mem_alloc (area%r_dp, sizes(1), error=error) 00298 CASE (dbcsr_type_complex_4) 00299 CALL dbcsr_cuda_host_mem_alloc (area%c_sp, sizes(1), error=error) 00300 CASE (dbcsr_type_complex_8) 00301 CALL dbcsr_cuda_host_mem_alloc (area%c_dp, sizes(1), error=error) 00302 CASE (dbcsr_type_real_8_2d, dbcsr_type_real_4_2d,& 00303 dbcsr_type_complex_8_2d, dbcsr_type_complex_4_2d) 00304 CALL dbcsr_assert (.FALSE.,& 00305 dbcsr_fatal_level, dbcsr_caller_error, routineN,& 00306 "Can not use MPI memory with 2D data areas.",& 00307 __LINE__, error=error) 00308 CASE default 00309 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00310 routineN, "Invalid data type.",__LINE__,error) 00311 END SELECT 00312 CASE (dbcsr_memory_default) 00313 SELECT CASE (data_type) 00314 CASE (dbcsr_type_real_8) 00315 ALLOCATE (area%r_dp(sizes(1)), stat=stat) 00316 CASE (dbcsr_type_real_4) 00317 ALLOCATE (area%r_sp(sizes(1)), stat=stat) 00318 CASE (dbcsr_type_complex_8) 00319 ALLOCATE (area%c_dp(sizes(1)), stat=stat) 00320 CASE (dbcsr_type_complex_4) 00321 ALLOCATE (area%c_sp(sizes(1)), stat=stat) 00322 CASE (dbcsr_type_real_8_2d) 00323 ALLOCATE (area%r2_dp(sizes(1), sizes(2)), stat=stat) 00324 CASE (dbcsr_type_real_4_2d) 00325 ALLOCATE (area%r2_sp(sizes(1), sizes(2)), stat=stat) 00326 CASE (dbcsr_type_complex_8_2d) 00327 ALLOCATE (area%c2_dp(sizes(1), sizes(2)), stat=stat) 00328 CASE (dbcsr_type_complex_4_2d) 00329 ALLOCATE (area%c2_sp(sizes(1), sizes(2)), stat=stat) 00330 CASE default 00331 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00332 routineN, "Invalid data type.", __LINE__, error=error) 00333 END SELECT 00334 CASE default 00335 CALL dbcsr_assert (.FALSE.,& 00336 dbcsr_fatal_level, dbcsr_unimplemented_error_nr,& 00337 routineN, "Unsupported memory type.", __LINE__, error=error) 00338 END SELECT 00339 CALL dbcsr_assert (stat, "EQ", 0, dbcsr_fatal_level,& 00340 dbcsr_postcondition_failed, routineN,& 00341 "Error allocating memory", __LINE__, error=error) 00342 CALL dbcsr_error_stop(error_handle, error) 00343 END SUBROUTINE internal_data_allocate 00344 00345 00346 ! ***************************************************************************** 00354 SUBROUTINE internal_data_deallocate (area, data_type,& 00355 memory_type, error) 00356 TYPE(dbcsr_data_area_type), 00357 INTENT(INOUT) :: area 00358 INTEGER, INTENT(IN) :: data_type, memory_type 00359 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 00360 00361 CHARACTER(len=*), PARAMETER :: routineN = 'internal_data_deallocate', 00362 routineP = moduleN//':'//routineN 00363 00364 INTEGER :: error_handler, stat 00365 00366 ! --------------------------------------------------------------------------- 00367 00368 CALL dbcsr_error_set (routineN, error_handler, error) 00369 stat = 0 00370 SELECT CASE (memory_type) 00371 CASE (dbcsr_memory_MPI) 00372 SELECT CASE (data_type) 00373 CASE (dbcsr_type_real_4) 00374 CALL mp_deallocate (area%r_sp, stat=stat) 00375 NULLIFY (area%r_sp) 00376 CASE (dbcsr_type_real_8) 00377 CALL mp_deallocate (area%r_dp, stat=stat) 00378 NULLIFY (area%r_dp) 00379 CASE (dbcsr_type_complex_4) 00380 CALL mp_deallocate (area%c_sp, stat=stat) 00381 NULLIFY (area%c_sp) 00382 CASE (dbcsr_type_complex_8) 00383 CALL mp_deallocate (area%c_dp, stat=stat) 00384 NULLIFY (area%c_dp) 00385 CASE (dbcsr_type_real_8_2d, dbcsr_type_real_4_2d,& 00386 dbcsr_type_complex_8_2d, dbcsr_type_complex_4_2d) 00387 CALL dbcsr_assert (.FALSE.,& 00388 dbcsr_fatal_level, dbcsr_caller_error, routineN,& 00389 "Can not use MPI memory with 2D data areas.",& 00390 __LINE__, error=error) 00391 CASE default 00392 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00393 routineN, "Invalid data type.",__LINE__,error) 00394 END SELECT 00395 CASE (dbcsr_memory_CUDA_host_pinned) 00396 SELECT CASE (data_type) 00397 CASE (dbcsr_type_real_4) 00398 CALL dbcsr_cuda_host_mem_dealloc (area%r_sp, error=error) 00399 NULLIFY (area%r_sp) 00400 CASE (dbcsr_type_real_8) 00401 CALL dbcsr_cuda_host_mem_dealloc (area%r_dp, error=error) 00402 NULLIFY (area%r_dp) 00403 CASE (dbcsr_type_complex_4) 00404 CALL dbcsr_cuda_host_mem_dealloc (area%c_sp, error=error) 00405 NULLIFY (area%c_sp) 00406 CASE (dbcsr_type_complex_8) 00407 CALL dbcsr_cuda_host_mem_dealloc (area%c_dp, error=error) 00408 NULLIFY (area%c_dp) 00409 CASE (dbcsr_type_real_8_2d, dbcsr_type_real_4_2d,& 00410 dbcsr_type_complex_8_2d, dbcsr_type_complex_4_2d) 00411 CALL dbcsr_assert (.FALSE.,& 00412 dbcsr_fatal_level, dbcsr_caller_error, routineN,& 00413 "Can not use MPI memory with 2D data areas.",& 00414 __LINE__, error=error) 00415 CASE default 00416 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00417 routineN, "Invalid data type.",__LINE__,error) 00418 END SELECT 00419 CASE (dbcsr_memory_default) 00420 SELECT CASE (data_type) 00421 CASE (dbcsr_type_real_8) 00422 DEALLOCATE (area%r_dp, stat=stat) 00423 NULLIFY (area%r_dp) 00424 CASE (dbcsr_type_real_4) 00425 DEALLOCATE (area%r_sp, stat=stat) 00426 NULLIFY (area%r_sp) 00427 CASE (dbcsr_type_complex_8) 00428 DEALLOCATE (area%c_dp, stat=stat) 00429 NULLIFY (area%c_dp) 00430 CASE (dbcsr_type_complex_4) 00431 DEALLOCATE (area%c_sp, stat=stat) 00432 NULLIFY (area%c_sp) 00433 CASE (dbcsr_type_real_8_2d) 00434 DEALLOCATE (area%r2_dp, stat=stat) 00435 NULLIFY (area%r2_dp) 00436 CASE (dbcsr_type_real_4_2d) 00437 DEALLOCATE (area%r2_sp, stat=stat) 00438 NULLIFY (area%r2_sp) 00439 CASE (dbcsr_type_complex_8_2d) 00440 DEALLOCATE (area%c2_dp, stat=stat) 00441 NULLIFY (area%c2_dp) 00442 CASE (dbcsr_type_complex_4_2d) 00443 DEALLOCATE (area%c2_sp, stat=stat) 00444 NULLIFY (area%c2_sp) 00445 CASE default 00446 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00447 routineN, "Invalid data type.", __LINE__, error=error) 00448 END SELECT 00449 CASE default 00450 CALL dbcsr_assert (.FALSE.,& 00451 dbcsr_fatal_level, dbcsr_unimplemented_error_nr,& 00452 routineN, "Unsupported memory type.", __LINE__, error=error) 00453 END SELECT 00454 CALL dbcsr_assert (stat, "EQ", 0, dbcsr_fatal_level,& 00455 dbcsr_postcondition_failed, routineN,& 00456 "Error deallocating memory", __LINE__, error=error) 00457 CALL dbcsr_error_stop(error_handler, error) 00458 END SUBROUTINE internal_data_deallocate 00459 00460 00461 ! ***************************************************************************** 00469 SUBROUTINE dbcsr_data_new (area, data_type, data_size, data_size2,& 00470 memory_type) 00471 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00472 INTEGER, INTENT(IN) :: data_type 00473 INTEGER, INTENT(IN), OPTIONAL :: data_size, data_size2, 00474 memory_type 00475 00476 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_new', 00477 routineP = moduleN//':'//routineN 00478 00479 INTEGER :: d, total_size 00480 INTEGER, DIMENSION(2) :: sizes 00481 TYPE(dbcsr_error_type) :: error 00482 00483 ! --------------------------------------------------------------------------- 00484 00485 IF (.NOT. ASSOCIATED (area%d)) THEN 00486 ALLOCATE (area%d) 00487 ENDIF 00488 !$OMP ATOMIC 00489 id = id + 1 00490 !$OMP FLUSH (id) 00491 area%d%id = id 00492 NULLIFY (area%d%r_sp) 00493 NULLIFY (area%d%r_dp) 00494 NULLIFY (area%d%c_sp) 00495 NULLIFY (area%d%c_dp) 00496 NULLIFY (area%d%r2_sp) 00497 NULLIFY (area%d%r2_dp) 00498 NULLIFY (area%d%c2_sp) 00499 NULLIFY (area%d%c2_dp) 00500 area%d%refcount = 1 00501 IF (PRESENT (memory_type)) THEN 00502 area%d%memory_type = memory_type 00503 ELSE 00504 area%d%memory_type = dbcsr_memory_default 00505 ENDIF 00506 IF (PRESENT (data_size)) THEN 00507 IF (dbcsr_type_is_2d (data_type)) THEN 00508 CALL dbcsr_assert (PRESENT (data_size2), dbcsr_fatal_level,& 00509 dbcsr_wrong_args_error, routineN,& 00510 "Must specify 2 sizes for 2-D data", __LINE__, error=error) 00511 d = 2 00512 sizes(1) = data_size 00513 sizes(2) = data_size2 00514 total_size = data_size * data_size2 00515 ELSE 00516 d = 1 00517 sizes(1) = data_size 00518 total_size = data_size 00519 ENDIF 00520 CALL internal_data_allocate (area%d, data_type, sizes(1:d),& 00521 memory_type = area%d%memory_type, error=error) 00522 CALL dbcsr_data_set_size_referenced (area, total_size) 00523 ELSE 00524 CALL dbcsr_data_set_size_referenced (area, 0) 00525 ENDIF 00526 area%d%data_type = data_type 00527 END SUBROUTINE dbcsr_data_new 00528 00529 ! ***************************************************************************** 00533 SUBROUTINE dbcsr_data_release (area) 00534 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00535 00536 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_release', 00537 routineP = moduleN//':'//routineN 00538 00539 TYPE(dbcsr_error_type) :: error 00540 00541 ! --------------------------------------------------------------------------- 00542 00543 CALL dbcsr_assert (ASSOCIATED (area%d), & 00544 dbcsr_warning_level, dbcsr_caller_error,& 00545 routineN, "Data seems to be unreferenced.",__LINE__,error) 00546 IF (ASSOCIATED (area%d)) THEN 00547 ! 00548 IF (careful_mod) & 00549 CALL dbcsr_assert (area%d%refcount, "GT", 0,& 00550 dbcsr_warning_level, dbcsr_caller_error,& 00551 routineN, "Data seems to be unreferenced.",__LINE__,error) 00552 ! 00553 area%d%refcount = area%d%refcount - 1 00554 ! If we're releasing the last reference, then free the memory. 00555 IF (area%d%refcount .EQ. 0) THEN 00556 IF (dbcsr_data_exists (area, error)) THEN 00557 CALL internal_data_deallocate (area%d, area%d%data_type,& 00558 area%d%memory_type, error) 00559 ENDIF 00560 DEALLOCATE (area%d) 00561 NULLIFY (area%d) 00562 ENDIF 00563 ENDIF 00564 END SUBROUTINE dbcsr_data_release 00565 00566 ! ***************************************************************************** 00570 SUBROUTINE dbcsr_data_clear_pointer (area) 00571 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00572 00573 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_clear_pointer', 00574 routineP = moduleN//':'//routineN 00575 00576 TYPE(dbcsr_error_type) :: error 00577 00578 ! --------------------------------------------------------------------------- 00579 00580 IF (.NOT. ASSOCIATED (area%d)) THEN 00581 RETURN 00582 ENDIF 00583 CALL dbcsr_assert (area%d%refcount .GT. 0, dbcsr_warning_level, dbcsr_caller_error,& 00584 routineN, "Data seems to be unreferenced.",__LINE__,error) 00585 SELECT CASE (area%d%data_type) 00586 CASE (dbcsr_type_real_4) 00587 NULLIFY (area%d%r_sp) 00588 CASE (dbcsr_type_real_8) 00589 NULLIFY (area%d%r_dp) 00590 CASE (dbcsr_type_complex_4) 00591 NULLIFY (area%d%c_sp) 00592 CASE (dbcsr_type_complex_8) 00593 NULLIFY (area%d%c_dp) 00594 CASE (dbcsr_type_real_8_2d) 00595 NULLIFY (area%d%r2_dp) 00596 CASE (dbcsr_type_real_4_2d) 00597 NULLIFY (area%d%r2_sp) 00598 CASE (dbcsr_type_complex_8_2d) 00599 NULLIFY (area%d%c2_dp) 00600 CASE (dbcsr_type_complex_4_2d) 00601 NULLIFY (area%d%c2_sp) 00602 CASE default 00603 CALL dbcsr_assert (.FALSE., dbcsr_failure_level, dbcsr_caller_error,& 00604 routineN, "Invalid data type.",__LINE__,error) 00605 END SELECT 00606 END SUBROUTINE dbcsr_data_clear_pointer 00607 00608 ! ***************************************************************************** 00612 SUBROUTINE dbcsr_data_reset_type (area, new_type) 00613 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00614 INTEGER, INTENT(IN) :: new_type 00615 00616 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_reset_type', 00617 routineP = moduleN//':'//routineN 00618 00619 TYPE(dbcsr_error_type) :: error 00620 00621 ! --------------------------------------------------------------------------- 00622 00623 IF (.NOT. ASSOCIATED (area%d)) THEN 00624 CALL dbcsr_assert (ASSOCIATED (area%d), dbcsr_fatal_level,& 00625 dbcsr_caller_error,& 00626 routineN, "Data not initialized.",__LINE__,error) 00627 ENDIF 00628 CALL dbcsr_data_clear_pointer (area) 00629 area%d%data_type = new_type 00630 END SUBROUTINE dbcsr_data_reset_type 00631 00632 ! ***************************************************************************** 00637 ELEMENTAL FUNCTION dbcsr_data_valid (area) RESULT (valid) 00638 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00639 LOGICAL :: valid 00640 00641 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_valid', 00642 routineP = moduleN//':'//routineN 00643 00644 ! --------------------------------------------------------------------------- 00645 00646 valid = ASSOCIATED (area%d) 00647 END FUNCTION dbcsr_data_valid 00648 00649 ! ***************************************************************************** 00655 FUNCTION dbcsr_data_exists (area, error) RESULT (valid) 00656 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00657 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 00658 LOGICAL :: valid 00659 00660 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_exists', 00661 routineP = moduleN//':'//routineN 00662 00663 INTEGER :: error_handle 00664 00665 ! --------------------------------------------------------------------------- 00666 00667 IF (careful_mod) THEN 00668 CALL dbcsr_error_set (routineN, error_handle, error) 00669 ENDIF 00670 ! 00671 valid = dbcsr_data_valid (area) 00672 CALL dbcsr_assert (valid, dbcsr_fatal_level, dbcsr_wrong_args_error,& 00673 routineN, "Data area is invalid.", __LINE__, error) 00674 ! 00675 SELECT CASE (area%d%memory_type) 00676 CASE (dbcsr_memory_default, dbcsr_memory_MPI, dbcsr_memory_CUDA_host_pinned) 00677 SELECT CASE (area%d%data_type) 00678 CASE (dbcsr_type_real_4) 00679 valid = ASSOCIATED (area%d%r_sp) 00680 CASE (dbcsr_type_real_8) 00681 valid = ASSOCIATED (area%d%r_dp) 00682 CASE (dbcsr_type_complex_4) 00683 valid = ASSOCIATED (area%d%c_sp) 00684 CASE (dbcsr_type_complex_8) 00685 valid = ASSOCIATED (area%d%c_dp) 00686 CASE (dbcsr_type_real_4_2d) 00687 valid = ASSOCIATED (area%d%r2_sp) 00688 CASE (dbcsr_type_real_8_2d) 00689 valid = ASSOCIATED (area%d%r2_dp) 00690 CASE (dbcsr_type_complex_4_2d) 00691 valid = ASSOCIATED (area%d%c2_sp) 00692 CASE (dbcsr_type_complex_8_2d) 00693 valid = ASSOCIATED (area%d%c2_dp) 00694 CASE default 00695 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 00696 routineN, "Invalid data type.",__LINE__,error) 00697 END SELECT 00698 CASE default 00699 CALL dbcsr_assert (.FALSE.,& 00700 dbcsr_fatal_level, dbcsr_unimplemented_error_nr,& 00701 routineN, "Unsupported memory type.", __LINE__, error=error) 00702 END SELECT 00703 ! 00704 IF (careful_mod) THEN 00705 CALL dbcsr_error_stop(error_handle, error) 00706 ENDIF 00707 END FUNCTION dbcsr_data_exists 00708 00709 ! ***************************************************************************** 00713 SUBROUTINE dbcsr_data_hold (area) 00714 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00715 00716 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_hold', 00717 routineP = moduleN//':'//routineN 00718 00719 TYPE(dbcsr_error_type) :: error 00720 00721 ! --------------------------------------------------------------------------- 00722 00723 IF (careful_mod) THEN 00724 CALL dbcsr_assert (ASSOCIATED (area%d),& 00725 dbcsr_caller_error, dbcsr_fatal_level,& 00726 routineN, "Can't hold an empty data area.",__LINE__,error) 00727 CALL dbcsr_assert (area%d%refcount, "GT", 0,& 00728 dbcsr_caller_error, dbcsr_fatal_level,& 00729 routineN, "Should not hold an area with zero references.",& 00730 __LINE__,error) 00731 ENDIF 00732 IF (.NOT. ASSOCIATED (area%d)) THEN 00733 RETURN 00734 ENDIF 00735 area%d%refcount = area%d%refcount + 1 00736 END SUBROUTINE dbcsr_data_hold 00737 00738 00739 00740 ! ***************************************************************************** 00750 SUBROUTINE set_data_area_area (area, rsize, csize, pointee, source_lb) 00751 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00752 INTEGER, INTENT(IN) :: rsize, csize 00753 TYPE(dbcsr_data_obj), INTENT(IN) :: pointee 00754 INTEGER, INTENT(IN), OPTIONAL :: source_lb 00755 00756 CHARACTER(len=*), PARAMETER :: routineN = 'set_data_area_area', 00757 routineP = moduleN//':'//routineN 00758 00759 COMPLEX(KIND=real_4), DIMENSION(:), 00760 POINTER :: c_sp 00761 COMPLEX(KIND=real_8), DIMENSION(:), 00762 POINTER :: c_dp 00763 INTEGER :: bp, dt1, dt2, nze 00764 LOGICAL :: compatible, pointee_is_2d, rmp 00765 REAL(KIND=real_4), DIMENSION(:), POINTER :: r_sp 00766 REAL(KIND=real_8), DIMENSION(:), POINTER :: r_dp 00767 TYPE(dbcsr_error_type) :: error 00768 00769 ! --------------------------------------------------------------------------- 00770 00771 bp = 1 ; IF (PRESENT (source_lb)) bp = source_lb 00772 nze = rsize*csize 00773 dt1 = area%d%data_type 00774 dt2 = pointee%d%data_type 00775 IF (careful_mod) THEN 00776 compatible = dt1 .EQ. dt2 .OR. dt1 .EQ. dbcsr_type_1d_to_2d (dt2) 00777 CALL dbcsr_assert (compatible, dbcsr_fatal_level,& 00778 dbcsr_wrong_args_error, routineN,& 00779 "Can not point 1-d pointer to 2-d data",__LINE__,error) 00780 00781 ENDIF 00782 pointee_is_2d = dbcsr_type_is_2d (dt2) 00783 IF (careful_mod) THEN 00784 CALL dbcsr_assert (.NOT. PRESENT (source_lb) .OR. .NOT. pointee_is_2d, & 00785 dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& 00786 "Lower bound specification not possible with 2-d data",__LINE__,error) 00787 ! Check if size is OK. 00788 CALL dbcsr_assert (bp, "GE", 1,& 00789 dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& 00790 "Attempt to point out of bounds",__LINE__,error) 00791 CALL dbcsr_assert (bp + nze - 1, "LE", dbcsr_data_get_size (pointee),& 00792 dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& 00793 "Attempt to point out of bounds",__LINE__,error) 00794 ENDIF 00795 ! There's a remap if the ranks are compatible but not equal. 00796 rmp = dt1 .NE. dt2 00797 IF (.NOT. dbcsr_ptr_remapping) & 00798 CALL dbcsr_assert (.NOT. rmp, dbcsr_fatal_level, dbcsr_internal_error,& 00799 routineN, "Compiler does not support pointer rank remapping.",& 00800 __LINE__, error=error) 00801 SELECT CASE (dt2) 00802 CASE (dbcsr_type_real_4_2d) 00803 area%d%r2_sp => pointee%d%r2_sp(1:rsize,1:csize) 00804 CASE (dbcsr_type_real_4) 00805 IF (rmp) THEN 00806 r_sp => dbcsr_get_data_p_s (pointee, bp, bp+nze-1) 00807 CALL pointer_s_rank_remap2(area%d%r2_sp, rsize, csize,& 00808 r_sp) 00809 ELSE 00810 area%d%r_sp => dbcsr_get_data_p_s (pointee, bp, bp+nze-1) 00811 ENDIF 00812 CASE (dbcsr_type_real_8_2d) 00813 area%d%r2_dp => pointee%d%r2_dp(1:rsize,1:csize) 00814 CASE (dbcsr_type_real_8) 00815 IF (rmp) THEN 00816 r_dp => dbcsr_get_data_p_d (pointee, bp, bp+nze-1) 00817 CALL pointer_d_rank_remap2(area%d%r2_dp, rsize, csize,& 00818 r_dp) 00819 ELSE 00820 area%d%r_dp => dbcsr_get_data_p_d (pointee, bp, bp+nze-1) 00821 ENDIF 00822 CASE (dbcsr_type_complex_4_2d) 00823 area%d%c2_sp => pointee%d%c2_sp(1:rsize,1:csize) 00824 CASE (dbcsr_type_complex_4) 00825 IF (rmp) THEN 00826 c_sp => dbcsr_get_data_p_c (pointee, bp, bp+nze-1) 00827 CALL pointer_c_rank_remap2(area%d%c2_sp, rsize, csize,& 00828 c_sp) 00829 ELSE 00830 area%d%c_sp => dbcsr_get_data_p_c (pointee, bp, bp+nze-1) 00831 ENDIF 00832 CASE (dbcsr_type_complex_8_2d) 00833 area%d%c2_dp => pointee%d%c2_dp(1:rsize,1:csize) 00834 CASE (dbcsr_type_complex_8) 00835 IF (rmp) THEN 00836 c_dp => dbcsr_get_data_p_z (pointee, bp, bp+nze-1) 00837 CALL pointer_z_rank_remap2(area%d%c2_dp, rsize, csize,& 00838 c_dp) 00839 ELSE 00840 area%d%c_dp => dbcsr_get_data_p_z (pointee, bp, bp+nze-1) 00841 ENDIF 00842 CASE default 00843 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_internal_error,& 00844 routineN, "Invalid data type",__LINE__,error) 00845 END SELECT 00846 CALL dbcsr_data_set_size_referenced (area, rsize*csize) 00847 IF (debug_mod) THEN 00848 CALL dbcsr_assert (dbcsr_data_get_size_referenced (area), "EQ",& 00849 dbcsr_data_get_size (area), dbcsr_fatal_level, dbcsr_internal_error,& 00850 routineN, "Size mismatch", __LINE__, error) 00851 ENDIF 00852 END SUBROUTINE set_data_area_area 00853 00854 00855 ! ***************************************************************************** 00860 FUNCTION dbcsr_data_get_size (area) RESULT (data_size) 00861 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00862 INTEGER :: data_size 00863 00864 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_get_size', 00865 routineP = moduleN//':'//routineN 00866 00867 TYPE(dbcsr_error_type) :: error 00868 00869 data_size = 0 00870 IF (ASSOCIATED (area%d)) THEN 00871 SELECT CASE (area%d%data_type) 00872 CASE (dbcsr_type_real_8) 00873 IF (ASSOCIATED (area%d%r_dp))& 00874 data_size = SIZE (area%d%r_dp) 00875 CASE (dbcsr_type_real_4) 00876 IF (ASSOCIATED (area%d%r_sp))& 00877 data_size = SIZE (area%d%r_sp) 00878 CASE (dbcsr_type_complex_8) 00879 IF (ASSOCIATED (area%d%c_dp))& 00880 data_size = SIZE (area%d%c_dp) 00881 CASE (dbcsr_type_complex_4) 00882 IF (ASSOCIATED (area%d%c_sp))& 00883 data_size = SIZE (area%d%c_sp) 00884 CASE (dbcsr_type_real_8_2d) 00885 IF (ASSOCIATED (area%d%r2_dp))& 00886 data_size = SIZE (area%d%r2_dp) 00887 CASE (dbcsr_type_real_4_2d) 00888 IF (ASSOCIATED (area%d%r2_sp))& 00889 data_size = SIZE (area%d%r2_sp) 00890 CASE (dbcsr_type_complex_8_2d) 00891 IF (ASSOCIATED (area%d%c2_dp))& 00892 data_size = SIZE (area%d%c2_dp) 00893 CASE (dbcsr_type_complex_4_2d) 00894 IF (ASSOCIATED (area%d%c2_sp))& 00895 data_size = SIZE (area%d%c2_sp) 00896 CASE default 00897 CALL dbcsr_assert (.FALSE., dbcsr_failure_level, dbcsr_caller_error,& 00898 routineN, "Incorrect data type",__LINE__,error) 00899 END SELECT 00900 ELSE 00901 CALL dbcsr_assert (.FALSE., dbcsr_warning_level, dbcsr_caller_error, routineN,& 00902 "Uninitialized data area",__LINE__,error) 00903 data_size = 0 00904 ENDIF 00905 END FUNCTION dbcsr_data_get_size 00906 00907 00908 ! ***************************************************************************** 00919 SUBROUTINE dbcsr_data_ensure_size (area, data_size, nocopy, zero_pad, factor, error) 00920 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 00921 INTEGER, INTENT(IN) :: data_size 00922 LOGICAL, INTENT(IN), OPTIONAL :: nocopy, zero_pad 00923 REAL, INTENT(IN), OPTIONAL :: factor 00924 TYPE(dbcsr_error_type), INTENT(inout) :: error 00925 00926 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_ensure_size', 00927 routineP = moduleN//':'//routineN 00928 00929 INTEGER :: current_size, error_handler 00930 LOGICAL :: nocp, pad 00931 00932 ! --------------------------------------------------------------------------- 00933 00934 IF (careful_mod) CALL dbcsr_error_set(routineN, error_handler, error) 00935 CALL dbcsr_assert(ASSOCIATED (area%d), dbcsr_fatal_level, dbcsr_caller_error,& 00936 routineN, "Data area must be setup.",__LINE__,error) 00937 current_size = dbcsr_data_get_size (area) 00938 CALL dbcsr_data_set_size_referenced (area, data_size) 00939 IF (current_size .GT. 1 .AND. current_size .GE. data_size) THEN 00940 IF (careful_mod) CALL dbcsr_error_stop(error_handler, error) 00941 RETURN 00942 ENDIF 00943 ! 00944 nocp = .FALSE. 00945 IF (PRESENT (nocopy)) nocp = nocopy 00946 pad = .FALSE. 00947 IF (PRESENT (zero_pad)) pad = zero_pad 00948 ! 00949 IF (.NOT. & 00950 dbcsr_data_exists (area, error=error)) THEN 00951 CALL internal_data_allocate (area%d, area%d%data_type, (/ data_size /),& 00952 memory_type = area%d%memory_type, error=error) 00953 IF (pad) THEN 00954 CALL dbcsr_data_zero (area, (/ 1 /), (/ data_size /), error=error) 00955 ENDIF 00956 ELSE 00957 SELECT CASE (area%d%memory_type) 00958 CASE (dbcsr_memory_default,& 00959 dbcsr_memory_MPI,& 00960 dbcsr_memory_CUDA_host_pinned) 00961 SELECT CASE (area%d%data_type) 00962 CASE (dbcsr_type_real_8) 00963 CALL ensure_array_size (area%d%r_dp, ub=data_size,& 00964 memory_type=area%d%memory_type,& 00965 nocopy=nocp, zero_pad=zero_pad,& 00966 factor=factor,error=error) 00967 CASE (dbcsr_type_real_4) 00968 CALL ensure_array_size (area%d%r_sp, ub=data_size,& 00969 memory_type=area%d%memory_type,& 00970 nocopy=nocp, zero_pad=zero_pad,& 00971 factor=factor,error=error) 00972 CASE (dbcsr_type_complex_8) 00973 CALL ensure_array_size (area%d%c_dp, ub=data_size,& 00974 memory_type=area%d%memory_type,& 00975 nocopy=nocp, zero_pad=zero_pad,& 00976 factor=factor,error=error) 00977 CASE (dbcsr_type_complex_4) 00978 CALL ensure_array_size (area%d%c_sp, ub=data_size,& 00979 memory_type=area%d%memory_type,& 00980 nocopy=nocp, zero_pad=zero_pad,& 00981 factor=factor,error=error) 00982 CASE default 00983 CALL dbcsr_assert(.FALSE., dbcsr_failure_level,& 00984 dbcsr_unimplemented_error_nr, routineN,& 00985 "Invalid data type are supported",__LINE__,error) 00986 END SELECT 00987 CASE default 00988 CALL dbcsr_assert (.FALSE.,& 00989 dbcsr_fatal_level, dbcsr_unimplemented_error_nr,& 00990 routineN, "Unsupported memory type.", __LINE__, error=error) 00991 END SELECT 00992 ENDIF 00993 IF (careful_mod) CALL dbcsr_error_stop(error_handler, error) 00994 END SUBROUTINE dbcsr_data_ensure_size 00995 00996 00997 ! ***************************************************************************** 01004 SUBROUTINE dbcsr_data_verify_bounds (area, lb, ub, error) 01005 TYPE(dbcsr_data_obj), INTENT(IN) :: area 01006 INTEGER, DIMENSION(:), INTENT(IN) :: lb, ub 01007 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 01008 01009 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_verify_bounds', 01010 routineP = moduleN//':'//routineN 01011 01012 INTEGER :: data_type, error_handler 01013 01014 ! --------------------------------------------------------------------------- 01015 01016 CALL dbcsr_error_set (routineN, error_handler, error) 01017 data_type = dbcsr_data_get_type (area) 01018 IF (dbcsr_type_is_2d (data_type)) THEN 01019 CALL dbcsr_assert (SIZE (lb), "EQ", 2, dbcsr_fatal_level,& 01020 dbcsr_wrong_args_error, routineN,& 01021 "size must be 2 for 2-d lb", __LINE__, error=error) 01022 CALL dbcsr_assert (SIZE (ub), "EQ", 2, dbcsr_fatal_level,& 01023 dbcsr_wrong_args_error, routineN,& 01024 "size must be 2 for 2-d ub", __LINE__, error=error) 01025 ELSE 01026 CALL dbcsr_assert (SIZE (lb), "EQ", 1, dbcsr_fatal_level,& 01027 dbcsr_wrong_args_error, routineN,& 01028 "size must be 1 for 1-d lb", __LINE__, error=error) 01029 CALL dbcsr_assert (SIZE (ub), "EQ", 1, dbcsr_fatal_level,& 01030 dbcsr_wrong_args_error, routineN,& 01031 "size must be 1 for 1-d ub", __LINE__, error=error) 01032 ENDIF 01033 SELECT CASE (data_type) 01034 CASE (dbcsr_type_real_4) 01035 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%r_sp,1),& 01036 dbcsr_fatal_level,& 01037 dbcsr_internal_error, routineN, "lb r_sp", __LINE__, error) 01038 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%r_sp,1),& 01039 dbcsr_fatal_level,& 01040 dbcsr_caller_error, routineN, "ub r_sp",__LINE__,error) 01041 CASE (dbcsr_type_real_4_2d) 01042 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%r2_sp,1),& 01043 dbcsr_fatal_level,& 01044 dbcsr_internal_error, routineN, "lb r_sp 2d", __LINE__, error) 01045 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%r2_sp,1),& 01046 dbcsr_fatal_level,& 01047 dbcsr_caller_error, routineN, "ub r_sp 2d",__LINE__,error) 01048 CALL dbcsr_assert(lb(2), "GE", LBOUND(area%d%r2_sp,2),& 01049 dbcsr_fatal_level,& 01050 dbcsr_internal_error, routineN, "lb r_sp 2d", __LINE__, error) 01051 CALL dbcsr_assert(ub(2), "LE", UBOUND(area%d%r2_sp,2),& 01052 dbcsr_fatal_level,& 01053 dbcsr_caller_error, routineN, "ub r_sp 2d",__LINE__,error) 01054 CASE (dbcsr_type_real_8) 01055 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%r_dp,1),& 01056 dbcsr_fatal_level,& 01057 dbcsr_internal_error, routineN, "lb r_dp", __LINE__, error) 01058 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%r_dp,1),& 01059 dbcsr_fatal_level,& 01060 dbcsr_caller_error, routineN, "ub r_dp",__LINE__,error) 01061 CASE (dbcsr_type_real_8_2d) 01062 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%r2_dp,1),& 01063 dbcsr_fatal_level,& 01064 dbcsr_internal_error, routineN, "lb r_dp 2d", __LINE__, error) 01065 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%r2_dp,1),& 01066 dbcsr_fatal_level,& 01067 dbcsr_caller_error, routineN, "ub r_dp 2d",__LINE__,error) 01068 CALL dbcsr_assert(lb(2), "GE", LBOUND(area%d%r2_dp,2),& 01069 dbcsr_fatal_level,& 01070 dbcsr_internal_error, routineN, "lb r_dp 2d", __LINE__, error) 01071 CALL dbcsr_assert(ub(2), "LE", UBOUND(area%d%r2_dp,2),& 01072 dbcsr_fatal_level,& 01073 dbcsr_caller_error, routineN, "ub r_dp 2d",__LINE__,error) 01074 CASE (dbcsr_type_complex_4) 01075 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%c_sp,1),& 01076 dbcsr_fatal_level,& 01077 dbcsr_internal_error, routineN, "lb c_sp", __LINE__, error) 01078 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%c_sp,1),& 01079 dbcsr_fatal_level,& 01080 dbcsr_caller_error, routineN, "ub c_sp",__LINE__,error) 01081 CASE (dbcsr_type_complex_4_2d) 01082 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%c2_sp,1),& 01083 dbcsr_fatal_level,& 01084 dbcsr_internal_error, routineN, "lb c_sp 2d", __LINE__, error) 01085 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%c2_sp,1),& 01086 dbcsr_fatal_level,& 01087 dbcsr_caller_error, routineN, "ub c_sp 2d",__LINE__,error) 01088 CALL dbcsr_assert(lb(2), "GE", LBOUND(area%d%c2_sp,2),& 01089 dbcsr_fatal_level,& 01090 dbcsr_internal_error, routineN, "lb c_sp 2d", __LINE__, error) 01091 CALL dbcsr_assert(ub(2), "LE", UBOUND(area%d%c2_sp,2),& 01092 dbcsr_fatal_level,& 01093 dbcsr_caller_error, routineN, "ub c_sp 2d",__LINE__,error) 01094 CASE (dbcsr_type_complex_8) 01095 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%c_dp,1),& 01096 dbcsr_fatal_level,& 01097 dbcsr_internal_error, routineN, "lb c_dp", __LINE__, error) 01098 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%c_dp,1),& 01099 dbcsr_fatal_level,& 01100 dbcsr_caller_error, routineN, "ub c_dp",__LINE__,error) 01101 CASE (dbcsr_type_complex_8_2d) 01102 CALL dbcsr_assert(lb(1), "GE", LBOUND(area%d%c2_dp,1),& 01103 dbcsr_fatal_level,& 01104 dbcsr_internal_error, routineN, "lb c_dp 2d", __LINE__, error) 01105 CALL dbcsr_assert(ub(1), "LE", UBOUND(area%d%c2_dp,1),& 01106 dbcsr_fatal_level,& 01107 dbcsr_caller_error, routineN, "ub c_dp 2d",__LINE__,error) 01108 CALL dbcsr_assert(lb(2), "GE", LBOUND(area%d%c2_dp,2),& 01109 dbcsr_fatal_level,& 01110 dbcsr_internal_error, routineN, "lb c_dp 2d", __LINE__, error) 01111 CALL dbcsr_assert(ub(2), "LE", UBOUND(area%d%c2_dp,2),& 01112 dbcsr_fatal_level,& 01113 dbcsr_caller_error, routineN, "ub c_dp 2d",__LINE__,error) 01114 CASE default 01115 CALL dbcsr_assert(.FALSE., dbcsr_fatal_level, dbcsr_wrong_args_error,& 01116 routineN, "Invalid data type", __LINE__, error=error) 01117 END SELECT 01118 CALL dbcsr_error_stop (error_handler, error) 01119 END SUBROUTINE dbcsr_data_verify_bounds 01120 01121 01122 ! ***************************************************************************** 01128 SUBROUTINE dbcsr_data_zero (area, lb, ub, error) 01129 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 01130 INTEGER, DIMENSION(:), INTENT(in) :: lb, ub 01131 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 01132 01133 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_zero', 01134 routineP = moduleN//':'//routineN 01135 01136 INTEGER :: error_handle 01137 01138 ! --------------------------------------------------------------------------- 01139 01140 IF (careful_mod) THEN 01141 CALL dbcsr_error_set (routineN, error_handle, error) 01142 ENDIF 01143 ! 01144 SELECT CASE (area%d%memory_type) 01145 CASE (dbcsr_memory_default, dbcsr_memory_MPI, dbcsr_memory_CUDA_host_pinned) 01146 SELECT CASE (area%d%data_type) 01147 CASE (dbcsr_type_real_4) 01148 CALL memory_zero (area%d%r_sp(lb(1):), ub(1)) 01149 CASE (dbcsr_type_real_8) 01150 CALL memory_zero (area%d%r_dp(lb(1):), ub(1)) 01151 CASE (dbcsr_type_complex_4) 01152 CALL memory_zero (area%d%c_sp(lb(1):), ub(1)) 01153 CASE (dbcsr_type_complex_8) 01154 CALL memory_zero (area%d%c_dp(lb(1):), ub(1)) 01155 CASE (dbcsr_type_real_4_2d) 01156 area%d%r2_sp(lb(1):ub(1), lb(2):ub(2)) = 0.0_real_4 01157 CASE (dbcsr_type_real_8_2d) 01158 area%d%r2_dp(lb(1):ub(1), lb(2):ub(2)) = 0.0_real_8 01159 CASE (dbcsr_type_complex_4_2d) 01160 area%d%c2_sp(lb(1):ub(1), lb(2):ub(2)) = 0.0_real_4 01161 CASE (dbcsr_type_complex_8_2d) 01162 area%d%c2_dp(lb(1):ub(1), lb(2):ub(2)) = 0.0_real_8 01163 CASE default 01164 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& 01165 routineN, "Invalid data type.",__LINE__,error) 01166 END SELECT 01167 CASE default 01168 CALL dbcsr_assert (.FALSE.,& 01169 dbcsr_fatal_level, dbcsr_unimplemented_error_nr,& 01170 routineN, "Unsupported memory type.", __LINE__, error=error) 01171 END SELECT 01172 ! 01173 IF (careful_mod) THEN 01174 CALL dbcsr_error_stop(error_handle, error) 01175 ENDIF 01176 END SUBROUTINE dbcsr_data_zero 01177 01178 01179 01180 ! ***************************************************************************** 01188 SUBROUTINE dbcsr_data_set_2d_pointer (area, rowsize, colsize, offset) 01189 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 01190 INTEGER, INTENT(IN) :: rowsize 01191 INTEGER, INTENT(IN), OPTIONAL :: colsize, offset 01192 01193 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_set_2d_pointer', 01194 routineP = moduleN//':'//routineN 01195 01196 COMPLEX(KIND=real_4), DIMENSION(:), 01197 POINTER :: c_sp 01198 COMPLEX(KIND=real_8), DIMENSION(:), 01199 POINTER :: c_dp 01200 INTEGER :: bp, csize, dt1, nze 01201 LOGICAL :: compatible 01202 REAL(KIND=real_4), DIMENSION(:), POINTER :: r_sp 01203 REAL(KIND=real_8), DIMENSION(:), POINTER :: r_dp 01204 TYPE(dbcsr_error_type) :: error 01205 01206 ! --------------------------------------------------------------------------- 01207 01208 dt1 = area%d%data_type 01209 compatible = dt1 .EQ. dbcsr_type_real_4& 01210 .OR. dt1 .EQ. dbcsr_type_real_8& 01211 .OR. dt1 .EQ. dbcsr_type_complex_4& 01212 .OR. dt1 .EQ. dbcsr_type_complex_8 01213 CALL dbcsr_assert (compatible, dbcsr_fatal_level,& 01214 dbcsr_wrong_args_error, routineN, "Must target 1-D data",__LINE__,error) 01215 IF (PRESENT (offset)) THEN 01216 bp = offset 01217 nze = dbcsr_data_get_size (area) - offset + 1 01218 ELSE 01219 bp = 1 01220 nze = dbcsr_data_get_size (area) 01221 ENDIF 01222 IF (PRESENT (colsize)) THEN 01223 csize = colsize 01224 ELSE 01225 csize = nze / rowsize 01226 ENDIF 01227 SELECT CASE (dt1) 01228 CASE (dbcsr_type_real_4) 01229 r_sp => dbcsr_get_data_p_s (area, bp, bp+nze-1) 01230 CALL pointer_s_rank_remap2(area%d%r2_sp, rowsize, csize,& 01231 r_sp) 01232 CASE (dbcsr_type_real_8) 01233 r_dp => dbcsr_get_data_p_d (area, bp, bp+nze-1) 01234 CALL pointer_d_rank_remap2(area%d%r2_dp, rowsize, csize,& 01235 r_dp) 01236 CASE (dbcsr_type_complex_4) 01237 c_sp => dbcsr_get_data_p_c (area, bp, bp+nze-1) 01238 CALL pointer_c_rank_remap2(area%d%c2_sp, rowsize, csize,& 01239 c_sp) 01240 CASE (dbcsr_type_complex_8) 01241 c_dp => dbcsr_get_data_p_z (area, bp, bp+nze-1) 01242 CALL pointer_z_rank_remap2(area%d%c2_dp, rowsize, csize,& 01243 c_dp) 01244 CASE default 01245 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_internal_error,& 01246 routineN, "Invalid data type",__LINE__,error) 01247 END SELECT 01248 END SUBROUTINE dbcsr_data_set_2d_pointer 01249 01250 ! ***************************************************************************** 01255 SUBROUTINE dbcsr_data_clear_2d_pointer (area) 01256 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 01257 01258 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_clear_2d_pointer', 01259 routineP = moduleN//':'//routineN 01260 01261 INTEGER :: dt1 01262 TYPE(dbcsr_error_type) :: error 01263 01264 ! --------------------------------------------------------------------------- 01265 01266 dt1 = area%d%data_type 01267 SELECT CASE (dt1) 01268 CASE (dbcsr_type_real_4) 01269 NULLIFY (area%d%r2_sp) 01270 CASE (dbcsr_type_real_8) 01271 NULLIFY (area%d%r2_dp) 01272 CASE (dbcsr_type_complex_4) 01273 NULLIFY (area%d%c2_sp) 01274 CASE (dbcsr_type_complex_8) 01275 NULLIFY (area%d%c2_dp) 01276 CASE default 01277 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_internal_error,& 01278 routineN, "Invalid data type",__LINE__,error) 01279 END SELECT 01280 END SUBROUTINE dbcsr_data_clear_2d_pointer 01281 01282 01283 ! ***************************************************************************** 01290 SUBROUTINE dbcsr_data_get_sizes_any (area, sizes, valid, error) 01291 TYPE(dbcsr_data_obj), INTENT(IN) :: area 01292 INTEGER, DIMENSION(:), INTENT(OUT) :: sizes 01293 LOGICAL, INTENT(OUT) :: valid 01294 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 01295 01296 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_get_sizes_any', 01297 routineP = moduleN//':'//routineN 01298 01299 INTEGER :: d, error_handler 01300 01301 ! --------------------------------------------------------------------------- 01302 01303 IF (careful_mod) & 01304 CALL dbcsr_error_set (routineN, error_handler, error) 01305 01306 valid = .FALSE. 01307 sizes(:) = 0 01308 IF (ASSOCIATED (area%d)) THEN 01309 IF (careful_mod) THEN 01310 IF (dbcsr_type_is_2d (area%d%data_type)) THEN 01311 CALL dbcsr_assert (SIZE(sizes), "EQ", 2, dbcsr_fatal_level,& 01312 dbcsr_wrong_args_error, routineN,& 01313 "Sizes must have 2 elements for 2-D data", __LINE__, error=error) 01314 ELSE 01315 CALL dbcsr_assert (SIZE(sizes), "EQ", 1, dbcsr_fatal_level,& 01316 dbcsr_wrong_args_error, routineN,& 01317 "Sizes must have 1 elements for 1-D data", __LINE__, error=error) 01318 ENDIF 01319 ENDIF 01320 valid = dbcsr_data_exists (area, error=error) 01321 IF (valid) THEN 01322 SELECT CASE (area%d%memory_type) 01323 CASE (dbcsr_memory_default,& 01324 dbcsr_memory_MPI,& 01325 dbcsr_memory_CUDA_host_pinned) 01326 SELECT CASE (area%d%data_type) 01327 CASE (dbcsr_type_real_8) 01328 sizes(1) = SIZE (area%d%r_dp) 01329 CASE (dbcsr_type_real_4) 01330 sizes(1) = SIZE (area%d%r_sp) 01331 CASE (dbcsr_type_complex_8) 01332 sizes(1) = SIZE (area%d%c_dp) 01333 CASE (dbcsr_type_complex_4) 01334 sizes(1) = SIZE (area%d%c_sp) 01335 CASE (dbcsr_type_real_8_2d) 01336 sizes(1) = SIZE (area%d%r2_dp,1) 01337 sizes(2) = SIZE (area%d%r2_dp,2) 01338 CASE (dbcsr_type_real_4_2d) 01339 sizes(1) = SIZE (area%d%r2_sp,1) 01340 sizes(2) = SIZE (area%d%r2_sp,2) 01341 CASE (dbcsr_type_complex_8_2d) 01342 sizes(1) = SIZE (area%d%c2_dp,1) 01343 sizes(2) = SIZE (area%d%c2_dp,2) 01344 CASE (dbcsr_type_complex_4_2d) 01345 sizes(1) = SIZE (area%d%c2_sp,1) 01346 sizes(2) = SIZE (area%d%c2_sp,2) 01347 CASE default 01348 CALL dbcsr_assert (.FALSE.,& 01349 dbcsr_fatal_level, dbcsr_caller_error,& 01350 routineN, "Incorrect data type", __LINE__, error=error) 01351 END SELECT 01352 END SELECT 01353 ENDIF 01354 ENDIF 01355 IF (careful_mod) & 01356 CALL dbcsr_error_stop(error_handler, error) 01357 END SUBROUTINE dbcsr_data_get_sizes_any 01358 01359 ! ***************************************************************************** 01367 SUBROUTINE dbcsr_data_get_sizes_2 (area, row_size, col_size, valid, error) 01368 TYPE(dbcsr_data_obj), INTENT(IN) :: area 01369 INTEGER, INTENT(OUT) :: row_size, col_size 01370 LOGICAL, INTENT(OUT) :: valid 01371 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 01372 01373 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_get_sizes_2', 01374 routineP = moduleN//':'//routineN 01375 01376 INTEGER :: d, error_handler 01377 INTEGER, DIMENSION(2) :: s 01378 01379 ! --------------------------------------------------------------------------- 01380 01381 IF (careful_mod) & 01382 CALL dbcsr_error_set (routineN, error_handler, error) 01383 IF (ASSOCIATED (area%d)) THEN 01384 IF (careful_mod) & 01385 CALL dbcsr_assert (dbcsr_type_is_2d (area%d%data_type),& 01386 dbcsr_fatal_level,& 01387 dbcsr_wrong_args_error, routineN,& 01388 "1-D data can not have column size", __LINE__, error=error) 01389 CALL dbcsr_data_get_sizes_any (area, s, valid, error=error) 01390 row_size = s(1) 01391 col_size = s(2) 01392 ELSE 01393 valid = .FALSE. 01394 row_size = 0 01395 col_size = 0 01396 ENDIF 01397 IF (careful_mod) & 01398 CALL dbcsr_error_stop(error_handler, error) 01399 END SUBROUTINE dbcsr_data_get_sizes_2 01400 01401 ! ***************************************************************************** 01408 SUBROUTINE dbcsr_data_get_sizes_1 (area, total_size, valid, error) 01409 TYPE(dbcsr_data_obj), INTENT(IN) :: area 01410 INTEGER, INTENT(OUT) :: total_size 01411 LOGICAL, INTENT(OUT) :: valid 01412 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 01413 01414 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_get_sizes_1', 01415 routineP = moduleN//':'//routineN 01416 01417 INTEGER :: d, error_handler 01418 INTEGER, DIMENSION(1) :: s 01419 01420 ! --------------------------------------------------------------------------- 01421 01422 CALL dbcsr_error_set (routineN, error_handler, error) 01423 01424 IF (ASSOCIATED (area%d)) THEN 01425 IF (careful_mod) & 01426 CALL dbcsr_assert ("NOT", dbcsr_type_is_2d (area%d%data_type),& 01427 dbcsr_fatal_level,& 01428 dbcsr_wrong_args_error, routineN,& 01429 "Should not use 2-D data", __LINE__, error=error) 01430 CALL dbcsr_data_get_sizes_any (area, s, valid, error=error) 01431 total_size = s(1) 01432 ELSE 01433 valid = .FALSE. 01434 total_size = 0 01435 ENDIF 01436 CALL dbcsr_error_stop(error_handler, error) 01437 END SUBROUTINE dbcsr_data_get_sizes_1 01438 01439 01440 ! ***************************************************************************** 01446 SUBROUTINE dbcsr_data_resize (area, sizes, error) 01447 TYPE(dbcsr_data_obj), INTENT(INOUT) :: area 01448 INTEGER, DIMENSION(:), INTENT(IN) :: sizes 01449 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 01450 01451 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_data_resize', 01452 routineP = moduleN//':'//routineN 01453 01454 INTEGER :: d, error_handler 01455 INTEGER, DIMENSION(2) :: old_sizes 01456 LOGICAL :: old_valid 01457 01458 ! --------------------------------------------------------------------------- 01459 01460 CALL dbcsr_error_set (routineN, error_handler, error) 01461 ! 01462 CALL dbcsr_assert (ASSOCIATED (area%d), dbcsr_fatal_level,& 01463 dbcsr_caller_error, routineN,& 01464 "Invalid data area", __LINE__, error=error) 01465 IF (dbcsr_type_is_2d (area%d%data_type)) THEN 01466 d = 2 01467 IF (careful_mod) & 01468 CALL dbcsr_assert (SIZE(sizes), "EQ", 2, dbcsr_fatal_level,& 01469 dbcsr_wrong_args_error, routineN,& 01470 "Sizes must have 2 elements for 2-D data", __LINE__, error=error) 01471 ELSE 01472 d = 1 01473 IF (careful_mod) & 01474 CALL dbcsr_assert (SIZE(sizes), "EQ", 1, dbcsr_fatal_level,& 01475 dbcsr_wrong_args_error, routineN,& 01476 "Sizes must have 1 elements for 1-D data", __LINE__, error=error) 01477 ENDIF 01478 CALL dbcsr_data_get_sizes (area, old_sizes(1:d),& 01479 valid=old_valid, error=error) 01480 IF (.NOT. old_valid .OR. ANY(old_sizes(1:d) .NE. sizes(1:d))) THEN 01481 IF (old_valid) THEN 01482 CALL internal_data_deallocate (area%d, data_type=area%d%data_type,& 01483 memory_type=area%d%memory_type, error=error) 01484 ENDIF 01485 CALL internal_data_allocate (area%d, data_type=area%d%data_type,& 01486 sizes=sizes,& 01487 memory_type=area%d%memory_type, error=error) 01488 ENDIF 01489 CALL dbcsr_error_stop(error_handler, error) 01490 END SUBROUTINE dbcsr_data_resize 01491 01492 01493 ! ***************************************************************************** 01498 ELEMENTAL FUNCTION dbcsr_scalar_one (data_type) RESULT (one) 01499 INTEGER, INTENT(IN) :: data_type 01500 TYPE(dbcsr_scalar_type) :: one 01501 01502 one = dbcsr_scalar_zero (data_type) 01503 SELECT CASE (data_type) 01504 CASE (dbcsr_type_real_4) 01505 one%r_sp = 1.0_real_4 01506 CASE (dbcsr_type_real_8) 01507 one%r_dp = 1.0_real_8 01508 CASE (dbcsr_type_complex_4) 01509 one%c_sp = CMPLX(1.0, 0.0, real_4) 01510 CASE (dbcsr_type_complex_8) 01511 one%c_dp = CMPLX(1.0, 0.0, real_8) 01512 END SELECT 01513 END FUNCTION dbcsr_scalar_one 01514 01515 ! ***************************************************************************** 01520 ELEMENTAL FUNCTION dbcsr_scalar_i (data_type) RESULT (i) 01521 INTEGER, INTENT(IN) :: data_type 01522 TYPE(dbcsr_scalar_type) :: i 01523 01524 i = dbcsr_scalar_zero (data_type) 01525 SELECT CASE (data_type) 01526 CASE (dbcsr_type_real_4) 01527 i%r_sp = 0.0_real_4 01528 CASE (dbcsr_type_real_8) 01529 i%r_dp = 0.0_real_8 01530 CASE (dbcsr_type_complex_4) 01531 i%c_sp = CMPLX(0.0, 1.0, real_4) 01532 CASE (dbcsr_type_complex_8) 01533 i%c_dp = CMPLX(0.0, 1.0, real_8) 01534 END SELECT 01535 END FUNCTION dbcsr_scalar_i 01536 01537 ! ***************************************************************************** 01542 ELEMENTAL FUNCTION dbcsr_scalar_zero (data_type) RESULT (zero) 01543 INTEGER, INTENT(IN) :: data_type 01544 TYPE(dbcsr_scalar_type) :: zero 01545 01546 zero%data_type = data_type 01547 zero%r_sp = 0.0_real_4 01548 zero%r_dp = 0.0_real_8 01549 zero%c_sp = CMPLX(0.0, 0.0, real_4) 01550 zero%c_dp = CMPLX(0.0, 0.0, real_8) 01551 END FUNCTION dbcsr_scalar_zero 01552 01553 01554 ! ***************************************************************************** 01560 ELEMENTAL FUNCTION dbcsr_scalar_are_equal (s1, s2) RESULT (are_equal) 01561 TYPE(dbcsr_scalar_type), INTENT(IN) :: s1, s2 01562 LOGICAL :: are_equal 01563 01564 IF (s1%data_type .NE. s2%data_type) THEN 01565 are_equal = .FALSE. 01566 ELSE 01567 SELECT CASE (s1%data_type) 01568 CASE (dbcsr_type_real_4) 01569 are_equal = s1%r_sp .EQ. s2%r_sp 01570 CASE (dbcsr_type_real_8) 01571 are_equal = s1%r_dp .EQ. s2%r_dp 01572 CASE (dbcsr_type_complex_4) 01573 are_equal = s1%c_sp .EQ. s2%c_sp 01574 CASE (dbcsr_type_complex_8) 01575 are_equal = s1%c_dp .EQ. s2%c_dp 01576 CASE default 01577 are_equal = .FALSE. 01578 END SELECT 01579 ENDIF 01580 END FUNCTION dbcsr_scalar_are_equal 01581 01582 ! ***************************************************************************** 01587 ELEMENTAL FUNCTION dbcsr_scalar_negative (s) RESULT (negated) 01588 TYPE(dbcsr_scalar_type), INTENT(IN) :: s 01589 TYPE(dbcsr_scalar_type) :: negated 01590 01591 negated = dbcsr_scalar_zero (s%data_type) 01592 SELECT CASE (s%data_type) 01593 CASE (dbcsr_type_real_4) 01594 negated%r_sp = -s%r_sp 01595 CASE (dbcsr_type_real_8) 01596 negated%r_dp = -s%r_dp 01597 CASE (dbcsr_type_complex_4) 01598 negated%c_sp = -s%c_sp 01599 CASE (dbcsr_type_complex_8) 01600 negated%c_dp = -s%c_dp 01601 CASE default 01602 negated = dbcsr_scalar_zero (s%data_type) 01603 END SELECT 01604 END FUNCTION dbcsr_scalar_negative 01605 01606 ! ***************************************************************************** 01611 ELEMENTAL FUNCTION dbcsr_scalar_add (s1, s2) RESULT (s_sum) 01612 TYPE(dbcsr_scalar_type), INTENT(IN) :: s1, s2 01613 TYPE(dbcsr_scalar_type) :: s_sum 01614 01615 s_sum = dbcsr_scalar_zero (s1%data_type) 01616 SELECT CASE (s1%data_type) 01617 CASE (dbcsr_type_real_4) 01618 s_sum%r_sp = s1%r_sp + s2%r_sp 01619 CASE (dbcsr_type_real_8) 01620 s_sum%r_dp = s1%r_dp + s2%r_dp 01621 CASE (dbcsr_type_complex_4) 01622 s_sum%c_sp = s1%c_sp + s2%c_sp 01623 CASE (dbcsr_type_complex_8) 01624 s_sum%c_dp = s1%c_dp + s2%c_dp 01625 CASE default 01626 s_sum = dbcsr_scalar_zero (s1%data_type) 01627 END SELECT 01628 END FUNCTION dbcsr_scalar_add 01629 01630 ! ***************************************************************************** 01635 ELEMENTAL FUNCTION dbcsr_scalar_multiply (s1, s2) RESULT (s_product) 01636 TYPE(dbcsr_scalar_type), INTENT(IN) :: s1, s2 01637 TYPE(dbcsr_scalar_type) :: s_product 01638 01639 s_product = dbcsr_scalar_zero (s1%data_type) 01640 SELECT CASE (s1%data_type) 01641 CASE (dbcsr_type_real_4) 01642 s_product%r_sp = s1%r_sp * s2%r_sp 01643 CASE (dbcsr_type_real_8) 01644 s_product%r_dp = s1%r_dp * s2%r_dp 01645 CASE (dbcsr_type_complex_4) 01646 s_product%c_sp = s1%c_sp * s2%c_sp 01647 CASE (dbcsr_type_complex_8) 01648 s_product%c_dp = s1%c_dp * s2%c_dp 01649 CASE default 01650 s_product = dbcsr_scalar_zero (s1%data_type) 01651 END SELECT 01652 END FUNCTION dbcsr_scalar_multiply 01653 01654 01655 ! ***************************************************************************** 01660 ELEMENTAL FUNCTION dbcsr_scalar_get_type (scalar) RESULT (data_type) 01661 TYPE(dbcsr_scalar_type), INTENT(IN) :: scalar 01662 INTEGER :: data_type 01663 01664 data_type = scalar%data_type 01665 END FUNCTION dbcsr_scalar_get_type 01666 01667 ! ***************************************************************************** 01672 ELEMENTAL SUBROUTINE dbcsr_scalar_set_type (scalar, data_type) 01673 TYPE(dbcsr_scalar_type), INTENT(INOUT) :: scalar 01674 INTEGER, INTENT(IN) :: data_type 01675 01676 scalar%data_type = data_type 01677 END SUBROUTINE dbcsr_scalar_set_type 01678 01679 01680 ! ***************************************************************************** 01684 ELEMENTAL SUBROUTINE dbcsr_scalar_fill_all (scalar) 01685 TYPE(dbcsr_scalar_type), INTENT(INOUT) :: scalar 01686 01687 SELECT CASE(scalar%data_type) 01688 CASE (dbcsr_type_real_4) 01689 !scalar%r_sp = 0 01690 scalar%r_dp = REAL(scalar%r_sp, KIND=real_8) 01691 scalar%c_sp = CMPLX(scalar%r_sp, 0, KIND=real_4) 01692 scalar%c_dp = CMPLX(scalar%r_sp, 0, KIND=real_8) 01693 CASE (dbcsr_type_real_8) 01694 scalar%r_sp = REAL(scalar%r_dp, KIND=real_4) 01695 !scalar%r_dp = REAL(scalar%r_dp, KIND=real_8) 01696 scalar%c_sp = CMPLX(scalar%r_dp, 0, KIND=real_4) 01697 scalar%c_dp = CMPLX(scalar%r_dp, 0, KIND=real_8) 01698 CASE (dbcsr_type_complex_4) 01699 scalar%r_sp = REAL(scalar%c_sp, KIND=real_4) 01700 scalar%r_dp = REAL(scalar%c_sp, KIND=real_8) 01701 !scalar%c_sp = CMPLX(scalar%c_sp, KIND=real_4) 01702 scalar%c_dp = CMPLX(scalar%c_sp, KIND=real_8) 01703 CASE (dbcsr_type_complex_8) 01704 scalar%r_sp = REAL(scalar%c_dp, KIND=real_4) 01705 scalar%r_dp = REAL(scalar%c_dp, KIND=real_8) 01706 scalar%c_sp = CMPLX(scalar%c_dp, KIND=real_4) 01707 !scalar%c_dp = CMPLX(scalar%r_dp, KIND=real_8) 01708 END SELECT 01709 END SUBROUTINE dbcsr_scalar_fill_all 01710 01711 ! ***************************************************************************** 01715 PURE FUNCTION dbcsr_type_is_2d (data_type) 01716 INTEGER, INTENT(IN) :: data_type 01717 LOGICAL :: dbcsr_type_is_2d 01718 01719 dbcsr_type_is_2d = data_type .EQ. dbcsr_type_real_4_2d .OR.& 01720 data_type .EQ. dbcsr_type_real_8_2d .OR.& 01721 data_type .EQ. dbcsr_type_complex_4_2d .OR.& 01722 data_type .EQ. dbcsr_type_complex_8_2d 01723 END FUNCTION dbcsr_type_is_2d 01724 01725 ! ***************************************************************************** 01729 PURE FUNCTION dbcsr_type_2d_to_1d (data_type) 01730 INTEGER, INTENT(IN) :: data_type 01731 INTEGER :: dbcsr_type_2d_to_1d 01732 01733 SELECT CASE (data_type) 01734 CASE (dbcsr_type_real_4_2d) 01735 dbcsr_type_2d_to_1d = dbcsr_type_real_4 01736 CASE (dbcsr_type_real_8_2d) 01737 dbcsr_type_2d_to_1d = dbcsr_type_real_8 01738 CASE (dbcsr_type_complex_4_2d) 01739 dbcsr_type_2d_to_1d = dbcsr_type_complex_4 01740 CASE (dbcsr_type_complex_8_2d) 01741 dbcsr_type_2d_to_1d = dbcsr_type_complex_8 01742 CASE (dbcsr_type_real_4) 01743 dbcsr_type_2d_to_1d = dbcsr_type_real_4 01744 CASE (dbcsr_type_real_8) 01745 dbcsr_type_2d_to_1d = dbcsr_type_real_8 01746 CASE (dbcsr_type_complex_4) 01747 dbcsr_type_2d_to_1d = dbcsr_type_complex_4 01748 CASE (dbcsr_type_complex_8) 01749 dbcsr_type_2d_to_1d = dbcsr_type_complex_8 01750 CASE default 01751 dbcsr_type_2d_to_1d = -1 01752 END SELECT 01753 END FUNCTION dbcsr_type_2d_to_1d 01754 01755 ! ***************************************************************************** 01759 PURE FUNCTION dbcsr_type_1d_to_2d (data_type) 01760 INTEGER, INTENT(IN) :: data_type 01761 INTEGER :: dbcsr_type_1d_to_2d 01762 01763 SELECT CASE (data_type) 01764 CASE (dbcsr_type_real_4) 01765 dbcsr_type_1d_to_2d = dbcsr_type_real_4_2d 01766 CASE (dbcsr_type_real_8) 01767 dbcsr_type_1d_to_2d = dbcsr_type_real_8_2d 01768 CASE (dbcsr_type_complex_4) 01769 dbcsr_type_1d_to_2d = dbcsr_type_complex_4_2d 01770 CASE (dbcsr_type_complex_8) 01771 dbcsr_type_1d_to_2d = dbcsr_type_complex_8_2d 01772 CASE (dbcsr_type_real_4_2d) 01773 dbcsr_type_1d_to_2d = dbcsr_type_real_4_2d 01774 CASE (dbcsr_type_real_8_2d) 01775 dbcsr_type_1d_to_2d = dbcsr_type_real_8_2d 01776 CASE (dbcsr_type_complex_4_2d) 01777 dbcsr_type_1d_to_2d = dbcsr_type_complex_4_2d 01778 CASE (dbcsr_type_complex_8_2d) 01779 dbcsr_type_1d_to_2d = dbcsr_type_complex_8_2d 01780 CASE default 01781 dbcsr_type_1d_to_2d = -1 01782 END SELECT 01783 END FUNCTION dbcsr_type_1d_to_2d 01784 01785 01786 01787 ! ***************************************************************************** 01792 PURE FUNCTION dbcsr_data_get_size_referenced (area) RESULT (data_size_referenced) 01793 TYPE(dbcsr_data_obj), INTENT(IN) :: area 01794 INTEGER :: data_size_referenced 01795 01796 IF (ASSOCIATED (area%d)) THEN 01797 data_size_referenced = area%d%ref_size 01798 ELSE 01799 data_size_referenced = 0 01800 ENDIF 01801 END FUNCTION dbcsr_data_get_size_referenced 01802 01803 ! ***************************************************************************** 01808 PURE SUBROUTINE dbcsr_data_set_size_referenced (data_area, referenced_size) 01809 TYPE(dbcsr_data_obj), INTENT(INOUT) :: data_area 01810 INTEGER, INTENT(IN) :: referenced_size 01811 01812 data_area%d%ref_size = referenced_size 01813 END SUBROUTINE dbcsr_data_set_size_referenced 01814 01815 01816 01817 01818 01819 01820 #include "dbcsr_data_methods_d.F" 01821 #include "dbcsr_data_methods_z.F" 01822 #include "dbcsr_data_methods_s.F" 01823 #include "dbcsr_data_methods_c.F" 01824 END MODULE dbcsr_data_methods
1.7.3