|
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 ! ***************************************************************************** 00016 MODULE dbcsr_ptr_util 00017 #if !defined (__HAS_NO_ISO_C_BINDING) 00018 USE ISO_C_BINDING 00019 #endif 00020 00021 USE dbcsr_cuda_memory, ONLY: dbcsr_cuda_host_mem_alloc,& 00022 dbcsr_cuda_host_mem_dealloc 00023 USE dbcsr_error_handling 00024 USE dbcsr_kinds, ONLY: real_4,& 00025 real_8 00026 USE dbcsr_message_passing, ONLY: mp_allocate,& 00027 mp_deallocate 00028 USE dbcsr_types, ONLY: dbcsr_data_obj,& 00029 dbcsr_memory_CUDA_host_pinned,& 00030 dbcsr_memory_MPI,& 00031 dbcsr_memory_default,& 00032 dbcsr_type_complex_4,& 00033 dbcsr_type_complex_8,& 00034 dbcsr_type_real_4,& 00035 dbcsr_type_real_8 00036 00037 !$ USE OMP_LIB 00038 00039 IMPLICIT NONE 00040 00041 PRIVATE 00042 00043 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_ptr_util' 00044 00045 REAL, PARAMETER :: default_resize_factor = 1.618034 00046 00047 LOGICAL, PARAMETER :: careful_mod = .FALSE. 00048 00049 #if defined(__PTR_RANK_REMAP) || !defined(__HAS_NO_ISO_C_BINDING) 00050 ! True pointer rank remapping or safe pointer rank remapping using 00051 ! ISO_C_BINDING can be used. 00052 LOGICAL, PARAMETER :: dbcsr_ptr_remapping = .TRUE. 00053 #elif defined(__NO_ASSUMED_SIZE_NOCOPY_ASSUMPTION) 00054 ! Use buffers 00055 LOGICAL, PARAMETER :: dbcsr_ptr_remapping = .FALSE. 00056 ERROR "CP2K must have some way of mapping rank-2 pointers onto rank-1 pointers." 00057 #else 00058 ! Use crazy Fortran hacks. 00059 ! This can be very unsafe! 00060 LOGICAL, PARAMETER :: dbcsr_ptr_remapping = .TRUE. 00061 #endif 00062 00063 00064 PUBLIC :: ensure_array_size, default_resize_factor 00065 PUBLIC :: memory_allocate, memory_deallocate 00066 PUBLIC :: memory_copy, memory_zero 00067 PUBLIC :: pointer_replace, pointer_view 00068 PUBLIC :: pointer_rank_remap2, dbcsr_ptr_remapping,& 00069 pointer_s_rank_remap2, pointer_d_rank_remap2,& 00070 pointer_c_rank_remap2, pointer_z_rank_remap2 00071 00072 00073 INTERFACE ensure_array_size 00074 MODULE PROCEDURE ensure_array_size_i 00075 MODULE PROCEDURE ensure_array_size_s, ensure_array_size_d,& 00076 ensure_array_size_c, ensure_array_size_z 00077 END INTERFACE 00078 00079 ! Ugly fortran hack 00080 INTERFACE pointer_view 00081 MODULE PROCEDURE pointer_view_s, pointer_view_d,& 00082 pointer_view_c, pointer_view_z 00083 MODULE PROCEDURE pointer_view_i 00084 MODULE PROCEDURE pointer_view_a 00085 END INTERFACE 00086 00087 INTERFACE pointer_replace 00088 MODULE PROCEDURE pointer_replace_i 00089 END INTERFACE 00090 00091 INTERFACE pointer_rank_remap2 00092 MODULE PROCEDURE pointer_s_rank_remap2, pointer_d_rank_remap2,& 00093 pointer_c_rank_remap2, pointer_z_rank_remap2 00094 END INTERFACE 00095 00096 INTERFACE memory_copy 00097 MODULE PROCEDURE mem_copy_i 00098 MODULE PROCEDURE mem_copy_s, mem_copy_d, mem_copy_c, mem_copy_z 00099 END INTERFACE 00100 00101 INTERFACE memory_zero 00102 MODULE PROCEDURE mem_zero_i 00103 MODULE PROCEDURE mem_zero_s, mem_zero_d, mem_zero_c, mem_zero_z 00104 END INTERFACE 00105 00106 INTERFACE memory_allocate 00107 MODULE PROCEDURE mem_alloc_i 00108 MODULE PROCEDURE mem_alloc_s, mem_alloc_d, mem_alloc_c, mem_alloc_z 00109 END INTERFACE 00110 00111 INTERFACE memory_deallocate 00112 MODULE PROCEDURE mem_dealloc_i 00113 MODULE PROCEDURE mem_dealloc_s, mem_dealloc_d, mem_dealloc_c, mem_dealloc_z 00114 END INTERFACE 00115 00116 CONTAINS 00117 00118 ! ***************************************************************************** 00132 SUBROUTINE ensure_array_size_i(array, lb, ub, factor, nocopy, memory_type,& 00133 zero_pad, error) 00134 INTEGER, DIMENSION(:), POINTER :: array 00135 INTEGER, INTENT(IN), OPTIONAL :: lb 00136 INTEGER, INTENT(IN) :: ub 00137 REAL, INTENT(IN), OPTIONAL :: factor 00138 LOGICAL, INTENT(IN), OPTIONAL :: nocopy 00139 INTEGER, INTENT(IN), OPTIONAL :: memory_type 00140 LOGICAL, INTENT(IN), OPTIONAL :: zero_pad 00141 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 00142 00143 CHARACTER(len=*), PARAMETER :: routineN = 'ensure_array_size_i', 00144 routineP = moduleN//':'//routineN 00145 00146 INTEGER :: error_handler, lb_new, 00147 lb_orig, mem_type, old_size, 00148 size_increase, ub_new, ub_orig 00149 INTEGER, DIMENSION(:), POINTER :: newarray 00150 LOGICAL :: dbg, docopy, pad 00151 00152 ! --------------------------------------------------------------------------- 00153 00154 IF (careful_mod) CALL dbcsr_error_set(routineN, error_handler, error) 00155 dbg = .FALSE. 00156 00157 IF (PRESENT (nocopy)) THEN 00158 docopy = .NOT. nocopy 00159 ELSE 00160 docopy = .TRUE. 00161 ENDIF 00162 IF (PRESENT (memory_type)) THEN 00163 mem_type = memory_type 00164 ELSE 00165 mem_type = dbcsr_memory_default 00166 ENDIF 00167 lb_new = 1 00168 IF (PRESENT (lb)) lb_new = lb 00169 pad = .FALSE. 00170 IF (PRESENT (zero_pad)) pad = zero_pad 00172 IF (.NOT.ASSOCIATED(array)) THEN 00173 CALL dbcsr_assert (lb_new, "EQ", 1, & 00174 dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& 00175 "Arrays must start at 1", __LINE__, error=error) 00176 CALL mem_alloc_i (array, ub, mem_type=mem_type, error=error) 00177 IF (pad .AND. ub .GT. 0) CALL mem_zero_i (array, ub) 00178 IF (careful_mod) CALL dbcsr_error_stop(error_handler, error) 00179 RETURN 00180 ENDIF 00181 lb_orig = LBOUND(array,1) 00182 ub_orig = UBOUND(array,1) 00183 old_size = ub_orig - lb_orig + 1 00184 ! The existing array is big enough. 00185 IF (lb_orig.LE.lb_new .AND. ub_orig.GE.ub) THEN 00186 IF (careful_mod) CALL dbcsr_error_stop(error_handler, error) 00187 RETURN 00188 ENDIF 00189 IF(dbg) WRITE(*,*)routineP//' Current bounds are',lb_orig,':',ub_orig 00190 ! A reallocation must be performed. 00191 IF (lb_orig.GT.lb_new) THEN 00192 IF (PRESENT(factor)) THEN 00193 size_increase = lb_orig - lb_new 00194 size_increase = MAX (NINT(REAL(size_increase)*factor), 00195 NINT(REAL(old_size)*factor)) 00196 lb_new = MIN (lb_orig, lb_new - size_increase) 00197 ELSE 00198 lb_new = lb_orig 00199 ENDIF 00200 ENDIF 00201 IF (ub_orig.LT.ub) THEN 00202 IF (PRESENT(factor)) THEN 00203 size_increase = ub - ub_orig 00204 size_increase = MAX (NINT(REAL(size_increase)*factor), 00205 NINT(REAL(old_size)*factor)) 00206 ub_new = MAX (ub_orig, ub + size_increase) 00207 ELSE 00208 ub_new = ub 00209 ENDIF 00210 ELSE 00211 ub_new = ub 00212 ENDIF 00213 IF(dbg) WRITE(*,*)routineP//' Resizing to bounds',lb_new,':',ub_new,'v',ub 00214 ! 00215 ! Deallocates the old array if it's not needed to copy the old data. 00216 IF(.NOT.docopy) THEN 00217 CALL mem_dealloc_i (array, mem_type=mem_type,error=error) 00218 ENDIF 00219 ! 00220 ! Allocates the new array 00221 CALL dbcsr_assert (lb_new, "EQ", 1, & 00222 dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& 00223 "Arrays must start at 1", __LINE__, error=error) 00224 CALL mem_alloc_i (newarray, ub_new-lb_new+1, mem_type, error=error) 00225 ! 00226 ! Now copy and/or zero pad. 00227 IF(docopy) THEN 00228 IF(dbg) CALL dbcsr_assert(lb_new.LE.lb_orig .AND. ub_new.GE.ub_orig,& 00229 dbcsr_failure_level, dbcsr_internal_error, routineP,& 00230 "Old extent exceeds the new one.",__LINE__,error) 00231 IF (ub_orig-lb_orig+1 .GT. 0) THEN 00232 !newarray(lb_orig:ub_orig) = array(lb_orig:ub_orig) 00233 CALL mem_copy_i (newarray(lb_orig:ub_orig),& 00234 array(lb_orig:ub_orig), ub_orig-lb_orig+1) 00235 ENDIF 00236 IF (pad) THEN 00237 !newarray(lb_new:lb_orig-1) = 0 00238 CALL mem_zero_i (newarray(lb_new:lb_orig-1), (lb_orig-1)-lb_new+1) 00239 !newarray(ub_orig+1:ub_new) = 0 00240 CALL mem_zero_i (newarray(ub_orig+1:ub_new), ub_new-(ub_orig+1)+1) 00241 ENDIF 00242 CALL mem_dealloc_i (array, mem_type, error=error) 00243 ELSEIF (pad) THEN 00244 !newarray(:) = 0 00245 CALL mem_zero_i (newarray, SIZE(newarray)) 00246 END IF 00247 array => newarray 00248 IF (careful_mod) CALL dbcsr_error_stop(error_handler, error) 00249 END SUBROUTINE ensure_array_size_i 00250 00251 00252 ! ***************************************************************************** 00258 SUBROUTINE mem_copy_i (dst, src, n) 00259 INTEGER, INTENT(IN) :: n 00260 INTEGER, DIMENSION(1:n), INTENT(IN) :: src 00261 INTEGER, DIMENSION(1:n), INTENT(OUT) :: dst 00262 00263 dst(:) = src(:) 00264 END SUBROUTINE mem_copy_i 00265 00266 ! ***************************************************************************** 00271 SUBROUTINE mem_zero_i (dst, n) 00272 INTEGER, INTENT(IN) :: n 00273 INTEGER, DIMENSION(1:n), INTENT(OUT) :: dst 00274 00275 dst(:) = 0 00276 END SUBROUTINE mem_zero_i 00277 00278 ! ***************************************************************************** 00285 SUBROUTINE mem_alloc_i (mem, n, mem_type, error) 00286 INTEGER, DIMENSION(:), POINTER :: mem 00287 INTEGER, INTENT(IN) :: n, mem_type 00288 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 00289 00290 CHARACTER(len=*), PARAMETER :: routineN = 'mem_alloc_i', 00291 routineP = moduleN//':'//routineN 00292 00293 INTEGER :: error_handle, stat 00294 00295 ! --------------------------------------------------------------------------- 00296 00297 IF (careful_mod) & 00298 CALL dbcsr_error_set (routineN, error_handle, error=error) 00299 ! 00300 SELECT CASE (mem_type) 00301 CASE (dbcsr_memory_default) 00302 ALLOCATE(mem(n), stat=stat) 00303 CASE (dbcsr_memory_MPI) 00304 CALL mp_allocate(mem, n, stat=stat) 00305 CASE (dbcsr_memory_CUDA_host_pinned) 00306 CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) 00307 CASE default 00308 CALL dbcsr_assert (.FALSE.,& 00309 dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& 00310 "Unsupported memory type",__LINE__,error) 00311 END SELECT 00312 ! 00313 CALL dbcsr_assert (stat == 0, dbcsr_warning_level, dbcsr_internal_error,& 00314 routineN, "memory",__LINE__,error) 00315 ! 00316 IF (careful_mod) & 00317 CALL dbcsr_error_stop (error_handle, error=error) 00318 END SUBROUTINE mem_alloc_i 00319 00320 ! ***************************************************************************** 00327 SUBROUTINE mem_dealloc_i (mem, mem_type, error) 00328 INTEGER, DIMENSION(:), POINTER :: mem 00329 INTEGER, INTENT(IN) :: mem_type 00330 TYPE(dbcsr_error_type), INTENT(INOUT) :: error 00331 00332 CHARACTER(len=*), PARAMETER :: routineN = 'mem_dealloc_i', 00333 routineP = moduleN//':'//routineN 00334 00335 INTEGER :: error_handle, stat 00336 00337 ! --------------------------------------------------------------------------- 00338 00339 IF (careful_mod) & 00340 CALL dbcsr_error_set (routineN, error_handle, error=error) 00341 ! 00342 SELECT CASE (mem_type) 00343 CASE (dbcsr_memory_default) 00344 DEALLOCATE(mem, stat=stat) 00345 CASE (dbcsr_memory_MPI) 00346 CALL mp_deallocate(mem, stat=stat) 00347 CASE (dbcsr_memory_CUDA_host_pinned) 00348 CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) 00349 CASE default 00350 CALL dbcsr_assert (.FALSE.,& 00351 dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& 00352 "Unsupported memory type",__LINE__,error) 00353 END SELECT 00354 ! 00355 CALL dbcsr_assert (stat == 0, dbcsr_warning_level, dbcsr_internal_error,& 00356 routineN, "memory",__LINE__,error) 00357 ! 00358 IF (careful_mod) & 00359 CALL dbcsr_error_stop (error_handle, error=error) 00360 END SUBROUTINE mem_dealloc_i 00361 00362 ! ***************************************************************************** 00368 SUBROUTINE pointer_replace_i (original_p, new_p) 00369 INTEGER, DIMENSION(:), POINTER :: original_p, new_p 00370 00371 ! --------------------------------------------------------------------------- 00372 00373 IF (ASSOCIATED (original_p)) DEALLOCATE (original_p) 00374 original_p => new_p 00375 END SUBROUTINE pointer_replace_i 00376 00377 00378 ! ***************************************************************************** 00384 FUNCTION pointer_view_i (original, lb, ub) RESULT (view) 00385 INTEGER, DIMENSION(:), POINTER :: original 00386 INTEGER, INTENT(IN) :: lb, ub 00387 INTEGER, DIMENSION(:), POINTER :: view 00388 00389 view => original(lb:ub) 00390 END FUNCTION pointer_view_i 00391 00392 00393 ! ***************************************************************************** 00401 FUNCTION pointer_view_a (new_area, area, offset, len) RESULT (narea2) 00402 TYPE(dbcsr_data_obj), INTENT(INOUT) :: new_area 00403 TYPE(dbcsr_data_obj), INTENT(IN) :: area 00404 INTEGER, INTENT(IN) :: offset 00405 INTEGER, INTENT(IN), OPTIONAL :: len 00406 TYPE(dbcsr_data_obj) :: narea2 00407 00408 CHARACTER(len=*), PARAMETER :: routineN = 'pointer_view_a', 00409 routineP = moduleN//':'//routineN 00410 00411 TYPE(dbcsr_error_type) :: error 00412 00413 CALL dbcsr_assert (area%d%data_type, "EQ", new_area%d%data_type,& 00414 dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& 00415 "Incompatible data types.",__LINE__,error) 00416 IF (PRESENT (len)) THEN 00417 SELECT CASE (area%d%data_type) 00418 CASE (dbcsr_type_real_4) 00419 new_area%d%r_sp => area%d%r_sp(offset:offset+len-1) 00420 CASE (dbcsr_type_real_8) 00421 new_area%d%r_dp => area%d%r_dp(offset:offset+len-1) 00422 CASE (dbcsr_type_complex_4) 00423 new_area%d%c_sp => area%d%c_sp(offset:offset+len-1) 00424 CASE (dbcsr_type_complex_8) 00425 new_area%d%c_dp => area%d%c_dp(offset:offset+len-1) 00426 CASE default 00427 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_wrong_args_error,& 00428 routineN, "Invalid data type.",__LINE__,error) 00429 END SELECT 00430 ELSE 00431 SELECT CASE (area%d%data_type) 00432 CASE (dbcsr_type_real_4) 00433 new_area%d%r_sp => area%d%r_sp(offset:) 00434 CASE (dbcsr_type_real_8) 00435 new_area%d%r_dp => area%d%r_dp(offset:) 00436 CASE (dbcsr_type_complex_4) 00437 new_area%d%c_sp => area%d%c_sp(offset:) 00438 CASE (dbcsr_type_complex_8) 00439 new_area%d%c_dp => area%d%c_dp(offset:) 00440 CASE default 00441 CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_wrong_args_error,& 00442 routineN, "Invalid data type.",__LINE__,error) 00443 END SELECT 00444 ENDIF 00445 narea2 = new_area 00446 END FUNCTION pointer_view_a 00447 00448 #include "dbcsr_ptr_util_d.F" 00449 #include "dbcsr_ptr_util_z.F" 00450 #include "dbcsr_ptr_util_s.F" 00451 #include "dbcsr_ptr_util_c.F" 00452 00453 END MODULE dbcsr_ptr_util
1.7.3