diff --git a/cuda_tools/dbcsr_cuda_calc.cu b/cuda_tools/dbcsr_cuda_calc.cu index 325c3d076c..b662f0fcd8 100644 --- a/cuda_tools/dbcsr_cuda_calc.cu +++ b/cuda_tools/dbcsr_cuda_calc.cu @@ -39,25 +39,25 @@ __global__ void stack_mm_r int stack_size, int nparams, const float *__restrict__ a_data, const float *__restrict__ b_data, - float *__restrict__ c_data, int *__restrict__ c_locks); + float *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset); __global__ void stack_mm_d (const int *__restrict__ param_stack, int stack_size, int nparams, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks); + double *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset); __global__ void stack_mm_c (const int *__restrict__ param_stack, int stack_size, int nparams, const float *__restrict__ a_data, const float *__restrict__ b_data, - float *__restrict__ c_data, int *__restrict__ c_locks); + float *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset); __global__ void stack_mm_z (const int *__restrict__ param_stack, int stack_size, int nparams, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks); + double *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset); __global__ void stack_mm_mnk_d (const int *__restrict__ param_stack, const int careful, const int nruns, @@ -66,7 +66,7 @@ __global__ void stack_mm_mnk_d (const int *__restrict__ param_stack, const double *__restrict__ a_data, const double *__restrict__ b_data, double *__restrict__ c_data, - int *__restrict__ c_locks); + int *__restrict__ c_locks, int lock_offset); __global__ void stack_mm_mnk_sq23_d (const int *__restrict__ param_stack, const int careful, const int nruns, @@ -75,7 +75,8 @@ __global__ void stack_mm_mnk_sq23_d (const int *__restrict__ param_stack, const double *__restrict__ a_data, const double *__restrict__ b_data, double *__restrict__ c_data, - int *__restrict__ c_locks); + int *__restrict__ c_locks, + int lock_offset); __global__ void stack_mm_mnk_sq5_d (const int *__restrict__ param_stack, const int careful, const int nruns, @@ -84,7 +85,8 @@ __global__ void stack_mm_mnk_sq5_d (const int *__restrict__ param_stack, const double *__restrict__ a_data, const double *__restrict__ b_data, double *__restrict__ c_data, - int *__restrict__ c_locks); + int *__restrict__ c_locks, + int lock_offset); /** * \brief Bridge routine to call appropriate CUDA kernel. @@ -129,7 +131,8 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, return 4; stack_mm_r <<< stack_size, maxt, shared_size, stream >>> (param_stack, stack_size, nparams, - (float *) a_data, (float *) b_data, (float *) c_data, c_locks); + (float *) a_data, (float *) b_data, (float *) c_data, c_locks, + pow (2, 15) * stream_id); break; case 3: /* Real, double precision */ @@ -164,7 +167,9 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, shared_size, stream >>> (param_stack, careful, nruns, m_max, n_max, k_max, liter, (double *) a_data, (double *) b_data, - (double *) c_data, c_locks); + (double *) c_data, c_locks, pow (2, + 15) + * stream_id); } else if (m_max == 5 && n_max == 5 && k_max == 5) { @@ -177,7 +182,8 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, m_max, n_max, k_max, liter, (double *) a_data, (double *) b_data, - (double *) c_data, c_locks); + (double *) c_data, c_locks, + pow (2, 15) * stream_id); } else { @@ -187,7 +193,9 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, //mn, mk, nk, maxb, liter, liter, (double *) a_data, (double *) b_data, - (double *) c_data, c_locks); + (double *) c_data, c_locks, pow (2, + 15) + * stream_id); } } else @@ -200,7 +208,7 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, stack_mm_d <<< stack_size, maxt, shared_size, stream >>> (param_stack, stack_size, nparams, (double *) a_data, (double *) b_data, (double *) c_data, - c_locks); + c_locks, pow (2, 15) * stream_id); } break; case 5: @@ -210,7 +218,8 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, return 4; stack_mm_c <<< stack_size, maxt, shared_size, stream >>> (param_stack, stack_size, nparams, - (float *) a_data, (float *) b_data, (float *) c_data, c_locks); + (float *) a_data, (float *) b_data, (float *) c_data, c_locks, + pow (2, 15) * stream_id); break; case 7: /* Complex, double precision */ @@ -219,7 +228,8 @@ dc_do_stack_cu (int *param_stack, int stack_size, int nparams, return 4; stack_mm_z <<< stack_size, maxt, shared_size, stream >>> (param_stack, stack_size, nparams, - (double *) a_data, (double *) b_data, (double *) c_data, c_locks); + (double *) a_data, (double *) b_data, (double *) c_data, c_locks, + pow (2, 15) * stream_id); break; default: return 2; diff --git a/cuda_tools/dbcsr_cuda_calc_c.cu b/cuda_tools/dbcsr_cuda_calc_c.cu index 9a8925d31e..ebcd13541d 100644 --- a/cuda_tools/dbcsr_cuda_calc_c.cu +++ b/cuda_tools/dbcsr_cuda_calc_c.cu @@ -12,7 +12,7 @@ __global__ void stack_mm_c int stack_size, int nparams, const float *__restrict__ a_data, const float *__restrict__ b_data, - float *__restrict__ c_data, int *__restrict__ c_locks) + float *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset) { /** @@ -117,7 +117,7 @@ __global__ void stack_mm_c // /* Lock the C block. */ // syncthreads(); // if (tn == 0) { - // sp_one = sp + 1; + // sp_one = lock_offset + sp + 1; // c_id = our_params[6]-1; // lock_owner = 0; // while ((lock_owner != sp_one)) diff --git a/cuda_tools/dbcsr_cuda_calc_d.cu b/cuda_tools/dbcsr_cuda_calc_d.cu index 8e8c946e41..0a0e4c657a 100644 --- a/cuda_tools/dbcsr_cuda_calc_d.cu +++ b/cuda_tools/dbcsr_cuda_calc_d.cu @@ -50,7 +50,8 @@ stack_mm_mnk_sq23_d (const int *__restrict__ param_stack, const int liter, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks) + double *__restrict__ c_data, int *__restrict__ c_locks, + int lock_offset) { /** @@ -227,7 +228,7 @@ stack_mm_mnk_sq23_d (const int *__restrict__ param_stack, c_loc = param_stack[psp + 5] - 1; // c_id = param_stack[psp+6]-1; // if (threadIdx.x == 0) { - // my_id = blockIdx.x+1; + // my_id = lock_offset + blockIdx.x+1; // lock_owner = 0; // while ((lock_owner != my_id)) // lock_owner = atomicCAS (&(c_locks[c_id]), 0, my_id); @@ -347,7 +348,8 @@ stack_mm_mnk_sq5_d (const int *__restrict__ param_stack, const int liter, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks) + double *__restrict__ c_data, int *__restrict__ c_locks, + int lock_offset) { /** @@ -519,7 +521,8 @@ stack_mm_mnk_sq5_d (const int *__restrict__ param_stack, /* if (lid == 0) { - my_id = 4*blockIdx.x + wid + 1; + // TODO: make shure 2^16 is enough as lock_offset stepsize + my_id = lock_offset + 4*blockIdx.x + wid + 1; int lock_owner = 0; while ((lock_owner != my_id)) lock_owner = atomicCAS (&(c_locks[c_id]), 0, my_id); @@ -556,7 +559,8 @@ stack_mm_mnk_d (const int *__restrict__ param_stack, const int liter, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks) + double *__restrict__ c_data, int *__restrict__ c_locks, + int lock_offset) { /** @@ -646,7 +650,7 @@ stack_mm_mnk_d (const int *__restrict__ param_stack, // c_id = param_stack[psp+6]-1; // // if (threadIdx.x == 0) { - // my_id = blockIdx.x+1; + // my_id = lock_offset + blockIdx.x+1; // lock_owner = 0; // while ((lock_owner != my_id)) // lock_owner = atomicCAS (&(c_locks[c_id]), 0, my_id); @@ -682,7 +686,7 @@ __global__ void stack_mm_d int stack_size, int nparams, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks) + double *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset) { /** @@ -754,7 +758,7 @@ __global__ void stack_mm_d // c_loc = param_stack[psp+5]-1; // syncthreads(); // if (tn == 0) { - // sp_one = sp + 1; + // sp_one = lock_offset + sp + 1; // lock_owner = 0; // while ((lock_owner != sp_one)) // lock_owner = atomicCAS (&(c_locks[c_id]), 0, sp_one); diff --git a/cuda_tools/dbcsr_cuda_calc_r.cu b/cuda_tools/dbcsr_cuda_calc_r.cu index f6c23c7c8f..8a5ddd9395 100644 --- a/cuda_tools/dbcsr_cuda_calc_r.cu +++ b/cuda_tools/dbcsr_cuda_calc_r.cu @@ -12,7 +12,7 @@ __global__ void stack_mm_r int stack_size, int nparams, const float *__restrict__ a_data, const float *__restrict__ b_data, - float *__restrict__ c_data, int *__restrict__ c_locks) + float *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset) { /** @@ -104,7 +104,7 @@ __global__ void stack_mm_r // /* Lock the C block. */ // syncthreads(); // if (tn == 0) { - // sp_one = sp + 1; + // sp_one = lock_offset + sp + 1; // c_id = our_params[6]-1; // lock_owner = 0; // while ((lock_owner != sp_one)) diff --git a/cuda_tools/dbcsr_cuda_calc_z.cu b/cuda_tools/dbcsr_cuda_calc_z.cu index 534046a680..3cdecbef76 100644 --- a/cuda_tools/dbcsr_cuda_calc_z.cu +++ b/cuda_tools/dbcsr_cuda_calc_z.cu @@ -12,7 +12,7 @@ __global__ void stack_mm_z int stack_size, int nparams, const double *__restrict__ a_data, const double *__restrict__ b_data, - double *__restrict__ c_data, int *__restrict__ c_locks) + double *__restrict__ c_data, int *__restrict__ c_locks, int lock_offset) { /** @@ -121,7 +121,7 @@ __global__ void stack_mm_z // /* Lock the C block. */ // syncthreads(); // if (tn == 0) { - // sp_one = sp + 1; + // sp_one = lock_offset + sp + 1; // c_id = our_params[6]-1; // lock_owner = 0; // while ((lock_owner != sp_one)) diff --git a/cuda_tools/dbcsr_cuda_dev.cu b/cuda_tools/dbcsr_cuda_dev.cu index 58af3b9bd5..08c7384893 100644 --- a/cuda_tools/dbcsr_cuda_dev.cu +++ b/cuda_tools/dbcsr_cuda_dev.cu @@ -56,6 +56,9 @@ dc_set_device_cu (int device_id) if (cuda_error_check (cErr)) return 1; + if (myDevice != device_id) + return 1; + cErr = cudaGetDeviceProperties (&devProperties, myDevice); if (cuda_error_check (cErr)) return 1; diff --git a/cuda_tools/dbcsr_cuda_mem.cu b/cuda_tools/dbcsr_cuda_mem.cu index 942722defa..e312d0192a 100644 --- a/cuda_tools/dbcsr_cuda_mem.cu +++ b/cuda_tools/dbcsr_cuda_mem.cu @@ -280,3 +280,15 @@ dc_memzero_cu (void *dev_mem, size_t offset, size_t length) if (cuda_error_check (cudaGetLastError())) return 1; */ return 0; } + +extern "C" int +dc_dev_mem_info_cu (size_t * free, size_t * avail) +{ + cudaError_t cErr; + cErr = cudaMemGetInfo (free, avail); + if (cuda_error_check (cErr)) + return 1; + if (cuda_error_check (cudaGetLastError ())) + return 1; + return 0; +} diff --git a/src/cp_dbcsr_interface.F b/src/cp_dbcsr_interface.F index 57f1cd06fa..112215b6d9 100644 --- a/src/cp_dbcsr_interface.F +++ b/src/cp_dbcsr_interface.F @@ -46,8 +46,7 @@ MODULE cp_dbcsr_interface dbcsr_set_conf_nstacks, dbcsr_set_conf_subcomm, & dbcsr_set_conf_use_comm_thread, has_cuda, has_mpi, mm_driver_blas, & mm_driver_cuda, mm_driver_matmul, mm_driver_plasma, mm_driver_smm, & - mm_name_blas, mm_name_cuda, mm_name_matmul, mm_name_plasma, & - mm_name_smm, mm_thread_workshare + mm_name_blas, mm_name_cuda, mm_name_matmul, mm_name_plasma, mm_name_smm USE dbcsr_data_methods, ONLY: dbcsr_scalar,& dbcsr_scalar_fill_all,& dbcsr_scalar_get_value,& @@ -433,8 +432,7 @@ CONTAINS INTEGER :: comm_thread_load, & error_handle, mm_driver, & - mm_ss, n_mem_regions, & - n_stack_buffers + mm_ss, n_stack_buffers INTEGER, DIMENSION(3) :: nstacks LOGICAL :: use_combtypes, & use_comm_thread, & @@ -463,15 +461,11 @@ CONTAINS "mm_stack_size", i_val=mm_ss, error=error) CALL section_vals_val_get(dbcsr_section,& "mm_driver", i_val=mm_driver, error=error) - CALL section_vals_val_get(dbcsr_section,& - "mm_thread_workshare", l_val=mm_thread_workshare, error=error) CALL section_vals_val_get(dbcsr_section,& "n_size_mnk_stacks", i_val=nstacks(1), error=error) nstacks(2:3) = nstacks(1) CALL section_vals_val_get(dbcsr_section,& "n_stack_buffers", i_val=n_stack_buffers, error=error) - CALL section_vals_val_get(dbcsr_section,& - "n_stack_memory_regions", i_val=n_mem_regions, error=error) CALL section_vals_val_get(dbcsr_section,& "use_comm_thread", l_val=use_comm_thread, error=error) CALL section_vals_val_get(dbcsr_section,& @@ -482,8 +476,7 @@ CONTAINS CALL dbcsr_set_conf_mpi_mem (use_mpi_mem, error=dbcsr_error) CALL dbcsr_set_conf_cuda_mem (use_cuda_mem, error=dbcsr_error) CALL dbcsr_set_conf_mm_stacksize (mm_ss, error=dbcsr_error) - CALL dbcsr_set_conf_nstacks(nstacks, n_stack_buffers, n_mem_regions,& - error=dbcsr_error) + CALL dbcsr_set_conf_nstacks(nstacks, n_stack_buffers, error=dbcsr_error) CALL dbcsr_set_conf_use_comm_thread(use_comm_thread, error=dbcsr_error) CALL dbcsr_set_conf_comm_thread_load(comm_thread_load, error=dbcsr_error) CALL dbcsr_error_stop (error_handle, dbcsr_error) @@ -504,11 +497,10 @@ CONTAINS CHARACTER(len=default_string_length) :: comm_thread_load_str, mm_name, & mm_ss_str, use_combtypes_str, use_comm_thread_str, use_cuda_mem_str, & - use_k_stacks, use_m_stacks, use_mem_regions, use_mpi_mem_str, & - use_n_stacks, use_stack_buffers, use_subcomms_str + use_k_stacks, use_m_stacks, use_mpi_mem_str, use_n_stacks, & + use_stack_buffers, use_subcomms_str INTEGER :: comm_thread_load, mm_driver, & - mm_ss, nbuffers, nmemregions, & - unit_num + mm_ss, nbuffers, unit_num INTEGER, DIMENSION(3) :: n_mnk_stacks LOGICAL :: use_combtypes, & use_comm_thread, & @@ -544,10 +536,8 @@ CONTAINS use_comm_thread_str = l2str_r(use_comm_thread,info_len) comm_thread_load_str = int2str_r(comm_thread_load,info_len) - CALL dbcsr_get_conf_nstacks (n_mnk_stacks, nbuffers, nmemregions,& - error=dbcsr_error) + CALL dbcsr_get_conf_nstacks (n_mnk_stacks, nbuffers, error=dbcsr_error) use_stack_buffers = int2str_r (nbuffers, info_len) - use_mem_regions = int2str_r (nmemregions, info_len) use_m_stacks = int2str_r (n_mnk_stacks(1), info_len) use_n_stacks = int2str_r (n_mnk_stacks(2), info_len) use_k_stacks = int2str_r (n_mnk_stacks(3), info_len) @@ -562,10 +552,6 @@ CONTAINS WRITE(UNIT=unit_num, FMT=o_fmt) & plabel, "Multiplication driver", mm_name(1:info_len),& plabel, "Multiplication stack size", mm_ss_str(1:info_len) - IF (nmemregions .NE. 1) & - WRITE(UNIT=unit_num, FMT=o_fmt) & - plabel, "Multiplication stack memory regions",& - use_mem_regions(1:info_len) IF (nbuffers .NE. 1) & WRITE(UNIT=unit_num, FMT=o_fmt) & plabel, "Multiplication stack buffers",& diff --git a/src/dbcsr_lib/OBJECTDEFS b/src/dbcsr_lib/OBJECTDEFS index 20888f5ee2..748ae0365b 100644 --- a/src/dbcsr_lib/OBJECTDEFS +++ b/src/dbcsr_lib/OBJECTDEFS @@ -34,8 +34,6 @@ LIB3_OBJECTS =\ dbcsr_operations.o\ dbcsr_performance_multiply.o\ dbcsr_plasma_interface.o\ - dbcsr_pq_methods.o\ - dbcsr_pq_types.o\ dbcsr_ptr_util.o\ dbcsr_test_add.o\ dbcsr_test_methods.o\ diff --git a/src/dbcsr_lib/dbcsr_config.F b/src/dbcsr_lib/dbcsr_config.F index b8d9c4a766..4060f0d9ca 100644 --- a/src/dbcsr_lib/dbcsr_config.F +++ b/src/dbcsr_lib/dbcsr_config.F @@ -69,12 +69,11 @@ MODULE dbcsr_config mm_name_smm,& mm_name_plasma,& mm_name_cuda - PUBLIC :: nm_stacks, nn_stacks, nk_stacks, nstackbuffers, nstackmemregions + PUBLIC :: nm_stacks, nn_stacks, nk_stacks, nstackbuffers PUBLIC :: use_comm_thread, comm_thread_load ! PUBLIC :: is_configured - PUBLIC :: mm_thread_workshare ! First the constants are declared. @@ -156,16 +155,13 @@ MODULE dbcsr_config INTEGER, SAVE :: nn_stacks = 0 INTEGER, SAVE :: nk_stacks = 0 INTEGER, SAVE :: nstackbuffers = 1 - INTEGER, SAVE :: nstackmemregions = 1 - + ! Configuration of an MPI progress thread LOGICAL, SAVE :: use_comm_thread = .TRUE. INTEGER, SAVE :: comm_thread_load = 100 LOGICAL, SAVE :: is_configured = .FALSE. - ! Worksharing between threads - LOGICAL, SAVE :: mm_thread_workshare = .TRUE. CONTAINS @@ -201,16 +197,12 @@ CONTAINS ! use_comm_thread = .TRUE. comm_thread_load = 100 - mm_thread_workshare = .FALSE. - !$ mm_thread_workshare = .TRUE. mm_async = driver_is_async (mm_driver) IF (mm_async) THEN mm_host_driver = mm_driver_smm - mm_thread_workshare = .FALSE. ELSE mm_host_driver = mm_driver ENDIF - IF (has_cuda) mm_thread_workshare = .FALSE. CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE dbcsr_init_conf @@ -390,8 +382,8 @@ CONTAINS END FUNCTION dbcsr_get_conf_mm_stacksize - SUBROUTINE dbcsr_set_conf_nstacks (nstacks, nbuffers, nmemregs, error) - INTEGER, INTENT(IN) :: nstacks(:), nbuffers, nmemregs + SUBROUTINE dbcsr_set_conf_nstacks (nstacks, nbuffers, error) + INTEGER, INTENT(IN) :: nstacks(:), nbuffers TYPE(dbcsr_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_set_conf_nstacks', & @@ -407,12 +399,11 @@ CONTAINS nn_stacks = nstacks(2) nk_stacks = nstacks(3) nstackbuffers = nbuffers - nstackmemregions = nmemregs CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE dbcsr_set_conf_nstacks - SUBROUTINE dbcsr_get_conf_nstacks (nstacks, nbuffers, nmemregs, error) - INTEGER, INTENT(OUT) :: nstacks(:), nbuffers, nmemregs + SUBROUTINE dbcsr_get_conf_nstacks (nstacks, nbuffers, error) + INTEGER, INTENT(OUT) :: nstacks(:), nbuffers TYPE(dbcsr_error_type), INTENT(INOUT) :: error CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_get_conf_nstacks', & @@ -428,7 +419,6 @@ CONTAINS nstacks(2) = nn_stacks nstacks(3) = nk_stacks nbuffers = nstackbuffers - nmemregs = nstackmemregions CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE dbcsr_get_conf_nstacks diff --git a/src/dbcsr_lib/dbcsr_cuda_device.F b/src/dbcsr_lib/dbcsr_cuda_device.F index 76f716e66d..b123d227b7 100644 --- a/src/dbcsr_lib/dbcsr_cuda_device.F +++ b/src/dbcsr_lib/dbcsr_cuda_device.F @@ -149,7 +149,7 @@ CONTAINS IF (PRESENT (card_num)) THEN icard = card_num ELSE - + icard = 0 ENDIF istat = cuda_set_device_cu (icard) #else @@ -212,14 +212,7 @@ CONTAINS #else istat = -1 #endif - IF (istat /= 0) THEN - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not synchronize all threads",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) STOP "dbcsr_cuda_device_sync: Could not synchronize all threads" CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dbcsr_cuda_device_sync @@ -241,14 +234,7 @@ CONTAINS #else istat = -1 #endif - IF (istat /= 0) THEN - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not synchronize stream",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) STOP "dbcsr_cuda_stream_sync: Could not synchronize stream" CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dbcsr_cuda_stream_sync @@ -271,14 +257,7 @@ CONTAINS #else istat = -1 #endif - IF (istat /= 0) THEN - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not create streams",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) STOP "dbcsr_cuda_create_streams: Could not create streams" CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dbcsr_cuda_create_streams @@ -299,14 +278,7 @@ CONTAINS #else istat = -1 #endif - IF (istat /= 0) THEN - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not destroy streams",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) STOP "dbcsr_cuda_destroy_streams: Could not destroy streams" CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dbcsr_cuda_destroy_streams diff --git a/src/dbcsr_lib/dbcsr_cuda_memory.F b/src/dbcsr_lib/dbcsr_cuda_memory.F index 61030a1635..0ca91e83fe 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory.F @@ -61,7 +61,7 @@ MODULE dbcsr_cuda_memory PUBLIC :: dbcsr_cuda_dev_mem_init PUBLIC :: dbcsr_cuda_dev_mem_new, dbcsr_cuda_dev_mem_release,& dbcsr_cuda_dev_mem_hold - + PUBLIC :: dbcsr_cuda_dev_mem_info INTERFACE dbcsr_cuda_dev_mem_alloc MODULE PROCEDURE dev_mem_alloc_any @@ -88,12 +88,24 @@ MODULE dbcsr_cuda_memory MODULE PROCEDURE host_mem_alloc_i, host_mem_alloc_l MODULE PROCEDURE host_mem_alloc_r, host_mem_alloc_d MODULE PROCEDURE host_mem_alloc_c, host_mem_alloc_z + MODULE PROCEDURE host_mem_alloc_i_2D, host_mem_alloc_l_2D + MODULE PROCEDURE host_mem_alloc_r_2D, host_mem_alloc_d_2D + MODULE PROCEDURE host_mem_alloc_c_2D, host_mem_alloc_z_2D + MODULE PROCEDURE host_mem_alloc_i_4D, host_mem_alloc_l_4D + MODULE PROCEDURE host_mem_alloc_r_4D, host_mem_alloc_d_4D + MODULE PROCEDURE host_mem_alloc_c_4D, host_mem_alloc_z_4D END INTERFACE INTERFACE dbcsr_cuda_host_mem_dealloc MODULE PROCEDURE host_mem_dealloc_i, host_mem_dealloc_l MODULE PROCEDURE host_mem_dealloc_r, host_mem_dealloc_d MODULE PROCEDURE host_mem_dealloc_c, host_mem_dealloc_z + MODULE PROCEDURE host_mem_dealloc_i_2D, host_mem_dealloc_l_2D + MODULE PROCEDURE host_mem_dealloc_r_2D, host_mem_dealloc_d_2D + MODULE PROCEDURE host_mem_dealloc_c_2D, host_mem_dealloc_z_2D + MODULE PROCEDURE host_mem_dealloc_i_4D, host_mem_dealloc_l_4D + MODULE PROCEDURE host_mem_dealloc_r_4D, host_mem_dealloc_d_4D + MODULE PROCEDURE host_mem_dealloc_c_4D, host_mem_dealloc_z_4D END INTERFACE INTERFACE dbcsr_cuda_dev_mem_zero @@ -106,6 +118,17 @@ MODULE dbcsr_cuda_memory #if defined (__DBCSR_CUDA) + + INTERFACE + FUNCTION dbcsr_cuda_dev_mem_info(free, avail) RESULT (istat) BIND(C, name="dc_dev_mem_info_cu") + USE ISO_C_BINDING + INTEGER(KIND=C_INT), INTENT(OUT) :: free, avail + INTEGER(KIND=C_INT) :: istat + + END FUNCTION dbcsr_cuda_dev_mem_info + END INTERFACE + + INTERFACE FUNCTION cuda_dev_mem_alloc_cu(mem, n) RESULT (istat) BIND(C, name="dc_dev_mem_alloc") USE ISO_C_BINDING @@ -177,6 +200,17 @@ MODULE dbcsr_cuda_memory CONTAINS +#if ! defined (__DBCSR_CUDA) + FUNCTION dbcsr_cuda_dev_mem_info(free, avail) RESULT (istat) + INTEGER, INTENT(OUT) :: free, avail + INTEGER :: istat + + free = 0 + avail = 0 + istat = -1 + END FUNCTION dbcsr_cuda_dev_mem_info +#endif + #include "dbcsr_cuda_memory_i.F" #include "dbcsr_cuda_memory_l.F" @@ -189,6 +223,35 @@ CONTAINS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Encapsulated memory routines for the device +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_raw (host_mem_c_ptr, n_bytes, error) + TYPE(C_PTR), INTENT(OUT) :: host_mem_c_ptr + INTEGER, INTENT(IN) :: n_bytes + TYPE(dbcsr_error_type), INTENT(INOUT), & + OPTIONAL :: error + + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_raw', & + routineP = moduleN//':'//routineN + + INTEGER :: error_handle, istat + + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_alloc_cu(host_mem_c_ptr, & + INT(n_bytes, KIND=C_SIZE_T), 0_c_int, 0_c_int) + IF (istat /= 0) STOP "host_mem_alloc_raw: Could not allocate host pinned memory" +#else + STOP "host_mem_alloc_raw: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_alloc_raw + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dbcsr_cuda_dev_mem_init (dev_mem, error) TYPE(dbcsr_cuda_mem_type), POINTER :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT) :: error @@ -196,14 +259,16 @@ CONTAINS NULLIFY (dev_mem) END SUBROUTINE dbcsr_cuda_dev_mem_init + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dbcsr_cuda_dev_mem_new (dev_mem, data_type, error) TYPE(dbcsr_cuda_mem_type), POINTER :: dev_mem INTEGER, INTENT(IN), OPTIONAL :: data_type TYPE(dbcsr_error_type), INTENT(INOUT) :: error - INTEGER :: stat - - ALLOCATE (dev_mem, stat=stat) + ALLOCATE (dev_mem) dev_mem%data_type = 0 dev_mem%refcount = 1 IF (PRESENT (data_type)) THEN @@ -211,6 +276,10 @@ CONTAINS ENDIF END SUBROUTINE dbcsr_cuda_dev_mem_new + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dbcsr_cuda_dev_mem_hold (dev_mem, error) TYPE(dbcsr_cuda_mem_type), POINTER :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT) :: error @@ -219,21 +288,25 @@ CONTAINS END SUBROUTINE dbcsr_cuda_dev_mem_hold +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dbcsr_cuda_dev_mem_release (dev_mem, error) TYPE(dbcsr_cuda_mem_type), POINTER :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT) :: error - INTEGER :: stat - dev_mem%refcount = dev_mem%refcount - 1 IF (dev_mem%refcount == 0) THEN CALL dev_mem_dealloc_any (dev_mem, error=error) - DEALLOCATE (dev_mem, stat=stat) + DEALLOCATE (dev_mem) NULLIFY (dev_mem) ENDIF END SUBROUTINE dbcsr_cuda_dev_mem_release +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_any (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type), INTENT(INOUT) :: dev_mem INTEGER, INTENT(IN) :: n @@ -245,13 +318,10 @@ CONTAINS routineP = moduleN//':'//routineN INTEGER :: error_handle - TYPE(dbcsr_error_type) :: my_error ! --------------------------------------------------------------------------- - IF (PRESENT (error)) my_error = error - CALL dbcsr_error_set (routineN, error_handle, my_error) - IF (PRESENT (error)) error = my_error + IF (PRESENT (error)) CALL dbcsr_error_set(routineN, error_handle, error) SELECT CASE (dbcsr_cuda_dev_mem_get_type (dev_mem)) CASE (dbcsr_type_int_4) @@ -273,19 +343,16 @@ CONTAINS CALL dbcsr_cuda_dev_mem_alloc (dev_mem%d_z, n,& error=error, stat=stat) CASE default - IF (PRESENT (error)) my_error = error - CALL dbcsr_assert (.FALSE.,& - dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& - "Invalid data type", __LINE__, error=my_error) - IF (PRESENT (error)) error = my_error + STOP "dev_mem_alloc_any: Invalid data type" END SELECT - IF (PRESENT (error)) my_error = error - CALL dbcsr_error_stop (error_handle, my_error) - IF (PRESENT (error)) error = my_error + IF (PRESENT (error)) CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE dev_mem_alloc_any +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_any (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type), INTENT(INOUT) :: dev_mem INTEGER, INTENT(IN) :: n @@ -297,13 +364,10 @@ CONTAINS routineP = moduleN//':'//routineN INTEGER :: error_handle - TYPE(dbcsr_error_type) :: my_error ! --------------------------------------------------------------------------- - IF (PRESENT (error)) my_error = error - CALL dbcsr_error_set (routineN, error_handle, my_error) - IF (PRESENT (error)) error = my_error + IF (PRESENT (error)) CALL dbcsr_error_set(routineN, error_handle, error) SELECT CASE (dbcsr_cuda_dev_mem_get_type (dev_mem)) CASE (dbcsr_type_int_4) @@ -325,19 +389,16 @@ CONTAINS CALL dbcsr_cuda_dev_mem_realloc (dev_mem%d_z, n,& error=error, stat=stat) CASE default - IF (PRESENT (error)) my_error = error - CALL dbcsr_assert (.FALSE.,& - dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& - "Invalid data type", __LINE__, error=my_error) - IF (PRESENT (error)) error = my_error + STOP "dev_mem_realloc_any: Invalid data type" END SELECT - IF (PRESENT (error)) my_error = error - CALL dbcsr_error_stop (error_handle, my_error) - IF (PRESENT (error)) error = my_error + IF (PRESENT (error)) CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE dev_mem_realloc_any +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_any (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), & @@ -348,13 +409,10 @@ CONTAINS routineP = moduleN//':'//routineN INTEGER :: error_handle - TYPE(dbcsr_error_type) :: my_error ! --------------------------------------------------------------------------- - IF (PRESENT (error)) my_error = error - CALL dbcsr_error_set (routineN, error_handle, my_error) - IF (PRESENT (error)) error = my_error + IF (PRESENT (error)) CALL dbcsr_error_set(routineN, error_handle, error) SELECT CASE (dbcsr_cuda_dev_mem_get_type (dev_mem)) CASE (dbcsr_type_int_4) @@ -376,19 +434,16 @@ CONTAINS CALL dbcsr_cuda_dev_mem_dealloc (dev_mem%d_z,& error=error, stat=stat) CASE default - IF (PRESENT (error)) my_error = error - CALL dbcsr_assert (.FALSE.,& - dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& - "Invalid data type", __LINE__, error=my_error) - IF (PRESENT (error)) error = my_error + STOP "dev_mem_dealloc_any: Invalid data type" END SELECT - IF (PRESENT (error)) my_error = error - CALL dbcsr_error_stop (error_handle, my_error) - IF (PRESENT (error)) error = my_error + IF (PRESENT (error)) CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE dev_mem_dealloc_any +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_any (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type), INTENT(INOUT) :: dev_mem INTEGER, INTENT(IN) :: first, last diff --git a/src/dbcsr_lib/dbcsr_cuda_memory__nametype1_.template b/src/dbcsr_lib/dbcsr_cuda_memory__nametype1_.template index ed2916abc7..cb1b66cb6d 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory__nametype1_.template +++ b/src/dbcsr_lib/dbcsr_cuda_memory__nametype1_.template @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_[nametype1] (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_[shorttype1]), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_[nametype1]: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_[nametype1] +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_[nametype1] (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_[shorttype1]), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_[nametype1]: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_[nametype1] +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_[nametype1] (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_[shorttype1]), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_[nametype1]: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_[nametype1] - SUBROUTINE host_mem_alloc_[nametype1] (host_mem, n, write_combined, all_contexts, error, stat) - [type1], DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_[nametype1] (host_mem, n, error) + [type1], DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_[nametype1]', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*[bytes1], KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*[bytes1], error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_[nametype1] - SUBROUTINE host_mem_dealloc_[nametype1] (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_[nametype1]_2D (host_mem, n1, n2, error) + [type1], DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*[bytes1] + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_[nametype1]_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_[nametype1]_4D (host_mem, n1, n2, n3, n4, error) + [type1], DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*[bytes1] + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_[nametype1]_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_[nametype1] (host_mem, error) [type1], DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_[nametype1]', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - [type1], POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_[nametype1]: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_[nametype1]: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_[nametype1] +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_[nametype1]_2D (host_mem, error) + [type1], DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_[nametype1]_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_[nametype1]_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_[nametype1]: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_[nametype1]_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_[nametype1]_4D (host_mem, error) + [type1], DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_[nametype1]_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_[nametype1]_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_[nametype1]: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_[nametype1]_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_[nametype1] (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_[shorttype1]), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_memory_c.F b/src/dbcsr_lib/dbcsr_cuda_memory_c.F index 31b0492854..5d03818dd3 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory_c.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory_c.F @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_c (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_c4), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_c: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_c +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_c (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_c4), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_c: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_c +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_c (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_c4), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_c: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_c - SUBROUTINE host_mem_alloc_c (host_mem, n, write_combined, all_contexts, error, stat) - COMPLEX(kind=real_4), DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_c (host_mem, n, error) + COMPLEX(kind=real_4), DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_c', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*(2*real_4_size), KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*(2*real_4_size), error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_c - SUBROUTINE host_mem_dealloc_c (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_c_2D (host_mem, n1, n2, error) + COMPLEX(kind=real_4), DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*(2*real_4_size) + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_c_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_c_4D (host_mem, n1, n2, n3, n4, error) + COMPLEX(kind=real_4), DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*(2*real_4_size) + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_c_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_c (host_mem, error) COMPLEX(kind=real_4), DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_c', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - COMPLEX(kind=real_4), POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_c: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_c: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_c +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_c_2D (host_mem, error) + COMPLEX(kind=real_4), DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_c_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_c_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_c: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_c_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_c_4D (host_mem, error) + COMPLEX(kind=real_4), DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_c_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_c_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_c: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_c_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_c (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_c4), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_memory_d.F b/src/dbcsr_lib/dbcsr_cuda_memory_d.F index 69cfa6242e..96321acedb 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory_d.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory_d.F @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_d (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_r8), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_d: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_d +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_d (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_r8), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_d: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_d +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_d (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_r8), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_d: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_d - SUBROUTINE host_mem_alloc_d (host_mem, n, write_combined, all_contexts, error, stat) - REAL(kind=real_8), DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_d (host_mem, n, error) + REAL(kind=real_8), DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_d', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*real_8_size, KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*real_8_size, error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_d - SUBROUTINE host_mem_dealloc_d (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_d_2D (host_mem, n1, n2, error) + REAL(kind=real_8), DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*real_8_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_d_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_d_4D (host_mem, n1, n2, n3, n4, error) + REAL(kind=real_8), DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*real_8_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_d_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_d (host_mem, error) REAL(kind=real_8), DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_d', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - REAL(kind=real_8), POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_d: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_d: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_d +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_d_2D (host_mem, error) + REAL(kind=real_8), DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_d_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_d_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_d: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_d_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_d_4D (host_mem, error) + REAL(kind=real_8), DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_d_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_d_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_d: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_d_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_d (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_r8), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_memory_i.F b/src/dbcsr_lib/dbcsr_cuda_memory_i.F index 7c064f1e8b..86ded090c4 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory_i.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory_i.F @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_i (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_i4), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_i: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_i +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_i (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_i4), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_i: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_i +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_i (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_i4), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_i: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_i - SUBROUTINE host_mem_alloc_i (host_mem, n, write_combined, all_contexts, error, stat) - INTEGER(KIND=int_4), DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_i (host_mem, n, error) + INTEGER(KIND=int_4), DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_i', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*int_4_size, KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*int_4_size, error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_i - SUBROUTINE host_mem_dealloc_i (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_i_2D (host_mem, n1, n2, error) + INTEGER(KIND=int_4), DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*int_4_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_i_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_i_4D (host_mem, n1, n2, n3, n4, error) + INTEGER(KIND=int_4), DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*int_4_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_i_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_i (host_mem, error) INTEGER(KIND=int_4), DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_i', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - INTEGER(KIND=int_4), POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_i: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_i: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_i +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_i_2D (host_mem, error) + INTEGER(KIND=int_4), DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_i_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_i_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_i: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_i_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_i_4D (host_mem, error) + INTEGER(KIND=int_4), DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_i_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_i_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_i: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_i_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_i (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_i4), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_memory_l.F b/src/dbcsr_lib/dbcsr_cuda_memory_l.F index ed1061edaf..71163bc08e 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory_l.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory_l.F @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_l (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_i8), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_l: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_l +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_l (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_i8), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_l: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_l +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_l (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_i8), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_l: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_l - SUBROUTINE host_mem_alloc_l (host_mem, n, write_combined, all_contexts, error, stat) - INTEGER(KIND=int_8), DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_l (host_mem, n, error) + INTEGER(KIND=int_8), DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_l', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*int_8_size, KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*int_8_size, error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_l - SUBROUTINE host_mem_dealloc_l (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_l_2D (host_mem, n1, n2, error) + INTEGER(KIND=int_8), DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*int_8_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_l_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_l_4D (host_mem, n1, n2, n3, n4, error) + INTEGER(KIND=int_8), DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*int_8_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_l_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_l (host_mem, error) INTEGER(KIND=int_8), DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_l', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - INTEGER(KIND=int_8), POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_l: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_l: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_l +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_l_2D (host_mem, error) + INTEGER(KIND=int_8), DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_l_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_l_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_l: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_l_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_l_4D (host_mem, error) + INTEGER(KIND=int_8), DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_l_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_l_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_l: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_l_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_l (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_i8), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_memory_r.F b/src/dbcsr_lib/dbcsr_cuda_memory_r.F index b6f76ecb1e..cdf0275f7e 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory_r.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory_r.F @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_r (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_r4), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_r: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_r +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_r (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_r4), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_r: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_r +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_r (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_r4), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_r: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_r - SUBROUTINE host_mem_alloc_r (host_mem, n, write_combined, all_contexts, error, stat) - REAL(kind=real_4), DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_r (host_mem, n, error) + REAL(kind=real_4), DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_r', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*real_4_size, KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*real_4_size, error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_r - SUBROUTINE host_mem_dealloc_r (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_r_2D (host_mem, n1, n2, error) + REAL(kind=real_4), DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*real_4_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_r_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_r_4D (host_mem, n1, n2, n3, n4, error) + REAL(kind=real_4), DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*real_4_size + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_r_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_r (host_mem, error) REAL(kind=real_4), DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_r', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - REAL(kind=real_4), POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_r: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_r: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_r +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_r_2D (host_mem, error) + REAL(kind=real_4), DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_r_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_r_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_r: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_r_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_r_4D (host_mem, error) + REAL(kind=real_4), DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_r_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_r_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_r: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_r_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_r (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_r4), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_memory_z.F b/src/dbcsr_lib/dbcsr_cuda_memory_z.F index 9235f5f063..2a57289532 100644 --- a/src/dbcsr_lib/dbcsr_cuda_memory_z.F +++ b/src/dbcsr_lib/dbcsr_cuda_memory_z.F @@ -3,6 +3,9 @@ ! Copyright (C) 2000 - 2013 Urban Borstnik and the CP2K developers group ! !-----------------------------------------------------------------------------! +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_alloc_z (dev_mem, n, error, stat) TYPE(dbcsr_cuda_mem_type_c8), & INTENT(OUT) :: dev_mem @@ -28,18 +31,16 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_alloc_z: Could not allocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_alloc_z +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_dealloc_z (dev_mem, error, stat) TYPE(dbcsr_cuda_mem_type_c8), INTENT(INOUT) :: dev_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error @@ -63,19 +64,16 @@ ELSE istat = 0 ENDIF - IF (istat /= 0) THEN - IF (PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not deallocate GPU device memory",& - __LINE__, error=error) - ENDIF - ENDIF + IF (istat /= 0) & + STOP "dev_mem_dealloc_z: Could not deallocate GPU device memory" IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_dealloc_z +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_realloc_z (dev_mem, n, error, stat, memory_crunch) TYPE(dbcsr_cuda_mem_type_c8), & INTENT(INOUT) :: dev_mem @@ -112,108 +110,134 @@ #endif IF (istat /= 0) THEN dev_mem%len = -1 - IF (PRESENT(error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not reallocate GPU device memory",& - __LINE__, error=error) - ENDIF + STOP "dev_mem_realloc_z: Could not reallocate GPU device memory" ENDIF IF (PRESENT (stat)) stat = istat IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dev_mem_realloc_z - SUBROUTINE host_mem_alloc_z (host_mem, n, write_combined, all_contexts, error, stat) - COMPLEX(kind=real_8), DIMENSION(:), & - POINTER :: host_mem +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_z (host_mem, n, error) + COMPLEX(kind=real_8), DIMENSION(:), POINTER :: host_mem INTEGER, INTENT(IN) :: n - LOGICAL, INTENT(IN), OPTIONAL :: write_combined, all_contexts TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_alloc_z', & - routineP = moduleN//':'//routineN - - INTEGER :: error_handle, istat - INTEGER(KIND=c_int) :: all_flag, wc_flag TYPE(C_PTR) :: host_mem_c_ptr -! --------------------------------------------------------------------------- - - IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) - IF (PRESENT (write_combined)) THEN - wc_flag = 1 - ELSE - wc_flag = 0 - ENDIF - IF (PRESENT (all_contexts)) THEN - all_flag = 1 - ELSE - all_flag = 0 - ENDIF -#if defined (__DBCSR_CUDA) - istat = cuda_host_mem_alloc_cu(host_mem_c_ptr,& - INT(MAX(1,n)*(2*real_8_size), KIND=C_SIZE_T),& - wc_flag, all_flag) -#else - istat = -1 -#endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Could not allocate host pinned memory",& - __LINE__, error=error) - NULLIFY (host_mem) - ELSE -#if defined (__DBCSR_CUDA) - CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) -#endif - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + CALL host_mem_alloc_raw(host_mem_c_ptr, MAX(1,n)*(2*real_8_size), error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n) /)) END SUBROUTINE host_mem_alloc_z - SUBROUTINE host_mem_dealloc_z (host_mem, error, stat) +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_z_2D (host_mem, n1, n2, error) + COMPLEX(kind=real_8), DIMENSION(:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*(2*real_8_size) + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, (/ MAX(1,n1),MAX(1,n2) /)) + END SUBROUTINE host_mem_alloc_z_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_alloc_z_4D (host_mem, n1, n2, n3, n4, error) + COMPLEX(kind=real_8), DIMENSION(:,:,:,:), POINTER :: host_mem + INTEGER, INTENT(IN) :: n1, n2, n3, n4 + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + TYPE(C_PTR) :: host_mem_c_ptr + INTEGER :: n_bytes + n_bytes = MAX(1,n1)*MAX(1,n2)*MAX(1,n3)*MAX(1,n4)*(2*real_8_size) + CALL host_mem_alloc_raw(host_mem_c_ptr,n_bytes , error) + CALL C_F_POINTER (host_mem_c_ptr, host_mem, & + (/ MAX(1,n1),MAX(1,n2),MAX(1,n3),MAX(1,n4) /)) + END SUBROUTINE host_mem_alloc_z_4D + + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_z (host_mem, error) COMPLEX(kind=real_8), DIMENSION(:), & POINTER :: host_mem TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error - INTEGER, INTENT(OUT), OPTIONAL :: stat - CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_z', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, istat - COMPLEX(kind=real_8), POINTER :: host_first_el - TYPE(C_PTR) :: host_mem_c_ptr - -! --------------------------------------------------------------------------- + IF (SIZE (host_mem) == 0) RETURN IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) #if defined (__DBCSR_CUDA) - IF (SIZE (host_mem) .GT. 0) THEN - host_first_el => host_mem(1) - host_mem_c_ptr = C_LOC (host_first_el) - ENDIF - IF (SIZE (host_mem) .GT. 0) THEN - istat = cuda_host_mem_dealloc_cu (host_mem_c_ptr) - ENDIF + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_z: Error deallocating host pinned memory" #else - istat = -1 + STOP "host_mem_dealloc_z: DBCSR_CUDA not compiled in." #endif - IF (istat /= 0 .AND. PRESENT (error)) THEN - CALL dbcsr_assert (istat, "EQ", 0,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Error deallocating host pinned memory",& - __LINE__, error=error) - ENDIF - IF (PRESENT (stat)) stat = istat - IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE host_mem_dealloc_z +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_z_2D (host_mem, error) + COMPLEX(kind=real_8), DIMENSION(:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_z_2D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_z_2D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_z: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_z_2D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** + SUBROUTINE host_mem_dealloc_z_4D (host_mem, error) + COMPLEX(kind=real_8), DIMENSION(:,:,:,:), & + POINTER :: host_mem + TYPE(dbcsr_error_type), INTENT(INOUT), OPTIONAL :: error + CHARACTER(len=*), PARAMETER :: routineN = 'host_mem_dealloc_z_4D', & + routineP = moduleN//':'//routineN + INTEGER :: error_handle, istat + + IF (SIZE (host_mem) == 0) RETURN + IF (PRESENT (error)) CALL dbcsr_error_set (routineN, error_handle, error) +#if defined (__DBCSR_CUDA) + istat = cuda_host_mem_dealloc_cu(C_LOC(host_mem(1,1,1,1))) + IF (istat /= 0 ) & + STOP "host_mem_dealloc_z_4D: Error deallocating host pinned memory" +#else + STOP "host_mem_dealloc_z: DBCSR_CUDA not compiled in." +#endif + IF (PRESENT (error)) CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE host_mem_dealloc_z_4D + + +! ***************************************************************************** +!> \brief +! ***************************************************************************** SUBROUTINE dev_mem_zero_z (dev_mem, first, last, error) TYPE(dbcsr_cuda_mem_type_c8), & INTENT(INOUT) :: dev_mem diff --git a/src/dbcsr_lib/dbcsr_cuda_types.F b/src/dbcsr_lib/dbcsr_cuda_types.F index 485435532b..60fca2717e 100644 --- a/src/dbcsr_lib/dbcsr_cuda_types.F +++ b/src/dbcsr_lib/dbcsr_cuda_types.F @@ -32,7 +32,10 @@ MODULE dbcsr_cuda_types PUBLIC :: dbcsr_cuda_mem_type_i4, dbcsr_cuda_mem_type_i8,& dbcsr_cuda_mem_type_r4, dbcsr_cuda_mem_type_r8,& dbcsr_cuda_mem_type_c4, dbcsr_cuda_mem_type_c8 + + PUBLIC :: dbcsr_cuda_mem_p_type + ! TODO: these datastructures are pointless. They hold C_PTR anyways. TYPE dbcsr_cuda_mem_type_i4 TYPE(C_PTR) :: ref INTEGER :: len, req_len @@ -74,7 +77,10 @@ MODULE dbcsr_cuda_types TYPE(dbcsr_cuda_mem_type_c8) :: d_z INTEGER :: refcount END TYPE dbcsr_cuda_mem_type - - + + + TYPE dbcsr_cuda_mem_p_type + TYPE(dbcsr_cuda_mem_type), POINTER :: p + END TYPE dbcsr_cuda_mem_p_type END MODULE dbcsr_cuda_types diff --git a/src/dbcsr_lib/dbcsr_data_methods.F b/src/dbcsr_lib/dbcsr_data_methods.F index ece6cc93df..b548621742 100644 --- a/src/dbcsr_lib/dbcsr_data_methods.F +++ b/src/dbcsr_lib/dbcsr_data_methods.F @@ -292,17 +292,13 @@ CONTAINS CASE (dbcsr_memory_CUDA_host_pinned) SELECT CASE (data_type) CASE (dbcsr_type_real_4) - CALL dbcsr_cuda_host_mem_alloc (area%r_sp, sizes(1), stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_alloc (area%r_sp, sizes(1), error=error) CASE (dbcsr_type_real_8) - CALL dbcsr_cuda_host_mem_alloc (area%r_dp, sizes(1), stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_alloc (area%r_dp, sizes(1), error=error) CASE (dbcsr_type_complex_4) - CALL dbcsr_cuda_host_mem_alloc (area%c_sp, sizes(1), stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_alloc (area%c_sp, sizes(1), error=error) CASE (dbcsr_type_complex_8) - CALL dbcsr_cuda_host_mem_alloc (area%c_dp, sizes(1), stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_alloc (area%c_dp, sizes(1), error=error) CASE (dbcsr_type_real_8_2d, dbcsr_type_real_4_2d,& dbcsr_type_complex_8_2d, dbcsr_type_complex_4_2d) CALL dbcsr_assert (.FALSE.,& @@ -399,20 +395,16 @@ CONTAINS CASE (dbcsr_memory_CUDA_host_pinned) SELECT CASE (data_type) CASE (dbcsr_type_real_4) - CALL dbcsr_cuda_host_mem_dealloc (area%r_sp, stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_dealloc (area%r_sp, error=error) NULLIFY (area%r_sp) CASE (dbcsr_type_real_8) - CALL dbcsr_cuda_host_mem_dealloc (area%r_dp, stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_dealloc (area%r_dp, error=error) NULLIFY (area%r_dp) CASE (dbcsr_type_complex_4) - CALL dbcsr_cuda_host_mem_dealloc (area%c_sp, stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_dealloc (area%c_sp, error=error) NULLIFY (area%c_sp) CASE (dbcsr_type_complex_8) - CALL dbcsr_cuda_host_mem_dealloc (area%c_dp, stat=stat,& - error=error) + CALL dbcsr_cuda_host_mem_dealloc (area%c_dp, error=error) NULLIFY (area%c_dp) CASE (dbcsr_type_real_8_2d, dbcsr_type_real_4_2d,& dbcsr_type_complex_8_2d, dbcsr_type_complex_4_2d) diff --git a/src/dbcsr_lib/dbcsr_mm_cannon.F b/src/dbcsr_lib/dbcsr_mm_cannon.F index 740564903a..74977b3eb1 100644 --- a/src/dbcsr_lib/dbcsr_mm_cannon.F +++ b/src/dbcsr_lib/dbcsr_mm_cannon.F @@ -63,10 +63,12 @@ MODULE dbcsr_mm_cannon dbcsr_mp_numnodes, dbcsr_mp_pgrid, dbcsr_nblkcols_local, & dbcsr_nblkcols_total, dbcsr_nblkrows_local, dbcsr_nblkrows_total, & dbcsr_nfullcols_local, dbcsr_nfullrows_local, dbcsr_valid_index - USE dbcsr_mm_multrec, ONLY: dbcsr_multrec_finalize,& - dbcsr_multrec_init,& - dbcsr_multrec_sparse - USE dbcsr_mm_types, ONLY: carrier_type + USE dbcsr_mm_multrec, ONLY: dbcsr_mm_multrec_finalize,& + dbcsr_mm_multrec_init,& + dbcsr_mm_multrec_lib_finalize,& + dbcsr_mm_multrec_lib_init,& + dbcsr_mm_multrec_multiply + USE dbcsr_mm_types, ONLY: multrec_carrier_type USE dbcsr_mp_operations, ONLY: dbcsr_irecv_any,& dbcsr_isend_any,& dbcsr_mp_type_from_anytype @@ -91,10 +93,33 @@ MODULE dbcsr_mm_cannon LOGICAL, PARAMETER :: debug_mod = .FALSE. LOGICAL, PARAMETER :: careful_mod = .FALSE. - PUBLIC :: dbcsr_mult_m_e_e + + PUBLIC :: dbcsr_mm_cannon_lib_init, dbcsr_mm_cannon_lib_finalize + PUBLIC :: dbcsr_mm_cannon_multiply -CONTAINS + CONTAINS + +! ***************************************************************************** +! \brief Initialize the library +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_cannon_lib_init(error) + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + CALL dbcsr_mm_multrec_lib_init(error) + END SUBROUTINE + + +! ***************************************************************************** +! \brief Finalize the library +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_cannon_lib_finalize(error) + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + CALL dbcsr_mm_multrec_lib_finalize(error) + END SUBROUTINE ! ***************************************************************************** @@ -108,7 +133,7 @@ CONTAINS !> existing product matrix; default is no !> \param[out] flop (optional) effective flop ! ***************************************************************************** - SUBROUTINE dbcsr_mult_m_e_e (left_set, right_set, product_matrix,& + SUBROUTINE dbcsr_mm_cannon_multiply(left_set, right_set, product_matrix,& error, retain_sparsity, & filter_eps, flop) TYPE(dbcsr_2d_array_type), POINTER :: left_set, right_set @@ -118,7 +143,7 @@ CONTAINS REAL(kind=real_8), INTENT(in), OPTIONAL :: filter_eps INTEGER(KIND=int_8), INTENT(OUT) :: flop - CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mult_m_e_e', & + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_cannon_multiply', & routineP = moduleN//':'//routineN CHARACTER(LEN=80), PARAMETER :: & fdata = '(A,1X,I4,"(",2(I3),"x",2(I3),")","(",I3,"x",I3,")")', fxfer = & @@ -179,7 +204,6 @@ CONTAINS right_fill REAL(kind=sp), ALLOCATABLE, DIMENSION(:) :: left_norms, right_norms, & row_max_epss - TYPE(carrier_type), SAVE :: carrier TYPE(dbcsr_2d_array_type), POINTER :: left_buffer_1, left_buffer_2, & left_buffer_calc, left_buffer_comm, right_buffer_1, right_buffer_2, & right_buffer_calc, right_buffer_comm @@ -199,8 +223,9 @@ CONTAINS left_send_subtypes, & right_recv_subtypes, & right_send_subtypes + TYPE(multrec_carrier_type), SAVE :: multrec_carrier -!$OMP THREADPRIVATE (carrier) +!$OMP THREADPRIVATE (multrec_carrier) ! --------------------------------------------------------------------------- @@ -659,13 +684,11 @@ CONTAINS !$omp right_data_sr, right_data_rr, left_data_sr, left_data_rr,& !$omp right_index_sr, right_index_rr, left_index_sr, left_index_rr), & !$omp shared (a_dev, b_dev) firstprivate (error) - CALL dbcsr_multrec_init(& + CALL dbcsr_mm_multrec_init(& left_buffer_comm%mats(1, 1)%m,& right_buffer_comm%mats(1, 1)%m,& product_matrix%m,& - carrier,& - right_data_sr, right_data_rr, left_data_sr, left_data_rr,& - right_index_sr, right_index_rr, left_index_sr, left_index_rr, & + multrec_carrier,& keep_sparsity=keep_sparsity,& eps=filter_eps,& row_max_epss = row_max_epss,& @@ -1042,16 +1065,15 @@ CONTAINS !$omp reduction (+: flop_single) t_error=error CALL dbcsr_error_set(routineN//"_multrec_sparse", error_handler2, t_error) - CALL dbcsr_multrec_sparse(& + CALL dbcsr_mm_multrec_multiply(& left_buffer_calc%mats(1, v_ki+1)%m,& right_buffer_calc%mats(v_ki+1, 1)%m,& product_matrix%m,& - carrier,& - keep_sparsity=keep_sparsity,& + multrec_carrier,& + keep_sparsity=keep_sparsity,& flop=flop_single,& a_norms=left_norms, b_norms=right_norms,& - eps=filter_eps,& - row_max_epss = row_max_epss, error=t_error) + error=t_error) ! once multiplication is complete, thread zero polls MPI until ! all other threads have also completed !$omp atomic @@ -1062,7 +1084,14 @@ CONTAINS !$ nthreads = omp_get_num_threads() IF (use_comm_thread .AND. (ithread .EQ. 0)) THEN DO WHILE (threads_finished .NE. nthreads) - CALL progress_comms(carrier) + CALL mp_testany(right_data_sr) + CALL mp_testany(right_data_rr) + CALL mp_testany(left_data_sr) + CALL mp_testany(left_data_rr) + CALL mp_testany(right_index_sr) + CALL mp_testany(right_index_rr) + CALL mp_testany(left_index_sr) + CALL mp_testany(left_index_rr) !$omp flush (threads_finished) END DO END IF @@ -1097,14 +1126,14 @@ CONTAINS ! -!$omp parallel & +!$omp parallel & !$omp default (none) & !$omp private (t_error) & !$omp shared (product_matrix, error) ! t_error = error ! Finalize multiplication - CALL dbcsr_multrec_finalize (carrier, product_matrix%m, t_error) + CALL dbcsr_mm_multrec_finalize(multrec_carrier, product_matrix%m, t_error) !$omp end parallel ! IF (ALLOCATED (right_norms)) THEN @@ -1181,7 +1210,7 @@ CONTAINS i = real_8_size * 2 END SELECT CALL dbcsr_error_stop(error_handler, error) - END SUBROUTINE dbcsr_mult_m_e_e + END SUBROUTINE dbcsr_mm_cannon_multiply ! ****************************************************************************** @@ -1726,24 +1755,6 @@ CONTAINS CALL dbcsr_error_stop(error_handle, error) END SUBROUTINE calculate_norms - - -! ***************************************************************************** -!> \brief Call in MPI to progrss any outstanding communications -! ***************************************************************************** - SUBROUTINE progress_comms(carrier) - TYPE(carrier_type), INTENT(inout) :: carrier - - CALL mp_testany(carrier%right_data_sr) - CALL mp_testany(carrier%right_data_rr) - CALL mp_testany(carrier%left_data_sr) - CALL mp_testany(carrier%left_data_rr) - CALL mp_testany(carrier%right_index_sr) - CALL mp_testany(carrier%right_index_rr) - CALL mp_testany(carrier%left_index_sr) - CALL mp_testany(carrier%left_index_rr) - END SUBROUTINE - #include "dbcsr_mm_cannon_d.F" #include "dbcsr_mm_cannon_z.F" #include "dbcsr_mm_cannon_s.F" diff --git a/src/dbcsr_lib/dbcsr_mm_csr.F b/src/dbcsr_lib/dbcsr_mm_csr.F index ae6d306ce2..d2544935cd 100644 --- a/src/dbcsr_lib/dbcsr_mm_csr.F +++ b/src/dbcsr_lib/dbcsr_mm_csr.F @@ -5,9 +5,9 @@ ! ***************************************************************************** !> \brief Third layer of the dbcsr matrix-matrix multiplication. -!> It collects the full matrix blocks, which need to be multiplied, +!> It collects the full matrix blocks, which need to be multiplied, !> and stores their parameters in various stacks. -!> After a certain amount of parameters is collected it dispatches +!> After a certain amount of parameters is collected it dispatches !> the filled stacks to either the CPU or the GPU. !> !> \author Urban Borstnik @@ -16,341 +16,466 @@ !> - 2010-02-23 Moved from dbcsr_operations !> - 2011-11 Moved parameter-stack processing routines to !> dbcsr_mm_methods. -!> - 2013-01 reorganized code (Ole Schuett) +!> - 2013-01 extensive refactoring (Ole Schuett) ! ***************************************************************************** MODULE dbcsr_mm_csr USE array_types, ONLY: array_data USE dbcsr_config, ONLY: dbcsr_get_conf_nstacks,& - mm_async,& mm_driver,& - mm_driver_cuda,& - mm_host_driver,& - mm_stack_size,& - mm_thread_workshare,& - use_comm_thread + mm_host_driver USE dbcsr_error_handling USE dbcsr_kinds, ONLY: int_1,& int_4,& int_8,& real_8,& sp - USE dbcsr_message_passing, ONLY: mp_testany - USE dbcsr_mm_driver, ONLY: dbcsr_mm_driver_inner_init,& + USE dbcsr_mm_driver, ONLY: dbcsr_mm_driver_inner_finalize,& + dbcsr_mm_driver_inner_init,& + dbcsr_mm_driver_lib_finalize,& + dbcsr_mm_driver_lib_init,& dbcsr_mm_driver_outer_finalize,& - dbcsr_mm_driver_outer_init - USE dbcsr_mm_stack, ONLY: enqueue_ps_group,& - get_stack_or_process_queue,& - process_queue_mine,& - process_queue_others,& - process_queue_preempt - USE dbcsr_mm_types, ONLY: carrier_type,& - ele_type,& - hash_table_type - USE dbcsr_pq_methods, ONLY: & - dbcsr_pq_create, dbcsr_pq_destroy, dbcsr_pq_flush_level_chg, & - dbcsr_pq_handoff_level_chg, dbcsr_pq_mark_done, dbcsr_pq_refresh, & - dbcsr_pq_share, dbcsr_pq_unshare, dbcsr_ps_set_advance, & - dbcsr_ps_set_create, dbcsr_ps_set_destroy, dbcsr_ps_set_get_group_p, & - dbcsr_ps_set_get_n_working, dbcsr_ps_target_add_data, & - dbcsr_ps_target_new, dbcsr_ps_target_release, dbcsr_psg_add_data_ab, & - dbcsr_psg_get_state, dbcsr_psg_rm_data_ab, dbcsr_psg_view_close, & - dbcsr_psg_view_open - USE dbcsr_pq_types, ONLY: & - dbcsr_pq_type, dbcsr_ps_group_type, dbcsr_ps_set_type, & - dbcsr_ps_state_queued, dbcsr_ps_target_obj, dbcsr_ps_width, p_a_first, & - p_b_first, p_c_blk, p_c_first, p_k, p_m, p_n + dbcsr_mm_driver_outer_init,& + dbcsr_mm_driver_process_stack + USE dbcsr_mm_types, ONLY: & + csr_carrier_type, dbcsr_ps_state_empty, dbcsr_ps_state_working, & + ele_type, hash_table_type, p_a_first, p_b_first, p_c_blk, p_c_first, & + p_k, p_m, p_n, stack_descriptor_type USE dbcsr_ptr_util, ONLY: ensure_array_size USE dbcsr_toollib, ONLY: sort - USE dbcsr_types, ONLY: dbcsr_memory_CUDA_host_pinned,& - dbcsr_memory_default,& - dbcsr_type + USE dbcsr_types, ONLY: dbcsr_type USE dbcsr_util, ONLY: map_most_common !$ USE OMP_LIB - + IMPLICIT NONE - + PRIVATE - + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_mm_csr' LOGICAL, PARAMETER :: debug_mod = .FALSE. LOGICAL, PARAMETER :: careful_mod = .FALSE. + REAL, PARAMETER :: default_resize_factor = 1.618034 - !> \var max_stack_block_size The maximal block size to be specially !> treated. INTEGER, PARAMETER :: max_stack_block_size = HUGE (INT (0)) - - REAL, PARAMETER :: default_resize_factor = 1.618034 - - - PUBLIC :: csr_multiply_outer_init, csr_multiply_outer_finalize - PUBLIC :: csr_multiply_inner_init, csr_multiply_inner_finalize - PUBLIC :: csr_multiply_unwrap - - + + + PUBLIC :: dbcsr_mm_csr_lib_init, dbcsr_mm_csr_lib_finalize + PUBLIC :: dbcsr_mm_csr_outer_init, dbcsr_mm_csr_outer_finalize + PUBLIC :: dbcsr_mm_csr_inner_init, dbcsr_mm_csr_inner_finalize + PUBLIC :: dbcsr_mm_csr_multiply + + CONTAINS ! ***************************************************************************** -!> \brief Performs multiplication of smaller submatrices. -!> -!> This routine is used for setting up and calling csr_multiply with -!> as few argument indirections as possible. +! \brief Initialize the library +! \author Ole Schuett ! ***************************************************************************** - SUBROUTINE csr_multiply_unwrap(mi, mf, ni, nf, ki, kf,& - ai, af, a_index, bi, bf, b_index, & - carrier, error) - INTEGER, INTENT(IN) :: mi, mf, ni, nf, ki, kf, ai, af - INTEGER, DIMENSION(1:3, 1:af), & - INTENT(IN) :: a_index - INTEGER, INTENT(IN) :: bi, bf - INTEGER, DIMENSION(1:3, 1:bf), & - INTENT(IN) :: b_index - TYPE(carrier_type), INTENT(INOUT) :: carrier + SUBROUTINE dbcsr_mm_csr_lib_init(error) TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'csr_multiply_unwrap', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: dbg = .FALSE. + CALL dbcsr_mm_driver_lib_init(error) + END SUBROUTINE + + +! ***************************************************************************** +! \brief Finalize the library +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_csr_lib_finalize(error) + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + CALL dbcsr_mm_driver_lib_finalize(error) + END SUBROUTINE + + +! ***************************************************************************** +! \brief A wrapper around dbcsr_mm_csr_multiply_low to avoid expensive dereferencings. +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_csr_multiply(mi, mf, ni, nf, ki, kf,& + ai, af,& + bi, bf,& + m_sizes, n_sizes, k_sizes,& + c_local_rows, c_local_cols,& + c_has_symmetry, keep_sparsity, use_eps,& + row_max_epss,& + flop,& + a_index, b_index, a_norms, b_norms,& + product, csr_carrier, error) + INTEGER, INTENT(IN) :: mi, mf, ni, nf, ki, kf, ai, & + af, bi, bf + INTEGER, DIMENSION(:), INTENT(INOUT) :: m_sizes, n_sizes, k_sizes, & + c_local_rows, c_local_cols + LOGICAL, INTENT(INOUT) :: c_has_symmetry, & + keep_sparsity, use_eps + REAL(kind=sp), DIMENSION(:) :: row_max_epss + INTEGER(KIND=int_8), INTENT(INOUT) :: flop + INTEGER, DIMENSION(1:3, 1:af), & + INTENT(IN) :: a_index + INTEGER, DIMENSION(1:3, 1:bf), & + INTENT(IN) :: b_index + REAL(KIND=sp), DIMENSION(:), POINTER :: a_norms, b_norms + TYPE(dbcsr_type), INTENT(INOUT) :: product + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier + TYPE(dbcsr_error_type), INTENT(INOUT) :: error INTEGER :: ithread, max_new_nblks, & - n_a_norms, n_b_norms, & - nblks_new, nstacks - INTEGER, ALLOCATABLE, DIMENSION(:) :: a_row_p, b_row_p - INTEGER, ALLOCATABLE, DIMENSION(:, :) :: a_blk_info, b_blk_info - LOGICAL :: advance_memreg - REAL(KIND=sp), DIMENSION(1:af-ai+1) :: csr_a_norms - REAL(KIND=sp), DIMENSION(1:bf-bi+1) :: csr_b_norms - TYPE(dbcsr_ps_group_type), POINTER :: ps_group + nblks_new + + ithread = 0 + !$ ithread = omp_get_thread_num() + + ! This has to be done here because ensure_array_size() expects a pointer. + ! the maximum number of blocks can be safely estimated by considering both the rowxcol, + ! but also the blocks the latter can never be larger than norec**2, which is a 'small' constant + max_new_nblks = MIN(INT(mf-mi+1,int_8) * INT(nf-ni+1,int_8), & + INT(af-ai+1,int_8) * INT(bf-bi+1,int_8)) + + nblks_new = product%wms(ithread+1)%lastblk + max_new_nblks + + CALL ensure_array_size(product%wms(ithread+1)%row_i, ub=nblks_new,& + factor=default_resize_factor, error=error) + CALL ensure_array_size(product%wms(ithread+1)%col_i, ub=nblks_new,& + factor=default_resize_factor, error=error) + CALL ensure_array_size(product%wms(ithread+1)%blk_p, ub=nblks_new,& + factor=default_resize_factor, error=error) + + CALL dbcsr_mm_csr_multiply_low(mi=mi, mf=mf,ni=ni, nf=nf, ki=ki, kf=kf,& + ai=ai, af=af,& + bi=bi, bf=bf,& + c_row_i=product%wms(ithread+1)%row_i,& + c_col_i=product%wms(ithread+1)%col_i,& + c_blk_p=product%wms(ithread+1)%blk_p,& + lastblk =product%wms(ithread+1)%lastblk, & + datasize=product%wms(ithread+1)%datasize,& + m_sizes=m_sizes, n_sizes=n_sizes, k_sizes=k_sizes,& + c_local_rows=c_local_rows, c_local_cols=c_local_cols,& + c_has_symmetry=c_has_symmetry, keep_sparsity=keep_sparsity,& + use_eps=use_eps,& + row_max_epss=row_max_epss,& + flop=flop,& + row_size_maps=csr_carrier%m_size_maps,& + col_size_maps=csr_carrier%n_size_maps,& + k_size_maps=csr_carrier%k_size_maps,& + row_size_maps_size=csr_carrier%m_size_maps_size,& + col_size_maps_size=csr_carrier%n_size_maps_size,& + k_size_maps_size=csr_carrier%k_size_maps_size,& + nm_stacks=csr_carrier%nm_stacks, nn_stacks=csr_carrier%nn_stacks,& + nk_stacks=csr_carrier%nk_stacks, & + stack_map=csr_carrier%stack_map,& + c_hashes=csr_carrier%c_hashes,& + a_index=a_index, b_index=b_index,& + a_norms=a_norms, b_norms=b_norms,& + csr_carrier=csr_carrier,& + error=error) + + END SUBROUTINE dbcsr_mm_csr_multiply + + +! ***************************************************************************** +!> \brief Performs multiplication of smaller submatrices. +! ***************************************************************************** + SUBROUTINE dbcsr_mm_csr_multiply_low(mi, mf, ni, nf, ki, kf,& + ai, af,& + bi, bf,& + c_hashes, c_row_i, c_col_i, c_blk_p, lastblk, datasize,& + m_sizes, n_sizes, k_sizes,& + c_local_rows, c_local_cols,& + c_has_symmetry, keep_sparsity, use_eps,& + row_size_maps, col_size_maps, k_size_maps,& + row_size_maps_size, col_size_maps_size, k_size_maps_size,& + nm_stacks, nn_stacks, nk_stacks, stack_map,& + row_max_epss, & + flop, a_index, b_index,a_norms, b_norms, csr_carrier, error) + INTEGER, INTENT(IN) :: mi, mf, ni, nf, ki, kf, ai, & + af, bi, bf + TYPE(hash_table_type), DIMENSION(:), & + INTENT(INOUT) :: c_hashes + INTEGER, DIMENSION(:), INTENT(INOUT) :: c_row_i, c_col_i, c_blk_p + INTEGER, INTENT(INOUT) :: lastblk, datasize + INTEGER, DIMENSION(:), INTENT(IN) :: m_sizes, n_sizes, k_sizes, & + c_local_rows, c_local_cols + LOGICAL, INTENT(IN) :: c_has_symmetry, & + keep_sparsity, use_eps + INTEGER, INTENT(IN) :: row_size_maps_size, & + k_size_maps_size, & + col_size_maps_size + INTEGER(KIND=int_4), & + DIMENSION(0:row_size_maps_size-1), & + INTENT(IN) :: row_size_maps + INTEGER(KIND=int_4), & + DIMENSION(0:col_size_maps_size-1), & + INTENT(IN) :: col_size_maps + INTEGER(KIND=int_4), & + DIMENSION(0:k_size_maps_size-1), & + INTENT(IN) :: k_size_maps + INTEGER, INTENT(IN) :: nm_stacks, nn_stacks, & + nk_stacks + INTEGER(KIND=int_1), DIMENSION(& + nn_stacks+1, nk_stacks+1, nm_stacks+1)& + , INTENT(IN) :: stack_map + REAL(kind=sp), DIMENSION(:) :: row_max_epss + INTEGER(KIND=int_8), INTENT(INOUT) :: flop + INTEGER, DIMENSION(1:3, 1:af), & + INTENT(IN) :: a_index + INTEGER, DIMENSION(1:3, 1:bf), & + INTENT(IN) :: b_index + REAL(KIND=sp), DIMENSION(:), POINTER :: a_norms, b_norms + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_csr_multiply_low', & + routineP = moduleN//':'//routineN + LOGICAL, PARAMETER :: dbg = .FALSE., & + local_timing = .FALSE. + + INTEGER :: a_blk, a_col_l, a_row_l, b_blk, b_col_l, c, c_blk_id, & + c_col_logical, c_nze, c_row_logical, ithread, k_size, m_size, & + mapped_col_size, mapped_k_size, mapped_row_size, n_a_norms, n_b_norms, & + n_size, nstacks, s_dp, ws + INTEGER, DIMENSION(mi:mf+1) :: a_row_p + INTEGER, DIMENSION(ki:kf+1) :: b_row_p + INTEGER, DIMENSION(:, :, :), POINTER :: stackcol_data + INTEGER, DIMENSION(:), POINTER :: stackcol_fillcount + INTEGER, DIMENSION(2, bf-bi+1) :: b_blk_info + INTEGER, DIMENSION(2, af-ai+1) :: a_blk_info + INTEGER(KIND=int_4) :: offset + LOGICAL :: block_exists, flush_stack + REAL(kind=sp) :: a_norm, a_row_eps, b_norm + REAL(KIND=sp), DIMENSION(1:af-ai+1) :: left_norms + REAL(KIND=sp), DIMENSION(1:bf-bi+1) :: right_norms ! --------------------------------------------------------------------------- - IF (dbg) THEN - WRITE(*,'(I7,1X,5(A,2(1X,I7)))')0,"uwr", mi, mf,",",ni,nf,",",ki,kf,"/",ai,af,",",bi,bf + ithread = 0 + !$ ithread = omp_get_thread_num() + + nstacks = SIZE(csr_carrier%stackgrid_data, 3) + + IF (use_eps) THEN + n_a_norms = af-ai+1 + n_b_norms = bf-bi+1 + ELSE + n_a_norms = 0 + n_b_norms = 0 ENDIF - IF (af-ai+1 .GT. 0 .AND. bf-bi+1 .GT. 0) THEN - ! the maximum number of blocks can be safely estimated by considering both the rowxcol, - ! but also the blocks the latter can never be larger than norec**2, which is a 'small' constant - max_new_nblks = MIN(INT(mf-mi+1,int_8) * INT(nf-ni+1,int_8), & - INT(af-ai+1,int_8) * INT(bf-bi+1,int_8)) - nblks_new = carrier%lastblk + max_new_nblks + ! + ! Build the indices + CALL build_csr_index (mi,mf,ai,af,a_row_p, a_blk_info, a_index,& + n_a_norms, left_norms, a_norms) + CALL build_csr_index (ki,kf,bi,bf,b_row_p, b_blk_info, b_index,& + n_b_norms, right_norms, b_norms) - CALL ensure_array_size(carrier%my_wm%row_i, ub=nblks_new,& - factor=default_resize_factor, error=error) - CALL ensure_array_size(carrier%my_wm%col_i, ub=nblks_new,& - factor=default_resize_factor, error=error) - CALL ensure_array_size(carrier%my_wm%blk_p, ub=nblks_new,& - factor=default_resize_factor, error=error) - ALLOCATE (a_row_p(mi:mf+1)) - ALLOCATE (b_row_p(ki:kf+1)) - ALLOCATE (a_blk_info(2,af-ai+1)) - ALLOCATE (b_blk_info(2,bf-bi+1)) - ! - IF (carrier%use_eps) THEN - n_a_norms = af-ai+1 - n_b_norms = bf-bi+1 - ELSE - n_a_norms = 0 - n_b_norms = 0 - ENDIF - ! - ! Build the indices - CALL build_csr_index (mi,mf,ai,af,a_row_p, a_blk_info, a_index,& - n_a_norms, csr_a_norms, carrier%a_norms) - CALL build_csr_index (ki,kf,bi,bf,b_row_p, b_blk_info, b_index,& - n_b_norms, csr_b_norms, carrier%b_norms) - ! - ! This is called here to get the ps_group, a parameter stack. - ! The memory region (of the parameter set) it belongs to must - ! remain unchanged throughout the csr_multiply call while the - ! buffer is allowed to change. The parameter stack groups of - ! all the buffers of a memory region share one "super parameter - ! stack" (\see dbcsr_ps_set_create). This super parameter - ! stack is passed directly to the csr_multiply routine - ! (ps_group%master%s%parameters) for efficiency reasons. - CALL get_stack_or_process_queue (carrier%param_sets, carrier%queue,& - ps_group, driver=mm_host_driver, error=error) - ! - nstacks = SIZE(ps_group%stacks) - CALL csr_multiply (mi, mf, ni, nf, ki, kf,& - ai, af, a_row_p, a_blk_info, bi, bf, b_row_p, b_blk_info,& - carrier%c_hashes,& - carrier%my_wm%row_i, carrier%my_wm%col_i, carrier%my_wm%blk_p,& - carrier%lastblk, carrier%datasize,& - carrier%m_sizes, carrier%n_sizes, carrier%k_sizes,& - carrier%c_local_rows, carrier%c_local_cols,& - carrier%c_has_symmetry, carrier%keep_sparsity, carrier%use_eps,& - carrier%param_sets,& - carrier%queue,& - ps_group%master%s%parameters, advance_memreg,& - carrier%m_size_maps, carrier%n_size_maps, carrier%k_size_maps,& - carrier%m_size_maps_size, carrier%n_size_maps_size, carrier%k_size_maps_size,& - carrier%nm_stacks, carrier%nn_stacks, carrier%nk_stacks, & - carrier%stack_map,& - nstacks, carrier%default_stack, & - carrier%row_max_epss, csr_a_norms, csr_b_norms,& - carrier%flop, error) - ! - ! If a stack group was filled up during the csr_multiply call then - ! we roll around to a new memory region. - IF (advance_memreg) THEN - CALL dbcsr_ps_set_advance (carrier%param_sets,& - advance_memreg = .TRUE.,& - error=error) - ! And make some progress in MPI - ithread = 0 -!$ ithread = omp_get_thread_num() - IF (use_comm_thread .AND. (ithread .EQ. 0)) & - CALL progress_comms(carrier) - END IF - ! - DEALLOCATE (a_row_p) - DEALLOCATE (b_row_p) - DEALLOCATE (a_blk_info) - DEALLOCATE (b_blk_info) - ENDIF - END SUBROUTINE csr_multiply_unwrap + CALL get_free_stack_column(csr_carrier, stackcol_data, stackcol_fillcount, error) + + + a_row_cycle: DO a_row_l = mi, mf + m_size = m_sizes(a_row_l) + + a_row_eps = row_max_epss (a_row_l) + mapped_row_size = row_size_maps(m_size) + + a_blk_cycle: DO a_blk = a_row_p(a_row_l)+1, a_row_p(a_row_l+1) + a_col_l = a_blk_info(1, a_blk) + IF (debug_mod) WRITE(*,*)ithread,routineN//" A col", a_col_l,";",a_row_l + k_size = k_sizes (a_col_l) + mapped_k_size = k_size_maps(k_size) + + a_norm = left_norms(a_blk) + b_blk_cycle: DO b_blk = b_row_p(a_col_l)+1, b_row_p(a_col_l+1) + IF (dbg) THEN + WRITE(*,'(1X,A,3(1X,I7),1X,A,1X,I16)')routineN//" trying B",& + a_row_l, b_blk_info(1,b_blk), a_col_l, "at", b_blk_info(2,b_blk) + ENDIF + b_norm = right_norms(b_blk) + IF (a_norm * b_norm .LT. a_row_eps) THEN + CYCLE + ENDIF + b_col_l = b_blk_info(1,b_blk) + ! Don't calculate symmetric blocks. + symmetric_product: IF (c_has_symmetry) THEN + c_row_logical = c_local_rows (a_row_l) + c_col_logical = c_local_cols (b_col_l) + IF (c_row_logical .NE. c_col_logical& + .AND. my_checker_tr (c_row_logical, c_col_logical)) THEN + IF (dbg) THEN + WRITE(*,*)"Skipping symmetric block!", c_row_logical,& + c_col_logical + ENDIF + CYCLE + ENDIF + ENDIF symmetric_product + + c_blk_id = hash_table_get (c_hashes(a_row_l), b_col_l) + IF (.FALSE.) THEN + WRITE(*,'(1X,A,3(1X,I7),1X,A,1X,I16)')routineN//" coor",& + a_row_l, a_col_l, b_col_l,"c blk", c_blk_id + ENDIF + block_exists = c_blk_id .GT. 0 + + n_size = n_sizes(b_col_l) + c_nze = m_size * n_size + ! + IF (block_exists) THEN + offset = c_blk_p(c_blk_id) + ELSE + IF (keep_sparsity) CYCLE + + offset = datasize + 1 + lastblk = lastblk+1 + datasize = datasize + c_nze + c_blk_id = lastblk ! assign a new c-block-id + + IF (dbg) WRITE(*,*)routineN//" new block offset, nze", offset, c_nze + CALL hash_table_add(c_hashes(a_row_l),& + b_col_l, c_blk_id, error=error) + + ! We still keep the linear index because it's + ! easier than getting the values out of the + ! hashtable in the end. + c_row_i(lastblk) = a_row_l + c_col_i(lastblk) = b_col_l + c_blk_p(lastblk) = offset + ENDIF + + ! TODO: this is only called withcareful_mod + ! We should not call certain MM routines (netlib BLAS) + ! with zero LDs; however, we still need to get to here + ! to get new blocks. + IF (careful_mod) THEN + IF (c_nze .EQ. 0 .OR. k_size .EQ. 0) THEN + CALL dbcsr_assert (.FALSE.,& + dbcsr_fatal_level, dbcsr_internal_error, routineN,& + "Can not call MM with LDx=0.", __LINE__, error=error) + CYCLE + ENDIF + ENDIF + + mapped_col_size = col_size_maps (n_size) + ws = stack_map (mapped_col_size, mapped_k_size, mapped_row_size) + stackcol_fillcount(ws) = stackcol_fillcount(ws) + 1 + s_dp = stackcol_fillcount(ws) + + stackcol_data(p_m, s_dp, ws) = m_size + stackcol_data(p_n, s_dp, ws) = n_size + stackcol_data(p_k, s_dp, ws) = k_size + stackcol_data(p_a_first, s_dp, ws) = a_blk_info(2, a_blk) + stackcol_data(p_b_first, s_dp, ws) = b_blk_info(2, b_blk) + stackcol_data(p_c_first, s_dp, ws) = offset + stackcol_data(p_c_blk, s_dp, ws) = c_blk_id + + flop = flop + INT(2*c_nze, int_8) * INT(k_size, int_8) + + flush_stack = stackcol_fillcount(ws) >= SIZE(stackcol_data, 2) + IF (flush_stack) & + CALL get_free_stack_column(csr_carrier, stackcol_data, stackcol_fillcount, error) + + ENDDO b_blk_cycle ! b + ENDDO a_blk_cycle ! a_col + ENDDO a_row_cycle ! a_row + + + END SUBROUTINE dbcsr_mm_csr_multiply_low ! ***************************************************************************** -!> \brief Call in MPI to progrss any outstanding communications -!> TODO: copied from dbcsr_internal_operations. MPI does not belong on this level. -! ***************************************************************************** - SUBROUTINE progress_comms(carrier) - TYPE(carrier_type), INTENT(inout) :: carrier - - CALL mp_testany(carrier%right_data_sr) - CALL mp_testany(carrier%right_data_rr) - CALL mp_testany(carrier%left_data_sr) - CALL mp_testany(carrier%left_data_rr) - CALL mp_testany(carrier%right_index_sr) - CALL mp_testany(carrier%right_index_rr) - CALL mp_testany(carrier%left_index_sr) - CALL mp_testany(carrier%left_index_rr) - END SUBROUTINE - - -! ***************************************************************************** -!> \brief Moved out of dbcsr_multrec_init +!> \brief Initializes a multiplication cycle for new set of C-blocks. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE csr_multiply_outer_init(left, right, product, carrier, fill_guess, error) + SUBROUTINE dbcsr_mm_csr_outer_init(csr_carrier, left, right, product, fill_guess,& + m_sizes, n_sizes, k_sizes, error) + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier TYPE(dbcsr_type), INTENT(IN) :: left, right TYPE(dbcsr_type), INTENT(INOUT) :: product - TYPE(carrier_type), INTENT(INOUT) :: carrier REAL(KIND=real_8) :: fill_guess + INTEGER, DIMENSION(:), POINTER :: m_sizes, n_sizes, k_sizes TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'csr_multiply_outer_init', & + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_csr_outer_init', & routineP = moduleN//':'//routineN INTEGER :: block_estimate, default_stack, istack, ithread, k_map, k_size, & - m_map, m_size, mem_type, n_map, n_size, n_stack_buffers, & - n_stack_mem_regions, nstacks, nthreads, ps_buffer, ps_g, ps_memreg + m_map, m_size, n_map, n_size, n_stack_buffers, nstacks, nthreads, ps_g INTEGER, ALLOCATABLE, DIMENSION(:) :: flop_index, flop_list, & most_common_k, most_common_m, & most_common_n INTEGER, DIMENSION(3) :: nxstacks - LOGICAL :: local_cols, local_indexing, & - local_rows - TYPE(dbcsr_ps_group_type), POINTER :: ps_group - TYPE(dbcsr_ps_target_obj) :: product_target + LOGICAL :: local_indexing + TYPE(stack_descriptor_type), & + ALLOCATABLE, DIMENSION(:) :: tmp_descr ithread = 0 ; nthreads = 1 - !$ ithread = OMP_GET_THREAD_NUM () ; nthreads = OMP_GET_NUM_THREADS () - + !$ ithread = OMP_GET_THREAD_NUM () ; nthreads = OMP_GET_NUM_THREADS () + ! find out if we have local_indexing - local_cols = right%local_indexing - local_rows = left%local_indexing - CALL dbcsr_assert (local_cols, "EQV", local_rows,& + CALL dbcsr_assert (right%local_indexing, "EQV", left%local_indexing,& dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& "Local index useage must be consistent.", __LINE__, error=error) - local_indexing = local_rows - - + local_indexing = left%local_indexing + ! Setup the hash tables if needed - IF (local_indexing) THEN - ALLOCATE (carrier%c_hashes (product%nblkrows_local)) - ELSE - ALLOCATE (carrier%c_hashes (product%nblkrows_total)) - ENDIF block_estimate=MAX(product%nblks,left%nblks,right%nblks)/nthreads IF (local_indexing) THEN - CALL fill_hash_tables (carrier%c_hashes, product,block_estimate,& + ALLOCATE (csr_carrier%c_hashes (product%nblkrows_local)) + CALL fill_hash_tables (csr_carrier%c_hashes, product,block_estimate,& row_map=array_data(product%global_rows),& col_map=array_data(product%global_cols),& error=error) ELSE - CALL fill_hash_tables (carrier%c_hashes, product,block_estimate,& + ALLOCATE (csr_carrier%c_hashes (product%nblkrows_total)) + CALL fill_hash_tables (csr_carrier%c_hashes, product,block_estimate,& error=error) ENDIF - ! + ! Setup the MM stack - CALL dbcsr_get_conf_nstacks (nxstacks, n_stack_buffers, n_stack_mem_regions,& - error) - carrier%nm_stacks = nxstacks(1) - carrier%nn_stacks = nxstacks(2) - carrier%nk_stacks = nxstacks(3) + CALL dbcsr_get_conf_nstacks (nxstacks, n_stack_buffers, error) + csr_carrier%nm_stacks = nxstacks(1) + csr_carrier%nn_stacks = nxstacks(2) + csr_carrier%nk_stacks = nxstacks(3) nstacks = nxstacks(1) * nxstacks(2) * nxstacks(3) + 1 - CALL dbcsr_assert (nstacks, "LE", INT (HUGE (carrier%stack_map)),& + CALL dbcsr_assert (nstacks, "LE", INT (HUGE (csr_carrier%stack_map)),& dbcsr_fatal_level, dbcsr_internal_error, routineN,& "Too many stacks requested (global/dbcsr/n_size_*_stacks in input)",& __LINE__, error=error) - ! - CALL dbcsr_ps_target_new (product_target, error) - CALL dbcsr_ps_target_add_data (product_target%t,& - product%wms(ithread+1)%data_area, carrier%datasize, error=error) - - IF (mm_driver .EQ. mm_driver_cuda) THEN - mem_type = dbcsr_memory_CUDA_host_pinned - ELSE - mem_type = dbcsr_memory_default - ENDIF - - ! Here the first driver init part used to be - - CALL dbcsr_ps_set_create (carrier%param_sets, mm_stack_size,& - product_target, nstacks, n_stack_buffers, n_stack_mem_regions,& - mem_type,error=error) - - !moved this to the end as product_target is need for driver_init - !CALL dbcsr_ps_target_release (product_target, error) - - ! Setup the block sizes mappings. The carrier%*_sizes arrays are - ! mappings from block sizes to an index from the number of most - ! common block sizes. I.e., if nxstacks(1) = 2 and the most - ! common blocks sizes are 13 and 5, then the values in - ! carrier%m_sizes will be 3 for all elements except 13 and 5; - ! these two elemnts will be either 1 or 2. - ! + + + ALLOCATE(csr_carrier%stackrow_descr(nstacks)) + + DO istack=1, nstacks + csr_carrier%stackrow_descr(istack)%total_entries = 0 + END DO + ALLOCATE (most_common_m(nxstacks(1))) ALLOCATE (most_common_n(nxstacks(2))) ALLOCATE (most_common_k(nxstacks(3))) - CALL map_most_common (carrier%m_sizes, carrier%m_size_maps, nxstacks(1),& + CALL map_most_common (m_sizes, csr_carrier%m_size_maps, nxstacks(1),& most_common_m,& - max_stack_block_size, carrier%max_m) - carrier%m_size_maps_size = SIZE (carrier%m_size_maps) - CALL map_most_common (carrier%n_sizes, carrier%n_size_maps, nxstacks(2),& + max_stack_block_size, csr_carrier%max_m) + csr_carrier%m_size_maps_size = SIZE (csr_carrier%m_size_maps) + CALL map_most_common (n_sizes, csr_carrier%n_size_maps, nxstacks(2),& most_common_n,& - max_stack_block_size, carrier%max_n) - carrier%n_size_maps_size = SIZE (carrier%n_size_maps) + max_stack_block_size, csr_carrier%max_n) + csr_carrier%n_size_maps_size = SIZE (csr_carrier%n_size_maps) CALL map_most_common (array_data(right%row_blk_size),& - carrier%k_size_maps, nxstacks(3), & + csr_carrier%k_size_maps, nxstacks(3), & most_common_k,& - max_stack_block_size, carrier%max_k) - carrier%k_size_maps_size = SIZE (carrier%k_size_maps) - ! + max_stack_block_size, csr_carrier%max_k) + csr_carrier%k_size_maps_size = SIZE (csr_carrier%k_size_maps) + ! Creates the stack map--a mapping from (mapped) stack block sizes ! (carrier%*_sizes) to a stack number. Triples with even one ! uncommon size will be mapped to a general, non-size-specific ! stack. - ALLOCATE (carrier%stack_map(nxstacks(2)+1, nxstacks(3)+1, nxstacks(1)+1)) + ALLOCATE (csr_carrier%stack_map(nxstacks(2)+1, nxstacks(3)+1, nxstacks(1)+1)) default_stack = nstacks - carrier%default_stack = default_stack + DO m_map = 1, nxstacks(1)+1 IF (m_map .LE. nxstacks(1)) THEN m_size = most_common_m(m_map) @@ -374,48 +499,30 @@ MODULE dbcsr_mm_csr .AND. n_map .LE. nxstacks(2)) THEN ! This is the case when m, n, and k are all defined. ps_g = (m_map-1)*nxstacks(2)*nxstacks(3) +& - (k_map-1)*nxstacks(2) +& - n_map + (k_map-1)*nxstacks(2) + n_map ps_g = nstacks-ps_g - carrier%stack_map(n_map, k_map, m_map) = ps_g + csr_carrier%stack_map(n_map, k_map, m_map) = ps_g ! Also take care of the stack m, n, k descriptors - DO ps_memreg = 1, n_stack_mem_regions - DO ps_buffer = 1, n_stack_buffers - ps_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - ps_buffer, ps_memreg, error=error) - ps_group%stacks(ps_g)%s%m = m_size - ps_group%stacks(ps_g)%s%n = n_size - ps_group%stacks(ps_g)%s%k = k_size - ps_group%stacks(ps_g)%s%max_m = m_size - ps_group%stacks(ps_g)%s%max_n = n_size - ps_group%stacks(ps_g)%s%max_k = k_size - ps_group%stacks(ps_g)%s%defined_mnk = .TRUE. - ! The bins are quasi-sorted according from those - ! with largest sizes (best for accelerators) to - ! those with smallest (worst for accelerators). - ps_group%stacks(ps_g)%s%size_bin = ps_g - ENDDO - ENDDO + csr_carrier%stackrow_descr(ps_g)%m = m_size + csr_carrier%stackrow_descr(ps_g)%n = n_size + csr_carrier%stackrow_descr(ps_g)%k = k_size + csr_carrier%stackrow_descr(ps_g)%max_m = m_size + csr_carrier%stackrow_descr(ps_g)%max_n = n_size + csr_carrier%stackrow_descr(ps_g)%max_k = k_size + csr_carrier%stackrow_descr(ps_g)%defined_mnk = .TRUE. ELSE ! This is the case when at least one of m, n, or k is ! undefined. ps_g = default_stack - carrier%stack_map(n_map, k_map, m_map) = default_stack + csr_carrier%stack_map(n_map, k_map, m_map) = default_stack ! Also take care of the stack m, n, k descriptors - DO ps_memreg = 1, n_stack_mem_regions - DO ps_buffer = 1, n_stack_buffers - ps_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - ps_buffer, ps_memreg, error=error) - ps_group%stacks(ps_g)%s%m = 0 - ps_group%stacks(ps_g)%s%n = 0 - ps_group%stacks(ps_g)%s%k = 0 - ps_group%stacks(ps_g)%s%max_m = carrier%max_m - ps_group%stacks(ps_g)%s%max_n = carrier%max_n - ps_group%stacks(ps_g)%s%max_k = carrier%max_k - ps_group%stacks(ps_g)%s%defined_mnk = .FALSE. - ps_group%stacks(ps_g)%s%size_bin = default_stack - ENDDO - ENDDO + csr_carrier%stackrow_descr(ps_g)%m = 0 + csr_carrier%stackrow_descr(ps_g)%n = 0 + csr_carrier%stackrow_descr(ps_g)%k = 0 + csr_carrier%stackrow_descr(ps_g)%max_m = csr_carrier%max_m + csr_carrier%stackrow_descr(ps_g)%max_n = csr_carrier%max_n + csr_carrier%stackrow_descr(ps_g)%max_k = csr_carrier%max_k + csr_carrier%stackrow_descr(ps_g)%defined_mnk = .FALSE. END IF ENDDO ENDDO @@ -427,35 +534,58 @@ MODULE dbcsr_mm_csr ! sort to make the order fixed... all defined stacks first, default stack ! last. Next, sort according to flops, first stack lots of flops, last ! stack, few flops - IF (nstacks>1) THEN - ps_group => dbcsr_ps_set_get_group_p (carrier%param_sets, 1, 1, error=error) - ALLOCATE(flop_list(nstacks-1),flop_index(nstacks-1)) - DO istack=1,nstacks-1 - flop_list(istack)=-2*ps_group%stacks(istack)%s%m*ps_group%stacks(istack)%s%n*ps_group%stacks(istack)%s%k - ENDDO - CALL sort(flop_list,nstacks-1,flop_index) - DO ps_memreg = 1, n_stack_mem_regions - DO ps_buffer = 1, n_stack_buffers - ps_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - ps_buffer, ps_memreg, error=error) - DO istack=1,nstacks-1 - ps_group%stacks(istack)%s%size_bin = flop_index(istack) - ENDDO - ENDDO - ENDDO - DEALLOCATE(flop_list,flop_index) - ENDIF + ! The default stack shall remain at the end of the gridcolumn + ALLOCATE(flop_list(nstacks-1),flop_index(nstacks-1), tmp_descr(nstacks)) + DO istack=1,nstacks-1 + flop_list(istack) = -2 * csr_carrier%stackrow_descr(istack)%m& + * csr_carrier%stackrow_descr(istack)%n& + * csr_carrier%stackrow_descr(istack)%k + ENDDO + + CALL sort(flop_list, nstacks-1, flop_index) + tmp_descr = csr_carrier%stackrow_descr + DO istack=1,nstacks-1 + csr_carrier%stackrow_descr(istack) = tmp_descr(flop_index(istack)) + ENDDO + + DO m_map = 1, SIZE(csr_carrier%stack_map, 1) + DO k_map = 1, SIZE(csr_carrier%stack_map, 2) + map_loop: DO n_map = 1, SIZE(csr_carrier%stack_map, 1) + DO istack=1,nstacks-1 + IF(csr_carrier%stack_map(m_map, k_map, n_map) == flop_index(istack)) THEN + csr_carrier%stack_map(m_map, k_map, n_map) = istack + CYCLE map_loop + END IF + ENDDO + ENDDO map_loop + ENDDO + ENDDO + DEALLOCATE(flop_list,flop_index,tmp_descr) + + + + + ! Driver allocates stackgrid_data and stackgrid_state, if needed as host-pinned. + NULLIFY(csr_carrier%stackgrid_data, csr_carrier%stackgrid_state) + CALL dbcsr_mm_driver_outer_init(left=left, right=right, product=product,& + drv_carrier=csr_carrier%drv_carrier, fill_guess=fill_guess,& + stackgrid_data=csr_carrier%stackgrid_data, & + stackgrid_state=csr_carrier%stackgrid_state, & + nstacks=nstacks, n_stack_buffers=n_stack_buffers, error=error) + + IF(.NOT. ASSOCIATED(csr_carrier%stackgrid_data)) & + STOP "dbcsr_mm_csr_outer_init: stackgrid_data not associated" + + IF(.NOT. ASSOCIATED(csr_carrier%stackgrid_state)) & + STOP "dbcsr_mm_csr_outer_init: stackgrid_state not associated" + + ALLOCATE(csr_carrier%stackgrid_fillcount(nstacks, n_stack_buffers)) + csr_carrier%stackgrid_fillcount = 0 + csr_carrier%stackgrid_state = dbcsr_ps_state_empty + + + END SUBROUTINE dbcsr_mm_csr_outer_init - CALL dbcsr_mm_driver_outer_init(left, right, product, product_target, carrier, fill_guess, error=error) - - CALL dbcsr_ps_target_release (product_target, error) - - ALLOCATE (carrier%queue) - CALL dbcsr_pq_create (carrier%queue, nstacks, error) - CALL dbcsr_pq_share (carrier%queue, error) - ! - END SUBROUTINE csr_multiply_outer_init - ! ***************************************************************************** !> \brief Fills row hashtable from an existing matrix. @@ -509,435 +639,241 @@ MODULE dbcsr_mm_csr CALL dbcsr_error_stop(error_handler, error) END SUBROUTINE fill_hash_tables - + ! ***************************************************************************** -!> \brief Moved out of dbcsr_multrec_finalize +!> \brief Finalizes a multiplication cycle for a set of C-blocks. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE csr_multiply_outer_finalize(carrier, product, error) - TYPE(carrier_type), INTENT(INOUT) :: carrier + SUBROUTINE dbcsr_mm_csr_outer_finalize(csr_carrier, product, error) + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier TYPE(dbcsr_type), INTENT(inout) :: product TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'csr_multiply_outer_finalize', & + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_csr_outer_finalize', & routineP = moduleN//':'//routineN INTEGER :: i - CALL dbcsr_mm_driver_outer_finalize(carrier, product, error) - -! Clear hash tables - DO i = 1, SIZE(carrier%c_hashes) - CALL hash_table_release (carrier%c_hashes (i)) +! The driver deallocates stackgrid_data and stackgrid_state as it might be host-pinned. + + CALL dbcsr_mm_driver_outer_finalize(drv_carrier=csr_carrier%drv_carrier,& + product=product, stackgrid_data=csr_carrier%stackgrid_data,& + stackgrid_state=csr_carrier%stackgrid_state,& + error=error) + + IF(ASSOCIATED(csr_carrier%stackgrid_data)) & + STOP "dbcsr_mm_csr_outer_finalize: stackgrid_data still associated" + IF(ASSOCIATED(csr_carrier%stackgrid_state)) & + STOP "dbcsr_mm_csr_outer_finalize: stackgrid_state still associated" + + ! Clear hash tables + DO i = 1, SIZE(csr_carrier%c_hashes) + CALL hash_table_release (csr_carrier%c_hashes(i)) ENDDO - DEALLOCATE (carrier%c_hashes) - + DEALLOCATE (csr_carrier%c_hashes) - - ! Clear MM stack - !CALL dbcsr_psg_rm_data_c (& - ! dbcsr_ps_set_get_group(carrier%param_sets, 1, 1, error), error=error) + DEALLOCATE(csr_carrier%stackrow_descr) + DEALLOCATE(csr_carrier%stackgrid_fillcount) + DEALLOCATE(csr_carrier%stack_map) + DEALLOCATE(csr_carrier%m_size_maps) + DEALLOCATE(csr_carrier%n_size_maps) + DEALLOCATE(csr_carrier%k_size_maps) + + END SUBROUTINE dbcsr_mm_csr_outer_finalize - ! maybe a call to dbcsr_psg_rm_data_ab in a critical section would be enough - !$OMP CRITICAL (crit_data) - CALL dbcsr_ps_set_destroy (carrier%param_sets, error=error) - !$OMP END CRITICAL (crit_data) - - - CALL dbcsr_pq_unshare (carrier%queue, error) - CALL dbcsr_pq_destroy (carrier%queue, error) - DEALLOCATE (carrier%queue) - - END SUBROUTINE csr_multiply_outer_finalize ! ***************************************************************************** -!> \brief Moved out of dbcsr_multrec_sparse +!> \brief Initializes a multiplication cycle for a new set of A- and B-blocks. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE csr_multiply_inner_init(left, right, carrier, error) + SUBROUTINE dbcsr_mm_csr_inner_init(left, right, csr_carrier, error) TYPE(dbcsr_type), INTENT(IN) :: left, right - TYPE(carrier_type), INTENT(INOUT) :: carrier + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier TYPE(dbcsr_error_type), INTENT(INOUT) :: error - INTEGER :: ps_buffer, ps_memreg - TYPE(dbcsr_ps_group_type), POINTER :: stack_group + CALL dbcsr_mm_driver_inner_init(left, right, csr_carrier%drv_carrier, error) + END SUBROUTINE dbcsr_mm_csr_inner_init - !$OMP BARRIER - -! Setup the carrier data that changes in each multiplication step. - - DO ps_memreg = 1, carrier%param_sets%nmemregs - DO ps_buffer = 1, carrier%param_sets%nbuffers - stack_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - ps_buffer, ps_memreg, error=error) - !$OMP CRITICAL (crit_data) - CALL dbcsr_psg_add_data_ab (stack_group,& - left%data_area, right%data_area, error=error) - !$OMP END CRITICAL (crit_data) - ENDDO - ENDDO - ! - ! Quick reset of the queue to avoid heavyweight de/allocations. - CALL dbcsr_pq_refresh (carrier%queue,& - flush_level=(carrier%param_sets%nbuffers*carrier%param_sets%group_size),& - error=error) - - CALL dbcsr_mm_driver_inner_init(left, right, carrier, error) - !$OMP BARRIER - - END SUBROUTINE csr_multiply_inner_init - ! ***************************************************************************** -!> \brief Moved out of dbcsr_multrec_sparse +!> \brief Finalizes a multiplication cycle for a set of A- and B-blocks. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE csr_multiply_inner_finalize(carrier, error) - TYPE(carrier_type), INTENT(INOUT) :: carrier + SUBROUTINE dbcsr_mm_csr_inner_finalize(csr_carrier, error) + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier TYPE(dbcsr_error_type), INTENT(INOUT) :: error - INTEGER :: ps_buffer, ps_memreg - LOGICAL :: i_interface - TYPE(dbcsr_ps_group_type), POINTER :: stack_group +! submit all left over stacks -! Mark myself as done with indexing. + CALL process_stacks(csr_carrier, driver=mm_driver, min_fill=0, error=error) + CALL dbcsr_mm_driver_inner_finalize(csr_carrier%drv_carrier, error=error) + END SUBROUTINE dbcsr_mm_csr_inner_finalize - CALL dbcsr_pq_mark_done (carrier%queue, error) - i_interface = .FALSE. - IF (mm_thread_workshare) THEN - !$OMP MASTER - ! - ! I am the thread that interfaces to the accelerator. - i_interface = mm_async - !$OMP END MASTER - ELSE - i_interface = mm_async - ENDIF - ! - ! Queue all outstanding stacks. - DO ps_memreg = 1, carrier%param_sets%nmemregs - DO ps_buffer = 1, carrier%param_sets%nbuffers - stack_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - wait=.FALSE., error=error) - ! Only enqueue the stack group if it is not already queued - ! or being processed. - IF (dbcsr_psg_get_state (stack_group, error) & - .LT. dbcsr_ps_state_queued) THEN - CALL enqueue_ps_group (carrier%queue,& - stack_group, error) - ENDIF - ENDDO - ENDDO - ! - ! Process my queues now. - IF (.NOT. i_interface) THEN - ! Non-master threads just do CPU calculations. - CALL process_queue_mine(carrier%queue, driver=mm_host_driver,& - error=error) - ELSE - ! The master thread tries to fill up the accelerator. - CALL process_queue_mine (carrier%queue, driver=mm_driver,& - error=error) - - IF (mm_thread_workshare) THEN - CALL process_queue_others (carrier%queue, forever=.FALSE.,& - driver=mm_driver, error=error) - ENDIF - - CALL process_queue_mine (carrier%queue,& - driver=mm_host_driver, error=error) - - IF (mm_thread_workshare) THEN - CALL process_queue_others (carrier%queue, forever=.TRUE.,& - driver=mm_driver, error=error) - ENDIF - ENDIF - - IF (mm_thread_workshare) THEN - !$OMP BARRIER - ENDIF - - !TODO: why is this only called on one stack_group see also csr_multiply_init - ! - !$OMP CRITICAL (crit_data) - CALL dbcsr_psg_rm_data_ab (stack_group, error=error) - !$OMP END CRITICAL (crit_data) - - END SUBROUTINE csr_multiply_inner_finalize - ! ***************************************************************************** -!> \brief Performs multiplication of smaller submatrices. -!> \note The queue parameter could be INTENT(INOUT) when OpenMP is not used. +!> \brief Processes stacks in the stackgrid which have min_fill or more entries. +!> \param driver Which driver (smm, blas, cuda,...) should be used +!> \param min_fill Only process stacks that contain at least min_fill items. +!> \param max_stacks Process only given number of stacks. Not present = no limit. +!> \param start_below If set, the stackgrid will be search bottom-up. +!> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE csr_multiply(mi, mf, ni, nf, ki, kf,& - ai, af, a_row_p, a_blk_info, bi, bf, b_row_p, b_blk_info,& - c_hashes, c_row_i, c_col_i, c_blk_p, lastblk, datasize,& - m_sizes, n_sizes, k_sizes,& - c_local_rows, c_local_cols,& - c_has_symmetry, keep_sparsity, use_eps,& - param_sets, queue,& - params_array, advance_memreg, & - row_size_maps, col_size_maps, k_size_maps,& - row_size_maps_size, col_size_maps_size, k_size_maps_size,& - nm_stacks, nn_stacks, nk_stacks, stack_map,& - nstacks, default_stack,& - row_max_epss, left_norms, right_norms,& - flop, error) - INTEGER, INTENT(IN) :: mi, mf, ni, nf, ki, kf, ai, af - INTEGER, DIMENSION(mi:mf+1), INTENT(IN) :: a_row_p - INTEGER, DIMENSION(2, 1:af-ai+1), & - INTENT(IN) :: a_blk_info - INTEGER, INTENT(IN) :: bi, bf - INTEGER, DIMENSION(ki:kf+1), INTENT(IN) :: b_row_p - INTEGER, DIMENSION(2, 1:bf-bi+1), & - INTENT(IN) :: b_blk_info - TYPE(hash_table_type), DIMENSION(:), & - INTENT(INOUT) :: c_hashes - INTEGER, DIMENSION(*), INTENT(INOUT) :: c_row_i, c_col_i, c_blk_p - INTEGER, INTENT(INOUT) :: lastblk, datasize - INTEGER, DIMENSION(*), INTENT(IN) :: m_sizes, n_sizes, k_sizes, & - c_local_rows, c_local_cols - LOGICAL, INTENT(IN) :: c_has_symmetry, & - keep_sparsity, use_eps - TYPE(dbcsr_ps_set_type), INTENT(INOUT) :: param_sets - TYPE(dbcsr_pq_type), POINTER :: queue - INTEGER, DIMENSION(*), INTENT(INOUT) :: params_array - LOGICAL, INTENT(OUT) :: advance_memreg - INTEGER, INTENT(IN) :: row_size_maps_size, & - k_size_maps_size, & - col_size_maps_size - INTEGER(KIND=int_4), & - DIMENSION(0:row_size_maps_size-1), & - INTENT(IN) :: row_size_maps - INTEGER(KIND=int_4), & - DIMENSION(0:col_size_maps_size-1), & - INTENT(IN) :: col_size_maps - INTEGER(KIND=int_4), & - DIMENSION(0:k_size_maps_size-1), & - INTENT(IN) :: k_size_maps - INTEGER, INTENT(IN) :: nm_stacks, nn_stacks, & - nk_stacks - INTEGER(KIND=int_1), DIMENSION(& - nn_stacks+1, nk_stacks+1, nm_stacks+1)& - , INTENT(IN) :: stack_map - INTEGER, INTENT(IN) :: nstacks, default_stack - REAL(kind=sp), DIMENSION(*) :: row_max_epss, left_norms, & - right_norms - INTEGER(KIND=int_8), INTENT(INOUT) :: flop +SUBROUTINE process_stacks(csr_carrier, driver, min_fill, max_stacks, start_below, error) + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier + INTEGER, INTENT(IN) :: driver, min_fill + INTEGER, INTENT(IN), OPTIONAL :: max_stacks + LOGICAL, INTENT(IN), OPTIONAL :: start_below TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'csr_multiply', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: dbg = .FALSE., & - local_timing = .FALSE. + INTEGER :: i, j, n_stack_buffers, & + nstacks, num_processed + INTEGER, DIMENSION(:, :), POINTER :: stack_data + INTEGER, POINTER :: stack_fillcount, stack_state + TYPE(stack_descriptor_type), POINTER :: stack_descr - INTEGER :: a_blk, a_col_l, a_row_l, b_blk, b_col_l, c, c_blk_id, & - c_blk_pt, c_col_logical, c_nze, c_row_logical, ithread, k_size, m_size, & - mapped_col_size, mapped_k_size, mapped_row_size, n_size, new_blk, & - nworking, s_dp, ws, zero_first, zero_last - INTEGER, DIMENSION(nstacks) :: param_starts, stack_p - INTEGER, DIMENSION(:), POINTER :: params_array_direct - INTEGER(KIND=int_4) :: offset - LOGICAL :: block_exists, do_preempt, & - flush_stack, i_interface - REAL(kind=sp) :: a_norm, a_row_eps, b_norm - TYPE(dbcsr_ps_group_type), POINTER :: ps_group + INTEGER ::j_start, j_end, j_incr -! --------------------------------------------------------------------------- + num_processed = 0 + nstacks = SIZE(csr_carrier%stackgrid_data, 3) + n_stack_buffers = SIZE(csr_carrier%stackgrid_data, 4) - ithread = 0 - !$ ithread = omp_get_thread_num() - ! - advance_memreg = .FALSE. - i_interface = .FALSE. - IF (mm_thread_workshare) THEN - !$OMP MASTER - ! I am the thread that interfaces to the accelerator. - i_interface = mm_async - !$OMP END MASTER - ELSE - i_interface = mm_async + j_start=1; j_end=nstacks; j_incr=1 + IF(PRESENT(start_below)) THEN + IF(start_below) THEN + j_start=nstacks; j_end=1; j_incr=-1 + ENDIF ENDIF - ! - ! Each thread always shares the same zero_first, zero_last, and - ! new_blk. All of the parameter stacks should have the same - ! value. - ps_group => dbcsr_ps_set_get_group_p (param_sets, error=error) - CALL dbcsr_psg_view_open (ps_group, params_array_direct, stack_p,& - zero_first, zero_last, new_blk, param_starts, error=error) - ! - ! New data blocks will be put into the data area starting at - ! the c_blk_pt position. - new_blk = lastblk - c_blk_pt = datasize + 1 - ws = 1 - ! - a_row_cycle: DO a_row_l = mi, mf - m_size = m_sizes(a_row_l) - a_row_eps = row_max_epss (a_row_l) - mapped_row_size = row_size_maps(m_size) + DO i=1, n_stack_buffers + DO j=j_start, j_end, j_incr + IF(csr_carrier%stackgrid_fillcount(j,i) > min_fill) THEN + stack_data=>csr_carrier%stackgrid_data(:,:,j,i) + stack_fillcount=>csr_carrier%stackgrid_fillcount(j,i) + stack_state=>csr_carrier%stackgrid_state(j,i) + stack_descr=>csr_carrier%stackrow_descr(j) - a_blk_cycle: DO a_blk = a_row_p(a_row_l)+1, a_row_p(a_row_l+1) - a_col_l = a_blk_info(1, a_blk) - IF (debug_mod) WRITE(*,*)ithread,routineN//" A col", a_col_l,";",a_row_l - k_size = k_sizes (a_col_l) - mapped_k_size = k_size_maps(k_size) + CALL dbcsr_mm_driver_process_stack(& + drv_carrier=csr_carrier%drv_carrier,& + driver=driver,& + stack_data=stack_data,& + stack_fillcount=stack_fillcount,& + stack_state=stack_state,& + stack_descr=stack_descr,& + stack_id=j + (i-1)*nstacks,& + error=error) - a_norm = left_norms(a_blk) - b_blk_cycle: DO b_blk = b_row_p(a_col_l)+1, b_row_p(a_col_l+1) - IF (dbg) THEN - WRITE(*,'(1X,A,3(1X,I7),1X,A,1X,I16)')routineN//" trying B",& - a_row_l, b_blk_info(1,b_blk), a_col_l, "at", b_blk_info(2,b_blk) - ENDIF - b_norm = right_norms(b_blk) - IF (a_norm * b_norm .LT. a_row_eps) THEN - CYCLE - ENDIF - b_col_l = b_blk_info(1,b_blk) - ! Don't calculate symmetric blocks. - symmetric_product: IF (c_has_symmetry) THEN - c_row_logical = c_local_rows (a_row_l) - c_col_logical = c_local_cols (b_col_l) - IF (c_row_logical .NE. c_col_logical& - .AND. my_checker_tr (c_row_logical, c_col_logical)) THEN - IF (dbg) THEN - WRITE(*,*)"Skipping symmetric block!", c_row_logical,& - c_col_logical - ENDIF - CYCLE - ENDIF - ENDIF symmetric_product + num_processed = num_processed + 1 + IF(PRESENT(max_stacks)) THEN + IF(num_processed >= max_stacks) RETURN + END IF + END IF + END DO + END DO - c_blk_id = hash_table_get (c_hashes(a_row_l), b_col_l) - IF (.FALSE.) THEN - WRITE(*,'(1X,A,3(1X,I7),1X,A,1X,I16)')routineN//" coor",& - a_row_l, a_col_l, b_col_l,"c blk", c_blk_id - ENDIF - block_exists = c_blk_id .GT. 0 +END SUBROUTINE process_stacks - n_size = n_sizes(b_col_l) - c_nze = m_size * n_size - ! - new_block_case: IF (.NOT. block_exists) THEN - sparsity_enforcement: IF (keep_sparsity) THEN - CYCLE - ENDIF sparsity_enforcement - offset = c_blk_pt - new_blk = new_blk+1 - c_blk_id = new_blk - IF (dbg) WRITE(*,*)routineN//" new block offset, nze", offset, c_nze - CALL hash_table_add(c_hashes(a_row_l),& - b_col_l, c_blk_id, error=error) - ! - ! We still keep the linear index because it's - ! easier than getting the values out of the - ! hashtable in the end. - c_row_i(new_blk) = a_row_l - c_col_i(new_blk) = b_col_l - c_blk_p(new_blk) = offset - ! - c_blk_pt = c_blk_pt + c_nze - datasize = datasize + c_nze - zero_last = c_blk_pt - 1 - ELSE - offset = c_blk_p(c_blk_id) - ENDIF new_block_case - ! - ! We should not call certain MM routines (netlib BLAS) - ! with zero LDs; however, we still need to get to here - ! to get new blocks. - IF (careful_mod) THEN - IF (c_nze .EQ. 0 .OR. k_size .EQ. 0) THEN - CALL dbcsr_assert (.FALSE.,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "Can not call MM with LDx=0.", __LINE__, error=error) - CYCLE - ENDIF - ENDIF - ! - mapped_col_size = col_size_maps (n_size) - ws = stack_map (mapped_col_size, mapped_k_size, mapped_row_size) - s_dp = (param_starts(ws)-1 + stack_p(ws)) * dbcsr_ps_width - stack_p(ws) = stack_p(ws) + 1 - ! - params_array(s_dp+p_m) = m_size - params_array(s_dp+p_n) = n_size - params_array(s_dp+p_k) = k_size - ! - params_array(s_dp+p_a_first) = a_blk_info(2, a_blk) - ! - params_array(s_dp+p_b_first) = b_blk_info(2, b_blk) - ! - params_array(s_dp+p_c_first) = offset - params_array(s_dp+p_c_blk) = c_blk_id - ! - flop = flop + INT(2*c_nze, int_8) * INT(k_size, int_8) - ! - flush_stack = (stack_p(ws) .GE. mm_stack_size-1) - IF (flush_stack) THEN - advance_memreg = .TRUE. - CALL dbcsr_psg_view_close (ps_group, params_array_direct,& - stack_p, zero_first, zero_last, new_blk, error=error) - do_preempt = mm_async - IF (mm_async) THEN - nworking = dbcsr_ps_set_get_n_working (param_sets, error) - queue%nworking = nworking - IF (nworking .EQ. 0) THEN - !> If no stack in currently being processed then it - !> is assumed the accelerator can handle the stacks - !> on its own. The queue's flush_level is thus - !> increased, making it less favorable for the host - !> CPU to process stacks from the queue. - !> \see process_queue_preempt - !> \see get_stack_or_process_queue - CALL dbcsr_pq_flush_level_chg (queue,& - MAX(1,param_sets%nbuffers/1), param_sets) - CALL dbcsr_pq_handoff_level_chg (queue,& - MAX(1,param_sets%group_size/2), param_sets) - do_preempt = .FALSE. - ENDIF - ENDIF - CALL enqueue_ps_group (queue, ps_group, error=error) - ! - IF (i_interface) THEN - CALL process_queue_mine (queue, & - driver=mm_driver, error=error) - IF (mm_thread_workshare) THEN - CALL process_queue_others (queue, forever=.FALSE.,& - driver=mm_driver, error=error) - ENDIF - ENDIF - IF (do_preempt) THEN - ! Do some CPU stack calculations when needed. - CALL process_queue_preempt (queue, param_sets,& - driver=mm_host_driver, error=error) - ENDIF - ! - CALL dbcsr_ps_set_advance (param_sets,& - advance_memreg = .FALSE.,& - error=error) - ! - CALL get_stack_or_process_queue (param_sets,& - queue, ps_group, driver=mm_host_driver, error=error) - ! - CALL dbcsr_psg_view_open (ps_group, params_array_direct,& - stack_p, zero_first, zero_last, new_blk,& - param_starts, error=error) - ENDIF - ENDDO b_blk_cycle ! b - ENDDO a_blk_cycle ! a_col - ENDDO a_row_cycle ! a_row - ! - lastblk = new_blk - datasize = c_blk_pt -1 - ! - CALL dbcsr_psg_view_close (ps_group, params_array_direct,& - stack_p, zero_first, zero_last, new_blk, error=error) - - END SUBROUTINE csr_multiply +! ***************************************************************************** +!> \brief Returns a free column of the stackgrid. +!> If also processes some of the stacks in the stackgrid. +!> \author Ole Schuett +! ***************************************************************************** +SUBROUTINE get_free_stack_column(csr_carrier, stackcol_data, stackcol_fillcount, error) + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier + INTEGER, DIMENSION(:, :, :), POINTER :: stackcol_data + INTEGER, DIMENSION(:), POINTER :: stackcol_fillcount + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + INTEGER :: i, j, mm_stack_size, & + n_stack_buffers, nstacks + + n_stack_buffers = SIZE(csr_carrier%stackgrid_data, 4) + nstacks = SIZE(csr_carrier%stackgrid_data, 3) + mm_stack_size = SIZE(csr_carrier%stackgrid_data, 2) + + CALL process_stacks(csr_carrier, driver=mm_driver, min_fill=mm_stack_size/2, error=error) + + ! checking for unkown stack states + DO i=1, n_stack_buffers + DO j=1, nstacks + IF((csr_carrier%stackgrid_state(j,i) /= dbcsr_ps_state_empty) & + .AND. (csr_carrier%stackgrid_state(j,i) /= dbcsr_ps_state_working)) THEN + WRITE (*,*) "odd stack state: ", csr_carrier%stackgrid_state(j,i) + STOP + END IF + END DO + END DO + + ! looking for a free stackgrid column + outer_loop: DO WHILE(.TRUE.) + DO i=1, n_stack_buffers + IF(ALL(csr_carrier%stackgrid_state(:,i) == dbcsr_ps_state_empty)) THEN + stackcol_data => csr_carrier%stackgrid_data(:,:,:,i) + stackcol_fillcount => csr_carrier%stackgrid_fillcount(:,i) + EXIT outer_loop + END IF + END DO + + ! Waiting for free stackgrid column, doing some cpu work in the meanwhile. + CALL process_stacks(csr_carrier, driver=mm_host_driver, & + min_fill=0, max_stacks=1, start_below=.TRUE., error=error) + END DO outer_loop + + + END SUBROUTINE get_free_stack_column + + +! ***************************************************************************** +!> \brief Prints a nice tabular summary of the stackgrid's current state. +!> \author Ole Schuett +! ***************************************************************************** +SUBROUTINE print_stackgrid(csr_carrier) + TYPE(csr_carrier_type), INTENT(INOUT) :: csr_carrier + + INTEGER :: i, j, n_stack_buffers, nstacks + + n_stack_buffers = SIZE(csr_carrier%stackgrid_data, 4) + nstacks = SIZE(csr_carrier%stackgrid_data, 3) + + ! print table header + WRITE(*,"(14X,A)",advance='no') "| total " + DO i=1, n_stack_buffers + WRITE(*,"(A,I3,A)",advance='no') "|", i, ". grp " + END DO + WRITE(*,"(A)",advance='yes') "|" + + ! print separation line below table header + WRITE(*,"(A)",advance='no') "--------------+-----------+" + DO j=1, n_stack_buffers + WRITE(*,"(A)",advance='no') "---------+" + END DO + WRITE(*,"(A)",advance='yes') "" + + DO i=1, nstacks + IF(csr_carrier%stackrow_descr(i)%defined_mnk) THEN + WRITE(*,"(A,I2,A,I2,A,I2,A)",advance='no') "|", & + csr_carrier%stackrow_descr(i)%m, " x ", & + csr_carrier%stackrow_descr(i)%n, " x ", & + csr_carrier%stackrow_descr(i)%k, " " + ELSE + WRITE(*,"(A)",advance='no') "| mixed " + END IF + + WRITE(*,"(A,I9,X)",advance='no') "| ", csr_carrier%stackrow_descr(i)%total_entries + DO j=1, n_stack_buffers + IF(csr_carrier%stackgrid_state(i,j)==dbcsr_ps_state_empty) THEN + WRITE(*,"(A,I7,A)",advance='no') "| ",csr_carrier%stackgrid_fillcount(i,j)," " + ELSE + WRITE(*,"(A,I1,A)",advance='no') "| busy(",csr_carrier%stackgrid_state(i,j),") " + END IF + END DO + WRITE(*,"(A)",advance='yes') "|" + END DO + + + +END SUBROUTINE print_stackgrid + ! ***************************************************************************** @@ -1015,7 +951,7 @@ MODULE dbcsr_mm_csr csr_norms(:) = 0.0_sp ENDIF END SUBROUTINE build_csr_index - + ! ***************************************************************************** !> \brief Determines whether a transpose must be applied !> \par Source @@ -1030,7 +966,7 @@ MODULE dbcsr_mm_csr transpose = BTEST(column+row, 0) .EQV. column.GE.row END FUNCTION my_checker_tr - + ! ----------------------------------------------------------------------------- ! Beginning of hashtable diff --git a/src/dbcsr_lib/dbcsr_mm_driver.F b/src/dbcsr_lib/dbcsr_mm_driver.F index 253bcb528d..be8a7a718d 100644 --- a/src/dbcsr_lib/dbcsr_mm_driver.F +++ b/src/dbcsr_lib/dbcsr_mm_driver.F @@ -5,378 +5,604 @@ ! ***************************************************************************** !> \brief Fourth layer of the dbcsr matrix-matrix multiplication. -!> It hides the differences between performing calculations on the -!> GPU or the CPU. +!> It hides the differences between performing calculations on the +!> GPU or the CPU. !> !> \author Urban Borstnik -!> +!> !> Modification history: !> - 2010-02-23 Moved from dbcsr_operations !> - 2011-11 Moved parameter-stack processing routines to !> dbcsr_mm_methods. -!> - 2013-01 reorganized code (Ole Schuett) +!> - 2013-01 extensive refactoring (Ole Schuett) ! ***************************************************************************** MODULE dbcsr_mm_driver - - USE dbcsr_block_operations, ONLY: block_add - USE dbcsr_config, ONLY: mm_driver,& + USE dbcsr_block_operations, ONLY: block_add,& + dbcsr_data_clear + USE dbcsr_config, ONLY: dbcsr_get_conf_nstacks,& + mm_driver,& mm_driver_cuda,& - mm_stack_size,& - mm_thread_workshare + mm_stack_size USE dbcsr_cuda_device, ONLY: dbcsr_cuda_create_streams,& - dbcsr_cuda_destroy_streams + dbcsr_cuda_destroy_streams,& + dbcsr_cuda_device_sync,& + dbcsr_cuda_init USE dbcsr_cuda_memory, ONLY: dbcsr_cuda_dev_mem_alloc,& - dbcsr_cuda_dev_mem_hold,& + dbcsr_cuda_dev_mem_dealloc,& dbcsr_cuda_dev_mem_new,& + dbcsr_cuda_dev_mem_realloc,& dbcsr_cuda_dev_mem_release,& - dbcsr_cuda_dev_mem_zero + dbcsr_cuda_dev_mem_zero,& + dbcsr_cuda_host_mem_alloc,& + dbcsr_cuda_host_mem_dealloc USE dbcsr_cuda_methods, ONLY: dbcsr_cuda_dev_mem_get_alloc USE dbcsr_cuda_operations, ONLY: dbcsr_cuda_cp_dev_to_host,& dbcsr_cuda_cp_host_to_dev - USE dbcsr_cuda_types, ONLY: dbcsr_cuda_mem_type + USE dbcsr_cuda_types, ONLY: dbcsr_cuda_mem_p_type,& + dbcsr_cuda_mem_type USE dbcsr_data_methods, ONLY: dbcsr_data_ensure_size,& dbcsr_data_get_size,& dbcsr_data_get_type,& dbcsr_data_init,& dbcsr_data_new,& - dbcsr_data_release + dbcsr_data_release,& + dbcsr_data_set_size_referenced USE dbcsr_error_handling - USE dbcsr_kinds, ONLY: int_4,& + USE dbcsr_kinds, ONLY: dp,& int_8,& real_8 - USE dbcsr_mm_types, ONLY: carrier_type - USE dbcsr_pq_methods, ONLY: dbcsr_ps_set_get_group_p,& - dbcsr_ps_target_add_data_cuda,& - dbcsr_psg_add_data_cuda_ab,& - dbcsr_psg_rm_data_cuda_ab - USE dbcsr_pq_types, ONLY: dbcsr_ps_group_type,& - dbcsr_ps_state_empty,& - dbcsr_ps_target_obj,& - dbcsr_ps_target_type,& - dbcsr_ps_width + USE dbcsr_mm_stack, ONLY: process_mm_stack_cpu,& + process_mm_stack_cuda + USE dbcsr_mm_types, ONLY: dbcsr_ps_state_empty,& + dbcsr_ps_state_working,& + dbcsr_ps_width,& + driver_carrier_type,& + stack_descriptor_type USE dbcsr_types, ONLY: dbcsr_data_obj,& dbcsr_type,& dbcsr_type_int_4 !$ USE OMP_LIB - + IMPLICIT NONE - + PRIVATE - + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_mm_driver' - - PUBLIC :: dbcsr_mm_driver_outer_init, dbcsr_mm_driver_outer_finalize - PUBLIC :: dbcsr_mm_driver_inner_init - + + PUBLIC :: dbcsr_mm_driver_lib_init, dbcsr_mm_driver_lib_finalize + PUBLIC :: dbcsr_mm_driver_outer_init, dbcsr_mm_driver_outer_finalize + PUBLIC :: dbcsr_mm_driver_inner_init, dbcsr_mm_driver_inner_finalize + PUBLIC :: dbcsr_mm_driver_process_stack + + ! ===== Global Cuda Memory ===== + ! Allocating memory for cuda (on the card and host-pinned) is slow. + ! Therefore, the memory is allocated once and stored in global variables. + ! Variable cuda_mem_in_use should prevent concurred use of this global memory. + LOGICAL cuda_mem_in_use + !$OMP THREADPRIVATE(cuda_mem_in_use) + TYPE(dbcsr_cuda_mem_type), POINTER :: cuda_dev_c_data, cuda_dev_c_locks + !$OMP THREADPRIVATE(cuda_dev_c_data, cuda_dev_c_locks) + TYPE(dbcsr_cuda_mem_p_type), DIMENSION(:), POINTER :: cuda_dev_stacklist_data + !$OMP THREADPRIVATE(cuda_dev_stacklist_data) + INTEGER, DIMENSION(:,:,:,:), POINTER :: cuda_host_stackgrid_data + !$OMP THREADPRIVATE(cuda_host_stackgrid_data) + INTEGER, DIMENSION(:,:), POINTER :: cuda_host_stackgrid_state + !$OMP THREADPRIVATE(cuda_host_stackgrid_state) + + !These are shared between threads + TYPE(dbcsr_cuda_mem_type), POINTER, SAVE :: cuda_dev_a_data => Null() + TYPE(dbcsr_cuda_mem_type), POINTER, SAVE :: cuda_dev_b_data => Null() + TYPE(dbcsr_cuda_mem_type), POINTER, SAVE :: cuda_dev_state_empty => Null() + + + !INTEGER , SAVE :: num_cpu_stacks = 0 + !INTEGER , SAVE :: num_gpu_stacks = 0 + !INTEGER(kind=int_8), SAVE :: gpu_flop = 0 + !INTEGER(kind=int_8), SAVE :: cpu_flop = 0 + CONTAINS - - - + + ! ***************************************************************************** -!> \brief Moved out of internal_operations -!> This loads the data for matrizes A and B onto the card. -!> \author Ole Schuett +! \brief Initialize the library +! \author Ole Schuett ! ***************************************************************************** - SUBROUTINE dbcsr_mm_driver_inner_init(left, right, carrier, error) - TYPE(dbcsr_type), INTENT(IN) :: left, right - TYPE(carrier_type), INTENT(INOUT) :: carrier + SUBROUTINE dbcsr_mm_driver_lib_init(error) TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_driver_inner_init', & - routineP = moduleN//':'//routineN + INTEGER :: i, ithread, n_stack_buffers, & + nstacks, nthreads + INTEGER, DIMENSION(1), TARGET :: tmp_arr + INTEGER, DIMENSION(3) :: nxstacks + INTEGER, DIMENSION(:), POINTER :: tmp_ptr - IF (mm_driver .EQ. mm_driver_cuda) THEN - !$OMP MASTER - CALL dbcsr_cuda_cp_host_to_dev(& - left%data_area,& - carrier%param_sets%groups(1,1)%master%s%left_data_cuda,& - async = .TRUE.,& - error=error) - CALL dbcsr_cuda_cp_host_to_dev(& - right%data_area,& - carrier%param_sets%groups(1,1)%master%s%right_data_cuda,& - async = .TRUE.,& - error=error) - !$OMP END MASTER + nthreads = 1; ithread = 0 + !$ nthreads = OMP_GET_NUM_THREADS () ; ithread = OMP_GET_THREAD_NUM () + + IF (mm_driver == mm_driver_cuda) THEN + CALL dbcsr_get_conf_nstacks(nxstacks, n_stack_buffers, error) + nstacks = nxstacks(1) * nxstacks(2) * nxstacks(3) + 1 + + !Ensure that lock_offset in dbcsr_cuda_calc.cu won't overflow (it's a int4). + ! TODO: Check this code, before you start to used locking again. + IF(4*mm_stack_size > 2**17)& ! The "4" due to stack_mm_mnk_sq5_d + STOP "dbcsr_mm_driver_lib_init: mm_stack_size is too large" + IF(nthreads*nstacks*n_stack_buffers > 2**15)& + STOP "dbcsr_mm_driver_lib_init: nthreads*nstacks*n_stack_buffers is too large" + + !TODO: do we want to support multiple cards? Search: ma_set_gpu_affinity + CALL dbcsr_cuda_init(error=error) + + ! 1. Things that are shared between threads. + !----------------------------------------------------------------------- + !$OMP BARRIER + !$OMP MASTER + CALL dbcsr_cuda_create_streams(nthreads*nstacks*n_stack_buffers, error) + + ! Constant dbcsr_ps_state_empty needed on card to signal completed transfers. + tmp_arr = dbcsr_ps_state_empty + tmp_ptr => tmp_arr + CALL dbcsr_cuda_dev_mem_new(cuda_dev_state_empty, dbcsr_type_int_4, error=error) + CALL dbcsr_cuda_dev_mem_alloc(cuda_dev_state_empty, 1, error=error) + CALL dbcsr_cuda_cp_host_to_dev(host_mem=tmp_ptr, dev_mem=cuda_dev_state_empty%d_i, n=1,& + async=.FALSE.,error=error) + !$OMP END MASTER + !$OMP BARRIER + + ! 2. Things that are local to each thread + !------------------------------------------------------------------------ + ! Allocate the parameter stack on the card + ALLOCATE(cuda_dev_stacklist_data(nstacks*n_stack_buffers)) + DO i=1, nstacks*n_stack_buffers + NULLIFY(cuda_dev_stacklist_data(i)%p) + CALL dbcsr_cuda_dev_mem_new(cuda_dev_stacklist_data(i)%p, dbcsr_type_int_4, error) + CALL dbcsr_cuda_dev_mem_alloc(cuda_dev_stacklist_data(i)%p,& + dbcsr_ps_width*mm_stack_size, error=error) + END DO + + ! Allocate the parameter stack on the host with pinned memory + CALL dbcsr_cuda_host_mem_alloc(cuda_host_stackgrid_data, & + dbcsr_ps_width, mm_stack_size, nstacks, n_stack_buffers, error=error) + CALL dbcsr_cuda_host_mem_alloc(cuda_host_stackgrid_state, & + nstacks, n_stack_buffers, error=error) + + ! Size of the C-Blocks unkown at this point, allocation is done late. + NULLIFY(cuda_dev_c_data, cuda_dev_c_locks) + + !Setup safety guard against overlapping multiplications. + cuda_mem_in_use = .FALSE. ENDIF - - END SUBROUTINE dbcsr_mm_driver_inner_init - + + END SUBROUTINE dbcsr_mm_driver_lib_init + + ! ***************************************************************************** -!> \brief Moved out of dbcsr_multrec_init (actually csr_multiply_outer_init) -!> This allocates the memory for the matrizes A and B on the card and -!> and leaves pointers to them in every stack. +! \brief Finalize the library +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_driver_lib_finalize(error) + USE ISO_C_BINDING + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + INTEGER :: i + + IF (mm_driver == mm_driver_cuda) THEN + ! Releasing host pinned memory of stackgrid on the host + CALL dbcsr_cuda_host_mem_dealloc(cuda_host_stackgrid_data, error) + CALL dbcsr_cuda_host_mem_dealloc(cuda_host_stackgrid_state, error) + + ! releasing stuff on the card if necessary + IF(ASSOCIATED(cuda_dev_c_data))& + CALL dbcsr_cuda_dev_mem_release(cuda_dev_c_data, error=error) + IF(ASSOCIATED(cuda_dev_c_locks))& + CALL dbcsr_cuda_dev_mem_release(cuda_dev_c_locks, error=error) + + DO i=1, SIZE(cuda_dev_stacklist_data) + CALL dbcsr_cuda_dev_mem_release(cuda_dev_stacklist_data(i)%p, error=error) + END DO + DEALLOCATE(cuda_dev_stacklist_data) + + !$OMP BARRIER + !$OMP MASTER + IF(ASSOCIATED(cuda_dev_a_data))& + CALL dbcsr_cuda_dev_mem_release(cuda_dev_a_data, error=error) + IF(ASSOCIATED(cuda_dev_b_data))& + CALL dbcsr_cuda_dev_mem_release(cuda_dev_b_data, error=error) + CALL dbcsr_cuda_dev_mem_release(cuda_dev_state_empty, error=error) + CALL dbcsr_cuda_destroy_streams(error=error) + + !How much memory is still allocated on the card? + !istat = dbcsr_cuda_dev_mem_info(mem_free, mem_avail) + !WRITE (*,*) "after outer_finalize cuda mem: ",mem_free, mem_avail, istat + !$OMP END MASTER + !$OMP BARRIER + + END IF + + + ! !$OMP MASTER + ! WRITE (*,*) "num_stacks gpu:", num_gpu_stacks, " cpu: ",num_cpu_stacks, " ratio: ",REAL(num_gpu_stacks)/REAL(num_cpu_stacks) + ! WRITE (*,*) "flop gpu:", gpu_flop, " cpu: ",cpu_flop, " ratio: ",REAL(gpu_flop)/REAL(cpu_flop) + ! !$OMP END MASTER + END SUBROUTINE dbcsr_mm_driver_lib_finalize + + + + +! ***************************************************************************** +!> \brief Initializes a multiplication cycle for new set of C-blocks. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE dbcsr_mm_driver_outer_init(left, right, product, product_target, carrier, fill_guess, error) + SUBROUTINE dbcsr_mm_driver_outer_init(left, right, product, drv_carrier,& + fill_guess, nstacks, n_stack_buffers, stackgrid_data, stackgrid_state, error) TYPE(dbcsr_type), INTENT(IN) :: left, right TYPE(dbcsr_type), INTENT(INOUT) :: product - TYPE(dbcsr_ps_target_obj), INTENT(INOUT) :: product_target - TYPE(carrier_type), INTENT(INOUT) :: carrier + TYPE(driver_carrier_type), INTENT(INOUT) :: drv_carrier REAL(KIND=real_8) :: fill_guess + INTEGER, INTENT(IN) :: nstacks, n_stack_buffers + INTEGER, DIMENSION(:, :, :, :), POINTER :: stackgrid_data + INTEGER, DIMENSION(:, :), POINTER :: stackgrid_state TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_driver_outer_init', & - routineP = moduleN//':'//routineN + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_driver_outer_init' - INTEGER :: data_type, nthreads, & - ps_buffer, ps_memreg - TYPE(dbcsr_cuda_mem_type), POINTER, SAVE :: a_dev, b_dev - TYPE(dbcsr_ps_group_type), POINTER :: ps_group + INTEGER :: a_data_size, allocated_datasize, b_data_size, c_data_size, & + c_locks_size, data_type, error_handler, ithread, nthreads, used_datasize - nthreads = 1 - !$ nthreads = OMP_GET_NUM_THREADS () - - - ! first driver init part --------------------------------------------------- + CALL dbcsr_error_set(routineN, error_handler, error) - IF (mm_driver .EQ. mm_driver_cuda) THEN - !$OMP MASTER - ! - ! Setup threads<->streams - CALL dbcsr_cuda_create_streams (nthreads, error) - ! - data_type = dbcsr_data_get_type (left%data_area) - CALL dbcsr_cuda_dev_mem_new (a_dev, data_type, error=error) - CALL dbcsr_cuda_dev_mem_new (b_dev, data_type, error=error) - CALL dbcsr_cuda_dev_mem_alloc (a_dev,& - dbcsr_data_get_size (left%data_area), error=error) - CALL dbcsr_cuda_dev_mem_alloc (b_dev,& - dbcsr_data_get_size (right%data_area), error=error) - !$OMP END MASTER - CALL init_card_c (product, product_target%t,fill_guess, error) - !$OMP BARRIER - IF (.FALSE.) THEN - ! Left in for mental accounting - !$OMP CRITICAL - CALL dbcsr_cuda_dev_mem_hold (a_dev, error=error) - CALL dbcsr_cuda_dev_mem_hold (b_dev, error=error) - !$OMP END CRITICAL - ENDIF + nthreads = 1; ithread = 0 + !$ nthreads = OMP_GET_NUM_THREADS () ; ithread = OMP_GET_THREAD_NUM () + + data_type = dbcsr_data_get_type(left%data_area) + + drv_carrier%product_wm => product%wms(ithread+1) !TODO: why do we need this ref? + used_datasize = drv_carrier%product_wm%datasize + allocated_datasize = dbcsr_data_get_size(drv_carrier%product_wm%data_area) + + ! The product's data_area could already contain some data. + ! ( see: keep_product_data in dbcsr_operations.F ) + ! But this data might not occupy all the allocated memory in the data_area. + ! Since, we don't want to keep track of unitialized memory we just zero it now. + CALL dbcsr_data_clear(drv_carrier%product_wm%data_area, lb=used_datasize+1, ub=allocated_datasize) + + IF (mm_driver /= mm_driver_cuda) THEN + ALLOCATE(stackgrid_data(dbcsr_ps_width, mm_stack_size, nstacks, n_stack_buffers)) + ALLOCATE(stackgrid_state(nstacks, n_stack_buffers)) ELSE - !$OMP MASTER - NULLIFY (a_dev, b_dev) - !$OMP END MASTER - !$OMP BARRIER - ENDIF - ! end of first part of driver init ----------------------------------------- - - ! second part of driver init ----------------------------------------------- - IF (mm_driver .EQ. mm_driver_cuda) THEN - DO ps_memreg = 1, carrier%param_sets%nmemregs - DO ps_buffer = 1, carrier%param_sets%nbuffers - ps_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - ps_buffer, ps_memreg, error=error) - !$OMP CRITICAL (crit_data_card) - CALL dbcsr_psg_add_data_cuda_ab (ps_group,& - a_dev, b_dev, error=error) - !$OMP END CRITICAL (crit_data_card) - ENDDO - ENDDO - IF (.FALSE.) THEN - ! Left in for mental accounting - !$OMP CRITICAL - CALL dbcsr_cuda_dev_mem_release (a_dev, error=error) - CALL dbcsr_cuda_dev_mem_release (b_dev, error=error) - !$OMP END CRITICAL - ENDIF + ! 0. Making shure there is only one multiplication going on at a time. + !------------------------------------------------------------------------ + IF(.NOT. ASSOCIATED(cuda_dev_state_empty)) & + STOP "dbcsr_mm_driver_outer_init: dbcsr not initialized" + IF(cuda_mem_in_use) STOP "dbcsr_mm_driver: found overlapping multiplications" + cuda_mem_in_use = .TRUE. + + ! 1. Things that are shared between threads. + !------------------------------------------------------------------------ !$OMP BARRIER !$OMP MASTER - CALL dbcsr_cuda_dev_mem_release (a_dev, error=error) - CALL dbcsr_cuda_dev_mem_release (b_dev, error=error) + ! (re)Allocate Memory for A and B blocks on the Card + a_data_size = dbcsr_data_get_size(left%data_area) + b_data_size = dbcsr_data_get_size(right%data_area) + CALL cuda_prepare_mem(cuda_dev_a_data, data_type, a_data_size, error=error) + CALL cuda_prepare_mem(cuda_dev_b_data, data_type, b_data_size, error=error) !$OMP END MASTER + !$OMP BARRIER + + + ! 2. Things that are local to each thread + !------------------------------------------------------------------------ + IF(SIZE(cuda_host_stackgrid_data, 1) /= dbcsr_ps_width .OR. & + SIZE(cuda_host_stackgrid_data, 2) /= mm_stack_size .OR. & + SIZE(cuda_host_stackgrid_data, 3) /= nstacks .OR. & + SIZE(cuda_host_stackgrid_data, 4) /= n_stack_buffers ) & + STOP "dbcsr_mm_driver_outer_init: cuda_host_stackgrid_data wrong dims" + + IF(SIZE(cuda_host_stackgrid_state, 1) /= nstacks .OR. & + SIZE(cuda_host_stackgrid_state, 2) /= n_stack_buffers ) & + STOP "dbcsr_mm_driver_outer_init: cuda_host_stackgrid_state wrong dims" + + stackgrid_data => cuda_host_stackgrid_data + stackgrid_state => cuda_host_stackgrid_state + + ! (re)Allocate Memory for C blocks on the Card and zero it. + c_data_size = dbcsr_data_get_size(product%wms(ithread+1)%data_area) + CALL cuda_prepare_mem(cuda_dev_c_data, data_type, c_data_size, zero=.TRUE., error=error) + + ! (re)Allocate and zero C locks on GPU. + c_locks_size = INT(product%nblkcols_local,KIND=int_8)* & + INT(product%nblkrows_local,KIND=int_8) * fill_guess + 1 + CALL cuda_prepare_mem(cuda_dev_c_locks, dbcsr_type_int_4, c_locks_size, zero=.TRUE., error=error) + ENDIF - + + CALL dbcsr_error_stop(error_handler, error) END SUBROUTINE dbcsr_mm_driver_outer_init - + ! ***************************************************************************** -!> \brief Moved out of dbcsr_multrec_finalize (actually csr_multiply_outer_finalize) -!> Copies the result matrix C back from the card, -!> deallocates the memory on the card, and destroys the streams. +! \brief Helper routine used by dbcsr_mm_driver_outer_init(). +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE cuda_prepare_mem(dev_mem, data_type, data_size, zero, error) + TYPE(dbcsr_cuda_mem_type), POINTER :: dev_mem + INTEGER, INTENT(IN) :: data_type, data_size + LOGICAL, INTENT(IN), OPTIONAL :: zero + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + IF (.NOT. ASSOCIATED(dev_mem)) THEN + !WRITE (*,*) "cuda_prepare_mem: allocting for the first time" + CALL dbcsr_cuda_dev_mem_new(dev_mem, data_type, error=error) + CALL dbcsr_cuda_dev_mem_alloc(dev_mem, data_size, error=error) + END IF + + IF (dev_mem%data_type /= data_type) THEN + !WRITE (*,*) "cuda_prepare_mem: changing datatype" + CALL dbcsr_cuda_dev_mem_release(dev_mem, error=error) + CALL dbcsr_cuda_dev_mem_new(dev_mem, data_type, error=error) + CALL dbcsr_cuda_dev_mem_alloc(dev_mem, data_size, error=error) + END IF + + IF (dbcsr_cuda_dev_mem_get_alloc(dev_mem) < data_size) THEN + !WRITE (*,*) "cuda_prepare_mem: growing dev_mem" + CALL dbcsr_cuda_dev_mem_dealloc(dev_mem, error=error) + CALL dbcsr_cuda_dev_mem_alloc(dev_mem, data_size, error=error) + END IF + + IF(PRESENT(zero)) THEN + IF(zero) CALL dbcsr_cuda_dev_mem_zero(dev_mem, first=1, & + last=dbcsr_cuda_dev_mem_get_alloc(dev_mem), error=error) + END IF + END SUBROUTINE + + +! ***************************************************************************** +!> \brief Initializes a multiplication cycle for a new set of A- and B-blocks. !> \author Ole Schuett ! ***************************************************************************** - SUBROUTINE dbcsr_mm_driver_outer_finalize(carrier, product, error) - TYPE(carrier_type), INTENT(INOUT) :: carrier - TYPE(dbcsr_type), INTENT(inout) :: product + SUBROUTINE dbcsr_mm_driver_inner_init(left, right, drv_carrier, error) + TYPE(dbcsr_type), INTENT(IN) :: left, right + TYPE(driver_carrier_type), INTENT(INOUT) :: drv_carrier TYPE(dbcsr_error_type), INTENT(INOUT) :: error - INTEGER :: data_size, data_type, & - ithread, ps_buffer, ps_memreg - TYPE(dbcsr_data_obj) :: tmp_data - TYPE(dbcsr_ps_group_type), POINTER :: ps_group + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_driver_inner_init' - IF (mm_driver .EQ. mm_driver_cuda) THEN - ! this part is from dbcsr_internal_operations --------------------------- - - ithread = 0 - !$ ithread = omp_get_thread_num() - - ! Transfer data from GPU to host. - CALL dbcsr_data_init (tmp_data) - CALL dbcsr_data_new (tmp_data,& - data_type = dbcsr_data_get_type(product%wms(ithread+1)%data_area),& - data_size = carrier%datasize) - CALL dbcsr_cuda_cp_dev_to_host(& - carrier%param_sets%groups(1,1)%master%s%t%t%product_data_cuda,& - !product%wms(1)%data_area,& - tmp_data,& - error=error) - CALL dbcsr_data_ensure_size(product%wms(ithread+1)%data_area,& - carrier%datasize, error=error) - CALL block_add (product%wms(ithread+1)%data_area, tmp_data,& - len=carrier%datasize, error=error) - CALL dbcsr_data_release (tmp_data) - ! end of part from dbcsr_internal_operations ---------------------------- - - ! this part is from dbcsr_multrec_finalize ------------------------------ - DO ps_memreg = 1, carrier%param_sets%nmemregs - DO ps_buffer = 1, carrier%param_sets%nbuffers - ps_group => dbcsr_ps_set_get_group_p (carrier%param_sets,& - ps_buffer, ps_memreg, error=error) - !$OMP CRITICAL (crit_data_card) - CALL dbcsr_psg_rm_data_cuda_ab (ps_group, error=error) - !$OMP END CRITICAL (crit_data_card) - ENDDO - ENDDO - ENDIF + INTEGER :: error_handler - !$OMP BARRIER - - !$OMP MASTER - IF (mm_driver .EQ. mm_driver_cuda) THEN - CALL dbcsr_cuda_destroy_streams (error=error) - ENDIF - !$OMP END MASTER - - END SUBROUTINE dbcsr_mm_driver_outer_finalize - - - -! ***************************************************************************** -!> \brief Perform allocations and setup needed for multiplication on an -!> accelerator card. -! ***************************************************************************** - SUBROUTINE init_card_c (host_matrix, product_target, fill_guess, error) - TYPE(dbcsr_type), INTENT(IN) :: host_matrix - TYPE(dbcsr_ps_target_type), & - INTENT(INOUT) :: product_target - REAL(KIND=real_8) :: fill_guess - TYPE(dbcsr_error_type), INTENT(INOUT) :: error + CALL dbcsr_error_set(routineN, error_handler, error) - CHARACTER(len=*), PARAMETER :: routineN = 'init_card_c', & - routineP = moduleN//':'//routineN + drv_carrier%left_data_area = left%data_area + drv_carrier%right_data_area = right%data_area - INTEGER :: clocks_size, data_size, & - data_type, error_handle, & - ithread - INTEGER, POINTER :: state_tmp - INTEGER, TARGET :: state_tmp_tgt - LOGICAL :: do_master_work - TYPE(dbcsr_cuda_mem_type), POINTER :: c_dev, c_locks_dev, & - params_dev_l - TYPE(dbcsr_cuda_mem_type), POINTER, SAVE :: params_dev, stack_state_dev - -! --------------------------------------------------------------------------- - - CALL dbcsr_error_set(routineN, error_handle, error) - - ! Only the master thread does common work in when threads share work. - do_master_work = .NOT. mm_thread_workshare - do_master_work = .TRUE. - !$OMP MASTER - do_master_work = .TRUE. - !$OMP END MASTER - - ithread = 0 - !$ ithread = OMP_GET_THREAD_NUM () - data_type = dbcsr_data_get_type (host_matrix%wms(ithread+1)%data_area) - data_size = dbcsr_data_get_size (host_matrix%wms(ithread+1)%data_area) - ! - ! Allocate space for product data on the card. - CALL dbcsr_cuda_dev_mem_new (c_dev, data_type, error) - CALL dbcsr_cuda_dev_mem_alloc (c_dev, data_size, error=error) - ! - ! To finish allocations before the zeroing is launched. - ! - !$OMP BARRIER - ! - ! Zero C data on card. This assumes that data will be - ! summed with the host data after the multiplication is done. - CALL dbcsr_cuda_dev_mem_zero(c_dev, first=1,& - last=data_size, error=error) - ! - ! Attach C data on card to the product target descriptor - CALL dbcsr_ps_target_add_data_cuda (product_target, c_dev, error) - CALL dbcsr_cuda_dev_mem_release (c_dev, error=error) - ! - ! Allocate C locks on GPU. Locks should be cleared as soon as - ! allocated. - CALL dbcsr_cuda_dev_mem_new (c_locks_dev,& - dbcsr_type_int_4, error) - clocks_size = INT(host_matrix%nblkcols_local,KIND=int_8)* & - INT(host_matrix%nblkrows_local,KIND=int_8)* & - fill_guess - clocks_size = MAX(1,INT(clocks_size, KIND=int_4)) - CALL dbcsr_cuda_dev_mem_alloc (c_locks_dev,INT(clocks_size,KIND=int_4), error=error) - CALL dbcsr_cuda_dev_mem_zero (c_locks_dev,& - first=1,last=dbcsr_cuda_dev_mem_get_alloc(c_locks_dev),& - error=error) - product_target%c_locks_dev => c_locks_dev - ! - ! Have a source from which to update states and setup the on-card - ! parameter stacks. - ! - !$OMP MASTER - CALL dbcsr_cuda_dev_mem_new (stack_state_dev, dbcsr_type_int_4,& - error=error) - CALL dbcsr_cuda_dev_mem_alloc (stack_state_dev, 1, error=error) - state_tmp_tgt = dbcsr_ps_state_empty - state_tmp => state_tmp_tgt - CALL dbcsr_cuda_cp_host_to_dev (state_tmp, stack_state_dev%d_i, error=error) - !$OMP END MASTER - IF (do_master_work) THEN - ! Allocate the on-card parameter stack. - CALL dbcsr_cuda_dev_mem_new (params_dev_l, dbcsr_type_int_4, error) - CALL dbcsr_cuda_dev_mem_alloc (params_dev_l, mm_stack_size*dbcsr_ps_width,& - error=error) + IF (mm_driver == mm_driver_cuda) THEN + !$OMP BARRIER !$OMP MASTER - params_dev => params_dev_l + !TODO: could be async if we use events to make the other streams wait + ! for a and b to be uploaded. + CALL dbcsr_cuda_cp_host_to_dev(host_mem=left%data_area,& + dev_mem=cuda_dev_a_data, async = .FALSE., error=error) + CALL dbcsr_cuda_cp_host_to_dev(host_mem=right%data_area,& + dev_mem=cuda_dev_b_data, async = .FALSE., error=error) !$OMP END MASTER + !$OMP BARRIER ENDIF - !$OMP BARRIER - !$OMP CRITICAL (crit_data_card) - ! - IF (.FALSE.) THEN - ! Left in for mental accounting - CALL dbcsr_cuda_dev_mem_hold (stack_state_dev, error=error) + + CALL dbcsr_error_stop(error_handler, error) + END SUBROUTINE dbcsr_mm_driver_inner_init + + +! ***************************************************************************** +!> \brief Finalizes a multiplication cycle for a set of A- and B-blocks. +!> \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_driver_inner_finalize(drv_carrier, error) + TYPE(driver_carrier_type), INTENT(INOUT) :: drv_carrier + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + IF (mm_driver == mm_driver_cuda) THEN + !TODO: waiting for ALL streams - should only wait for those of this thread + !$OMP BARRIER + CALL dbcsr_cuda_device_sync(error) + !$OMP BARRIER + END IF + END SUBROUTINE dbcsr_mm_driver_inner_finalize + + +! ***************************************************************************** +!> \brief Finalizes a multiplication cycle for a set of C-blocks. +!> \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_driver_outer_finalize(drv_carrier, product,stackgrid_data, stackgrid_state, error) + USE ISO_C_BINDING + TYPE(driver_carrier_type), INTENT(INOUT) :: drv_carrier + TYPE(dbcsr_type), INTENT(inout) :: product + INTEGER, DIMENSION(:, :, :, :), POINTER :: stackgrid_data + INTEGER, DIMENSION(:, :), POINTER :: stackgrid_state + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + INTEGER :: data_type, datasize, ithread + TYPE(dbcsr_data_obj) :: tmp_data + + ithread = 0 + !$ ithread = omp_get_thread_num() + + IF (mm_driver /= mm_driver_cuda) THEN + DEALLOCATE(stackgrid_data) + DEALLOCATE(stackgrid_state) + ELSE + ! Host-pinned memory not dealloced, will be reused by next multiplication + NULLIFY(stackgrid_data, stackgrid_state) + + ! Transfer C-data from GPU to host and adding it to host's result + datasize = product%wms(ithread+1)%datasize + data_type = dbcsr_data_get_type(product%wms(ithread+1)%data_area) + + CALL dbcsr_data_init(tmp_data) + CALL dbcsr_data_new(tmp_data, data_type=data_type, data_size=datasize) + CALL dbcsr_cuda_cp_dev_to_host(dev_mem=cuda_dev_c_data,& + host_mem=tmp_data, error=error) + CALL block_add(product%wms(ithread+1)%data_area, tmp_data,& + len=datasize, error=error) + CALL dbcsr_data_release(tmp_data) + + cuda_mem_in_use = .FALSE. ENDIF - ! all threads share the master's stack_state_dev - product_target%stack_state_dev => stack_state_dev - IF (do_master_work) THEN - product_target%params_dev => params_dev_l - ELSE - product_target%params_dev => params_dev - ENDIF - CALL dbcsr_cuda_dev_mem_hold (product_target%params_dev, error=error) - IF (.FALSE.) THEN - ! Left in for mental accounting - CALL dbcsr_cuda_dev_mem_release (stack_state_dev, error=error) - ENDIF - ! - !$OMP END CRITICAL (crit_data_card) - !$OMP BARRIER - IF (do_master_work) THEN - !$OMP CRITICAL (crit_data_card) - CALL dbcsr_cuda_dev_mem_release (params_dev_l, error=error) - !$OMP END CRITICAL (crit_data_card) - ENDIF - ! - CALL dbcsr_error_stop(error_handle, error) - END SUBROUTINE init_card_c - - + END SUBROUTINE dbcsr_mm_driver_outer_finalize + + +! ***************************************************************************** +! \brief Processes a given stack. +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_driver_process_stack(drv_carrier, driver, stack_data,& + stack_fillcount, stack_state, stack_descr, stack_id, error) + TYPE(driver_carrier_type), INTENT(INOUT) :: drv_carrier + INTEGER, INTENT(IN) :: driver + INTEGER, DIMENSION(:, :), POINTER :: stack_data + INTEGER, POINTER :: stack_fillcount, stack_state + TYPE(stack_descriptor_type), POINTER :: stack_descr + INTEGER, INTENT(IN) :: stack_id + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + REAL, PARAMETER :: resize_factor = 1.618034 + + INTEGER :: allocated_datasize, nblks, & + new_c_size, new_locks_size, & + old_c_size, stacked_datasize + !INTEGER(kind=int_8) :: flop + +!TODO: make difference clear between driver, mm_driver and mm_host_driver. +! collect statistics + + stack_descr%total_entries = stack_descr%total_entries + stack_fillcount + + stacked_datasize = drv_carrier%product_wm%datasize + allocated_datasize = dbcsr_data_get_size(drv_carrier%product_wm%data_area) + + ! tell the data_area how much of its memory is actually beeing used. + CALL dbcsr_data_set_size_referenced(drv_carrier%product_wm%data_area, stacked_datasize) + + ! Resizing the product data (on host and card) --------------------------- + IF (stacked_datasize > allocated_datasize) THEN + + ! Resize the target data area if the stack references a target + ! matrix data element outside of its current range. When + ! appropriate a lock on the data area is taken. + !WRITE (*,*) "dbcsr_mm_driver_process_stack: We need to resize c data" + + !IF (dbg) & + ! WRITE(*,*)routineN//" Resizing to", LOG(REAL(maxs))/LOG(10.0) + CALL dbcsr_data_ensure_size(drv_carrier%product_wm%data_area,& + stacked_datasize, factor=resize_factor, zero_pad=.TRUE., error=error) + + IF(stacked_datasize > dbcsr_data_get_size(drv_carrier%product_wm%data_area))& + STOP "dbcsr_mm_driver_process_stack: resizing failed" + + ! Cuda on-device resizing + IF (mm_driver == mm_driver_cuda) THEN + ! All kernels in the stream must be finished before + ! reallocation is performed. + !TODO: waiting for ALL streams - should only wait for those of this thread + CALL dbcsr_cuda_device_sync(error) + + ! dbcsr_data_ensure_size oversizes the array - we need to know how much. + old_c_size = dbcsr_cuda_dev_mem_get_alloc(cuda_dev_c_data) + new_c_size = dbcsr_data_get_size(drv_carrier%product_wm%data_area) + CALL dbcsr_cuda_dev_mem_realloc(cuda_dev_c_data, new_c_size, error=error) + CALL dbcsr_cuda_dev_mem_zero(cuda_dev_c_data,& + first=old_c_size, last=new_c_size, error=error) + END IF + END IF + + ! Resizing the product locks (only on the card) -------------------------- + IF (mm_driver == mm_driver_cuda) THEN + ! Resize locks, which are equal to the new block count. + nblks = drv_carrier%product_wm%lastblk + IF (nblks > dbcsr_cuda_dev_mem_get_alloc(cuda_dev_c_locks)) THEN + !WRITE (*,*) "dbcsr_mm_driver_process_stack: We need to resize c_locks_cuda" + ! All kernels in the stream must be finished before + ! reallocation is performed. + !TODO: waiting for ALL streams - should only wait for those of this thread + CALL dbcsr_cuda_device_sync(error) + new_locks_size = INT(REAL(nblks*4,kind=dp)*resize_factor) + CALL dbcsr_cuda_dev_mem_realloc(cuda_dev_c_locks, new_locks_size, error=error) + CALL dbcsr_cuda_dev_mem_zero(cuda_dev_c_locks,& + first=1, last=new_locks_size, error=error) + END IF + END IF + + !!From here on there is no boundary checking due to assumed-SIZE-arguments. + !!This is usefull to check stack parameters, BUT it works only for kind=dp + !DO sp = 1, stack_fillcount + ! IF(stack_data(p_a_first,sp) > SIZE(drv_carrier%left_data_area%d%r_dp)) & + ! STOP "left data out of range" + ! IF(stack_data(p_b_first,sp) > SIZE(drv_carrier%right_data_area%d%r_dp)) & + ! STOP "right data out of range" + ! IF(stack_data(p_c_first,sp) > SIZE(drv_carrier%product_wm%data_area%d%r_dp)) THEN + ! WRITE (*,*) "blub: ",stack_data(p_c_first,sp) , SIZE(drv_carrier%product_wm%data_area%d%r_dp), & + ! dbcsr_data_get_size(drv_carrier%product_wm%data_area), stacked_datasize + ! STOP "product data out of range" + ! END IF + !END DO + + ! Submitting the stack for processing ------------------------------------- + stack_state = dbcsr_ps_state_working + + ! flop = 2*stack_fillcount*stack_descr%max_m*stack_descr%max_n*stack_descr%max_k + IF (driver == mm_driver_cuda) THEN + ! !$OMP critical + ! num_gpu_stacks = num_gpu_stacks + 1 + ! gpu_flop = gpu_flop + flop + ! !$OMP end critical + CALL process_mm_stack_cuda(params=stack_data,& + stack_size=stack_fillcount,& + data_a_dev=cuda_dev_a_data,& + data_b_dev=cuda_dev_b_data,& + data_c_dev=cuda_dev_c_data,& + c_locks=cuda_dev_c_locks,& + params_dev=cuda_dev_stacklist_data(stack_id)%p,& + m=stack_descr%m,& + n=stack_descr%n,& + k=stack_descr%k,& + max_m=stack_descr%max_m,& + max_n=stack_descr%max_n,& + max_k=stack_descr%max_k,& + defined_mnk=stack_descr%defined_mnk,& + state=stack_state,& + stack_state_dev=cuda_dev_state_empty,& + stack_id=stack_id,& + error=error) + ELSE + ! !$OMP critical + ! num_cpu_stacks = num_cpu_stacks + 1 + ! cpu_flop = cpu_flop + flop + ! !$OMP end critical + CALL process_mm_stack_cpu(params=stack_data,& + driver=driver,& + stack_size=stack_fillcount, & + left_data_area=drv_carrier%left_data_area,& + right_data_area=drv_carrier%right_data_area,& + product_data_area=drv_carrier%product_wm%data_area,& + state=stack_state,& + m=stack_descr%m,& + n=stack_descr%n,& + k=stack_descr%k,& + max_m=stack_descr%max_m,& + max_n=stack_descr%max_n,& + max_k=stack_descr%max_k,& + defined_mnk=stack_descr%defined_mnk,& + stack_id=stack_id,& + error=error) + END IF + + stack_fillcount = 0 !otherwise the stackcolumn gets processed again. + + + END SUBROUTINE dbcsr_mm_driver_process_stack + + END MODULE dbcsr_mm_driver + diff --git a/src/dbcsr_lib/dbcsr_mm_multrec.F b/src/dbcsr_lib/dbcsr_mm_multrec.F index 4f34289bab..bed183dd00 100644 --- a/src/dbcsr_lib/dbcsr_mm_multrec.F +++ b/src/dbcsr_lib/dbcsr_mm_multrec.F @@ -13,14 +13,13 @@ !> - 2010-02-23 Moved from dbcsr_operations !> - 2011-11 Moved parameter-stack processing routines to !> dbcsr_mm_methods. -!> - 2013-01 reorganized code (Ole Schuett) +!> - 2013-01 extensive refactoring (Ole Schuett) ! ***************************************************************************** MODULE dbcsr_mm_multrec USE array_types, ONLY: array_data,& array_equality - USE dbcsr_config, ONLY: mm_thread_workshare USE dbcsr_error_handling USE dbcsr_kinds, ONLY: int_8,& real_8,& @@ -31,29 +30,53 @@ MODULE dbcsr_mm_multrec dbcsr_distribution_local_rows,& dbcsr_distribution_row_dist,& dbcsr_distribution_thread_dist - USE dbcsr_mm_csr, ONLY: csr_multiply_inner_finalize,& - csr_multiply_inner_init,& - csr_multiply_outer_finalize,& - csr_multiply_outer_init,& - csr_multiply_unwrap - USE dbcsr_mm_types, ONLY: carrier_type + USE dbcsr_mm_csr, ONLY: dbcsr_mm_csr_inner_finalize,& + dbcsr_mm_csr_inner_init,& + dbcsr_mm_csr_lib_finalize,& + dbcsr_mm_csr_lib_init,& + dbcsr_mm_csr_multiply,& + dbcsr_mm_csr_outer_finalize,& + dbcsr_mm_csr_outer_init + USE dbcsr_mm_types, ONLY: multrec_carrier_type USE dbcsr_ptr_util, ONLY: ensure_array_size USE dbcsr_types, ONLY: dbcsr_type !$ USE OMP_LIB - + IMPLICIT NONE - + PRIVATE - + CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_mm_multrec' LOGICAL, PARAMETER :: careful_mod = .FALSE. - PUBLIC :: dbcsr_multrec_init - PUBLIC :: dbcsr_multrec_sparse - PUBLIC :: dbcsr_multrec_finalize - -CONTAINS + PUBLIC :: dbcsr_mm_multrec_lib_init, dbcsr_mm_multrec_lib_finalize + PUBLIC :: dbcsr_mm_multrec_init, dbcsr_mm_multrec_finalize + PUBLIC :: dbcsr_mm_multrec_multiply + + CONTAINS + +! ***************************************************************************** +! \brief Initialize the library +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_multrec_lib_init(error) + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + CALL dbcsr_mm_csr_lib_init(error) + END SUBROUTINE + + +! ***************************************************************************** +! \brief Finalize the library +! \author Ole Schuett +! ***************************************************************************** + SUBROUTINE dbcsr_mm_multrec_lib_finalize(error) + TYPE(dbcsr_error_type), INTENT(INOUT) :: error + + CALL dbcsr_mm_csr_lib_finalize(error) + END SUBROUTINE + ! ***************************************************************************** !> \brief Sets up recursive multiplication @@ -65,23 +88,18 @@ CONTAINS !> existing product matrix, default is no !> \param[in] eps (optional) on-the-fly filtering epsilon ! ***************************************************************************** - SUBROUTINE dbcsr_multrec_init(left, right, product, carrier,& - right_data_sr, right_data_rr, left_data_sr, left_data_rr, & - right_index_sr, right_index_rr, left_index_sr, left_index_rr, & + SUBROUTINE dbcsr_mm_multrec_init(left, right, product, multrec_carrier,& keep_sparsity, eps, row_max_epss, fill_guess, error) TYPE(dbcsr_type), INTENT(IN) :: left, right TYPE(dbcsr_type), INTENT(INOUT) :: product - TYPE(carrier_type), INTENT(out) :: carrier - INTEGER, DIMENSION(:, :), POINTER :: right_data_sr, right_data_rr, & - left_data_sr, left_data_rr, right_index_sr, right_index_rr, & - left_index_sr, left_index_rr + TYPE(multrec_carrier_type), INTENT(out) :: multrec_carrier LOGICAL, INTENT(IN) :: keep_sparsity REAL(kind=real_8), INTENT(in), OPTIONAL :: eps REAL(kind=sp), DIMENSION(:), INTENT(IN) :: row_max_epss REAL(KIND=real_8) :: fill_guess TYPE(dbcsr_error_type), INTENT(inout) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_multrec_init', & + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_multrec_init', & routineP = moduleN//':'//routineN LOGICAL, PARAMETER :: dbg = .FALSE. @@ -90,35 +108,30 @@ CONTAINS error_handler, i, ithread INTEGER, DIMENSION(:), POINTER :: c_local_cols, c_local_rows, & product_thread_dist - LOGICAL :: local_cols, local_indexing, & - local_rows ! --------------------------------------------------------------------------- CALL dbcsr_error_set(routineN, error_handler, error) - + ithread = 0 !$ ithread = OMP_GET_THREAD_NUM () - carrier%id = ithread ! ! Ensures that the index is correctly defined. CALL dbcsr_assert (left%list_indexing,& dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& "Must use list indexing for this routine.", __LINE__, error=error) - ! + CALL dbcsr_assert ("NOT", left%bcsc,& dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& "Wrong routine for BCSC matrices.", __LINE__, error=error) CALL dbcsr_assert ("NOT", right%bcsc,& dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& "Wrong routine for BCSC matrices.", __LINE__, error=error) - local_cols = right%local_indexing - local_rows = left%local_indexing - CALL dbcsr_assert (local_cols, "EQV", local_rows,& + CALL dbcsr_assert (right%local_indexing, "EQV", left%local_indexing,& dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& "Local index useage must be consistent.", __LINE__, error=error) - local_indexing = local_rows - IF (local_cols) THEN + + IF (right%local_indexing) THEN CALL dbcsr_assert (left%local_indexing,& dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& "Wrong left format for local_cols.", __LINE__, error=error) @@ -134,28 +147,18 @@ CONTAINS "Wrong right format for not local_cols.", __LINE__, error=error) ENDIF ! - ! Fill carrier data structure. - carrier%local_indexing = local_indexing - carrier%keep_sparsity = keep_sparsity - carrier%c_has_symmetry = product%symmetry - carrier%use_eps = PRESENT (eps) - carrier%my_wm = product%wms(ithread+1) - carrier%lastblk = product%wms(ithread+1)%lastblk - carrier%original_lastblk = carrier%lastblk - carrier%datasize = product%wms(ithread+1)%datasize - carrier%flop = INT(0, int_8) - carrier%right_data_sr => right_data_sr - carrier%right_data_rr => right_data_rr - carrier%right_index_sr => right_index_sr - carrier%right_index_rr => right_index_rr - carrier%left_data_sr => left_data_sr - carrier%left_data_rr => left_data_rr - carrier%left_index_sr => left_index_sr - carrier%left_index_rr => left_index_rr + ! Fill multrec_carrier data structure. + multrec_carrier%local_indexing = left%local_indexing + multrec_carrier%keep_sparsity = keep_sparsity + multrec_carrier%c_has_symmetry = product%symmetry + multrec_carrier%use_eps = PRESENT (eps) + multrec_carrier%original_lastblk = product%wms(ithread+1)%lastblk + multrec_carrier%flop = INT(0, int_8) + IF (PRESENT (eps)) THEN - carrier%eps = eps + multrec_carrier%eps = eps ELSE - carrier%eps = 0.0_real_8 + multrec_carrier%eps = 0.0_real_8 ENDIF ! ! @@ -171,17 +174,17 @@ CONTAINS c_local_rows => array_data (product%local_rows) c_nblkcols_local = product%nblkcols_local c_local_cols => array_data (product%local_cols) - IF (local_indexing) THEN - carrier%c_local_rows => c_local_rows - carrier%c_local_cols => c_local_cols + IF (multrec_carrier%local_indexing) THEN + multrec_carrier%c_local_rows => c_local_rows + multrec_carrier%c_local_cols => c_local_cols ELSE - ALLOCATE (carrier%c_local_rows (product%nblkrows_total)) - ALLOCATE (carrier%c_local_cols (product%nblkcols_total)) + ALLOCATE (multrec_carrier%c_local_rows (product%nblkrows_total)) + ALLOCATE (multrec_carrier%c_local_cols (product%nblkcols_total)) FORALL (i = 1 : product%nblkrows_total) - carrier%c_local_rows(i) = i + multrec_carrier%c_local_rows(i) = i END FORALL FORALL (i = 1 : product%nblkcols_total) - carrier%c_local_cols(i) = i + multrec_carrier%c_local_cols(i) = i END FORALL ENDIF IF (dbg) WRITE(*,*)"setting up for product", product%name @@ -213,54 +216,57 @@ CONTAINS ENDIF ! ! And the k epsilons - IF (local_indexing) THEN - ALLOCATE (carrier%row_max_epss(c_nblkrows_local)) + IF (multrec_carrier%local_indexing) THEN + ALLOCATE (multrec_carrier%row_max_epss(c_nblkrows_local)) ELSE - ALLOCATE (carrier%row_max_epss(product%nblkrows_total)) + ALLOCATE (multrec_carrier%row_max_epss(product%nblkrows_total)) ENDIF - IF (carrier%use_eps) THEN - IF (local_indexing) THEN + IF (multrec_carrier%use_eps) THEN + IF (multrec_carrier%local_indexing) THEN CALL local_filter_sp(row_max_epss, c_nblkrows_local, c_local_rows,& - carrier%row_max_epss) + multrec_carrier%row_max_epss) ELSE IF (careful_mod) & - CALL dbcsr_assert (SIZE(row_max_epss) .EQ. SIZE(carrier%row_max_epss),& + CALL dbcsr_assert (SIZE(row_max_epss) .EQ. SIZE(multrec_carrier%row_max_epss),& dbcsr_fatal_level, dbcsr_internal_error, routineN,& "max epss local/global mismatch.", __LINE__, error=error) - carrier%row_max_epss(:) = row_max_epss(:) + multrec_carrier%row_max_epss(:) = row_max_epss(:) ENDIF ELSE - carrier%row_max_epss(:) = -HUGE(0.0_sp) + multrec_carrier%row_max_epss(:) = -HUGE(0.0_sp) ENDIF ! - IF (local_indexing) THEN - ALLOCATE(carrier%m_sizes(c_nblkrows_local)) + IF (multrec_carrier%local_indexing) THEN + ALLOCATE(multrec_carrier%m_sizes(c_nblkrows_local)) CALL local_filter(array_data (product%row_blk_size), SIZE(c_local_rows),& - c_local_rows, carrier%m_sizes) - ALLOCATE(carrier%n_sizes(c_nblkcols_local)) + c_local_rows, multrec_carrier%m_sizes) + ALLOCATE(multrec_carrier%n_sizes(c_nblkcols_local)) CALL local_filter(array_data (product%col_blk_size), SIZE(c_local_cols),& - c_local_cols, carrier%n_sizes) + c_local_cols, multrec_carrier%n_sizes) ELSE - ALLOCATE(carrier%m_sizes(product%nblkrows_total)) - carrier%m_sizes(:) = array_data (product%row_blk_size) - ALLOCATE(carrier%n_sizes(product%nblkcols_total)) - carrier%n_sizes(:) = array_data (product%col_blk_size) + ALLOCATE(multrec_carrier%m_sizes(product%nblkrows_total)) + multrec_carrier%m_sizes(:) = array_data (product%row_blk_size) + ALLOCATE(multrec_carrier%n_sizes(product%nblkcols_total)) + multrec_carrier%n_sizes(:) = array_data (product%col_blk_size) ENDIF ! - NULLIFY (carrier%k_locals) - NULLIFY (carrier%k_sizes) - IF (.NOT. local_indexing) THEN - ALLOCATE (carrier%k_locals(right%nblkrows_total)) + NULLIFY (multrec_carrier%k_locals) + NULLIFY (multrec_carrier%k_sizes) + IF (.NOT. multrec_carrier%local_indexing) THEN + ALLOCATE (multrec_carrier%k_locals(right%nblkrows_total)) FORALL (i = 1:right%nblkrows_total) - carrier%k_locals(i) = i + multrec_carrier%k_locals(i) = i END FORALL - carrier%k_sizes => array_data (right%row_blk_size) + multrec_carrier%k_sizes => array_data (right%row_blk_size) ENDIF - - CALL csr_multiply_outer_init(left, right, product, carrier, fill_guess, error=error) - + + CALL dbcsr_mm_csr_outer_init(csr_carrier=multrec_carrier%csr_carrier, & + left=left, right=right, product=product,fill_guess=fill_guess,& + m_sizes=multrec_carrier%m_sizes, n_sizes=multrec_carrier%n_sizes,& + k_sizes=multrec_carrier%k_sizes, error=error) + CALL dbcsr_error_stop(error_handler, error) - END SUBROUTINE dbcsr_multrec_init + END SUBROUTINE dbcsr_mm_multrec_init ! ***************************************************************************** @@ -282,121 +288,85 @@ CONTAINS !> \param[out] flop (optional) number of effective double-precision !> floating point operations performed ! ***************************************************************************** - SUBROUTINE dbcsr_multrec_sparse(left, right, product, carrier, flop,& - keep_sparsity, a_norms, b_norms, eps, row_max_epss, error) + SUBROUTINE dbcsr_mm_multrec_multiply(left, right, product, multrec_carrier, flop,& + keep_sparsity, a_norms, b_norms, error) TYPE(dbcsr_type), INTENT(IN) :: left, right TYPE(dbcsr_type), INTENT(INOUT) :: product - TYPE(carrier_type), INTENT(inout) :: carrier + TYPE(multrec_carrier_type), & + INTENT(inout) :: multrec_carrier INTEGER(KIND=int_8), INTENT(OUT) :: flop LOGICAL, INTENT(IN) :: keep_sparsity REAL(kind=sp), DIMENSION(:), & INTENT(in), TARGET :: a_norms, b_norms - REAL(kind=real_8), INTENT(in), OPTIONAL :: eps - REAL(kind=sp), DIMENSION(:), & - INTENT(in), TARGET :: row_max_epss TYPE(dbcsr_error_type), INTENT(inout) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_multrec_sparse', & + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_multrec_multiply', & routineP = moduleN//':'//routineN LOGICAL, PARAMETER :: dbg = .FALSE. INTEGER :: ithread, nthreads, t_a_f, & t_a_l, t_b_f, t_b_l INTEGER, DIMENSION(:), POINTER :: k_locals - LOGICAL :: local_cols, local_indexing, & - local_rows ! --------------------------------------------------------------------------- -! ithread = 0 ; nthreads = 1 !$ ithread = OMP_GET_THREAD_NUM () ; nthreads = OMP_GET_NUM_THREADS () - carrier%flop = 0 - - CALL csr_multiply_inner_init(left, right, carrier, error=error) - - local_cols = right%local_indexing - local_rows = left%local_indexing - local_indexing = local_rows - + multrec_carrier%flop = 0 + + CALL dbcsr_mm_csr_inner_init(left=left, right=right, & + csr_carrier=multrec_carrier%csr_carrier, error=error) + ! Find out the local A columns / B rows and sizes ! The right%local_rows is setup by the communication engine. - IF (local_indexing) THEN + IF (multrec_carrier%local_indexing) THEN k_locals => array_data (right%local_rows) - carrier%k_locals => k_locals - CALL ensure_array_size (carrier%k_sizes, ub=SIZE(k_locals), error=error) + multrec_carrier%k_locals => k_locals + CALL ensure_array_size (multrec_carrier%k_sizes, ub=SIZE(k_locals), error=error) CALL local_filter(array_data(right%row_blk_size), SIZE(k_locals),& - k_locals, carrier%k_sizes) + k_locals, multrec_carrier%k_sizes) ELSE - k_locals => carrier%k_locals + k_locals => multrec_carrier%k_locals ENDIF ! Setup the block norms - carrier%a_norms => a_norms - carrier%b_norms => b_norms - ! - IF (mm_thread_workshare) THEN - !$OMP BARRIER - ENDIF - ! + multrec_carrier%a_norms => a_norms + multrec_carrier%b_norms => b_norms + + ! Start local multiplication - IF (.TRUE.) THEN - t_a_f = 1 - t_a_l = left%nblks - t_b_f = 1 - t_b_l = right%nblks - !$ ithread = OMP_GET_THREAD_NUM() - !$ t_a_f = left%thr_c(ithread+1)+1 - !$ t_a_l = left%thr_c(ithread+2) - IF (left%local_indexing) THEN - CALL sparse_multrec(& - 1, left%nblkrows_local,& - 1, right%nblkcols_local,& - 1, SIZE(k_locals),& - t_a_f, t_a_l, left%coo_l,& - t_b_f, t_b_l, right%coo_l,& - carrier, error, 0) - ELSE - CALL sparse_multrec(& - 1, left%nblkrows_total,& - 1, right%nblkcols_total,& - 1, SIZE(k_locals),& - t_a_f, t_a_l, left%coo_l,& - t_b_f, t_b_l, right%coo_l,& - carrier, error, 0) - ENDIF + t_a_f = 1 + t_a_l = left%nblks + t_b_f = 1 + t_b_l = right%nblks + !$ ithread = OMP_GET_THREAD_NUM() + !$ t_a_f = left%thr_c(ithread+1)+1 + !$ t_a_l = left%thr_c(ithread+2) + IF (multrec_carrier%local_indexing) THEN + CALL sparse_multrec(& + 1, left%nblkrows_local,& + 1, right%nblkcols_local,& + 1, SIZE(k_locals),& + t_a_f, t_a_l, left%coo_l,& + t_b_f, t_b_l, right%coo_l,& + product, multrec_carrier, error, 0) ELSE - ! For debugging. This avoids the recursion but it might not - ! work anymore. - IF (left%local_indexing) THEN - CALL csr_multiply_unwrap(& - 1, left%nblkrows_local,& - 1, right%nblkrows_local,& - 1, SIZE(k_locals),& - 1, left%nblks, left%row_p,& - 1, right%nblks, right%row_p,& - carrier, error) - ELSE - CALL csr_multiply_unwrap(& - 1, left%nblkrows_total,& - 1, right%nblkrows_total,& - 1, SIZE(k_locals),& - 1, left%nblks, left%row_p,& - 1, right%nblks, right%row_p,& - carrier, error) - ENDIF + CALL sparse_multrec(& + 1, left%nblkrows_total,& + 1, right%nblkcols_total,& + 1, SIZE(k_locals),& + t_a_f, t_a_l, left%coo_l,& + t_b_f, t_b_l, right%coo_l,& + product, multrec_carrier, error, 0) ENDIF + + CALL dbcsr_mm_csr_inner_finalize(csr_carrier=multrec_carrier%csr_carrier, error=error) + flop = multrec_carrier%flop ! - CALL csr_multiply_inner_finalize(carrier, error=error) - flop = carrier%flop - ! - IF (ASSOCIATED (carrier%k_sizes) .AND. carrier%local_indexing) & - DEALLOCATE (carrier%k_sizes) - ! - product%wms(ithread+1)%lastblk = carrier%lastblk - product%wms(ithread+1)%datasize = carrier%datasize - ! - END SUBROUTINE dbcsr_multrec_sparse - + IF (ASSOCIATED (multrec_carrier%k_sizes) .AND. multrec_carrier%local_indexing) & + DEALLOCATE (multrec_carrier%k_sizes) + + END SUBROUTINE dbcsr_mm_multrec_multiply + ! ***************************************************************************** !> \brief Sets up recursive multiplication @@ -408,12 +378,13 @@ CONTAINS !> existing product matrix, default is no !> \param[in] eps (optional) on-the-fly filtering epsilon ! ***************************************************************************** - SUBROUTINE dbcsr_multrec_finalize(carrier, product, error) - TYPE(carrier_type), INTENT(inout) :: carrier + SUBROUTINE dbcsr_mm_multrec_finalize(multrec_carrier, product, error) + TYPE(multrec_carrier_type), & + INTENT(inout) :: multrec_carrier TYPE(dbcsr_type), INTENT(inout) :: product TYPE(dbcsr_error_type), INTENT(inout) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_multrec_finalize', & + CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_mm_multrec_finalize', & routineP = moduleN//':'//routineN LOGICAL, PARAMETER :: dbg = .FALSE. @@ -422,64 +393,52 @@ CONTAINS ! --------------------------------------------------------------------------- CALL dbcsr_error_set(routineN, error_handler, error) - CALL csr_multiply_outer_finalize(carrier, product, error=error) - + CALL dbcsr_mm_csr_outer_finalize(csr_carrier=multrec_carrier%csr_carrier,& + product=product, error=error) + ithread = 0 !$ ithread = OMP_GET_THREAD_NUM() - - ! Release the carrier - DEALLOCATE (carrier%m_sizes) - DEALLOCATE (carrier%n_sizes) - DEALLOCATE (carrier%row_max_epss) - - IF (carrier%local_indexing) THEN - CALL remap_local2global(carrier%my_wm%row_i, carrier%my_wm%col_i,& - carrier%c_local_rows, carrier%c_local_cols,& - carrier%original_lastblk+1, carrier%lastblk) - ENDIF - ! - DEALLOCATE (carrier%m_size_maps) - DEALLOCATE (carrier%n_size_maps) - DEALLOCATE (carrier%k_size_maps) - DEALLOCATE (carrier%stack_map) - IF (.NOT. carrier%local_indexing) THEN - DEALLOCATE (carrier%c_local_rows) - DEALLOCATE (carrier%c_local_cols) - DEALLOCATE (carrier%k_locals) - NULLIFY (carrier%k_sizes) - ENDIF - ! - ! Reinstate WM - carrier%my_wm%lastblk = carrier%lastblk - carrier%my_wm%datasize = carrier%datasize - product%wms(ithread+1) = carrier%my_wm - NULLIFY(carrier%right_data_sr) - NULLIFY(carrier%right_data_rr) - NULLIFY(carrier%right_index_sr) - NULLIFY(carrier%right_index_rr) - NULLIFY(carrier%left_data_sr) - NULLIFY(carrier%left_data_rr) - NULLIFY(carrier%left_index_sr) - NULLIFY(carrier%left_index_rr) + ! Release the carrier + DEALLOCATE (multrec_carrier%m_sizes) + DEALLOCATE (multrec_carrier%n_sizes) + DEALLOCATE (multrec_carrier%row_max_epss) + + IF (multrec_carrier%local_indexing) THEN + CALL remap_local2global(product%wms(ithread+1)%row_i, & + product%wms(ithread+1)%col_i, & + multrec_carrier%c_local_rows, multrec_carrier%c_local_cols,& + multrec_carrier%original_lastblk+1, product%wms(ithread+1)%lastblk) + ENDIF ! + + IF (.NOT. multrec_carrier%local_indexing) THEN + DEALLOCATE (multrec_carrier%c_local_rows) + DEALLOCATE (multrec_carrier%c_local_cols) + DEALLOCATE (multrec_carrier%k_locals) + NULLIFY (multrec_carrier%k_sizes) + ENDIF + CALL dbcsr_error_stop(error_handler, error) - END SUBROUTINE dbcsr_multrec_finalize - - - + END SUBROUTINE dbcsr_mm_multrec_finalize + + + + ! ***************************************************************************** !> \brief Performs recursive multiplication !> \author Joost VandeVondele ! ***************************************************************************** RECURSIVE SUBROUTINE sparse_multrec(mi, mf, ni, nf, ki, kf,& ai, af, a_index, bi, bf, b_index, & - carrier, error, d) + product, carrier, error, d) INTEGER, INTENT(IN) :: mi, mf, ni, nf, ki, kf, ai, af INTEGER, DIMENSION(3, 1:af), INTENT(IN) :: a_index INTEGER, INTENT(IN) :: bi, bf INTEGER, DIMENSION(3, 1:bf), INTENT(IN) :: b_index - TYPE(carrier_type), INTENT(INOUT) :: carrier + TYPE(dbcsr_type), INTENT(INOUT) :: product + TYPE(multrec_carrier_type), & + INTENT(INOUT) :: carrier TYPE(dbcsr_error_type), INTENT(INOUT) :: error INTEGER, INTENT(IN) :: d @@ -502,13 +461,23 @@ CONTAINS RETURN ENDIF ENDIF + IF (af-ai+1 <= norec .AND. bf-bi+1 <= norec) THEN - CALL csr_multiply_unwrap(& - mi, mf, ni, nf, ki, kf,& - ai, af, a_index,& - bi, bf, b_index,& - carrier, error) - RETURN + IF (af-ai+1 .GT. 0 .AND. bf-bi+1 .GT. 0) & + CALL dbcsr_mm_csr_multiply(mi=mi, mf=mf,ni=ni, nf=nf, ki=ki, kf=kf,& + ai=ai, af=af, & + bi=bi, bf=bf,& + m_sizes=carrier%m_sizes, n_sizes=carrier%n_sizes, k_sizes=carrier%k_sizes,& + c_local_rows=carrier%c_local_rows, c_local_cols=carrier%c_local_cols,& + c_has_symmetry=carrier%c_has_symmetry, keep_sparsity=carrier%keep_sparsity,& + use_eps=carrier%use_eps, row_max_epss=carrier%row_max_epss,& + flop=carrier%flop,& + a_index=a_index, b_index=b_index,& + a_norms=carrier%a_norms, b_norms=carrier%b_norms,& + csr_carrier=carrier%csr_carrier, & + product=product,& + error=error) + RETURN ENDIF M = mf-mi + 1 @@ -525,9 +494,9 @@ CONTAINS s1=M/2 acut = find_cut_row(ai,af,a_index,mi+s1-1) CALL sparse_multrec(mi,mi+s1-1, ni,nf, ki,kf,& - ai,acut-1,a_index, bi,bf,b_index, carrier, error,d+1) + ai,acut-1,a_index, bi,bf,b_index, product, carrier, error,d+1) CALL sparse_multrec(mi+s1,mf, ni,nf, ki,kf,& - acut,af,a_index, bi,bf,b_index, carrier, error,d+1) + acut,af,a_index, bi,bf,b_index, product, carrier, error,d+1) CASE(2) s1=K/2 acut = find_cut_col(ai,af,a_index,ki+s1-1) @@ -541,9 +510,9 @@ CONTAINS WRITE(*,'(3(I7))')b_index ENDIF CALL sparse_multrec(mi,mf, ni,nf, ki,ki+s1-1,& - ai,acut-1,a_index, bi,bcut-1,b_index, carrier, error,d+1) + ai,acut-1,a_index, bi,bcut-1,b_index, product, carrier, error,d+1) CALL sparse_multrec(mi,mf, ni,nf, ki+s1,kf,& - acut,af,a_index, bcut,bf,b_index, carrier, error,d+1) + acut,af,a_index, bcut,bf,b_index, product, carrier, error,d+1) CASE(3) s1=N/2 bcut = find_cut_col(bi,bf,b_index,ni+s1-1) @@ -552,15 +521,15 @@ CONTAINS WRITE(*,'(3(I7))')b_index ENDIF CALL sparse_multrec(mi,mf, ni,ni+s1-1, ki,kf,& - ai,af,a_index, bi,bcut-1,b_index, carrier, error,d+1) + ai,af,a_index, bi,bcut-1,b_index, product, carrier, error,d+1) CALL sparse_multrec(mi,mf, ni+s1,nf, ki,kf,& - ai,af,a_index, bcut,bf,b_index, carrier, error,d+1) + ai,af,a_index, bcut,bf,b_index, product, carrier, error,d+1) END SELECT END SUBROUTINE sparse_multrec - + ! ****************************************************************************** -!> \brief +!> \brief !> \author JV ! ****************************************************************************** PURE FUNCTION find_cut_row(ai,af,a,val) RESULT(res) @@ -601,13 +570,13 @@ CONTAINS ! IF (a(i)%r>val) EXIT !ENDDO !res=i - END FUNCTION find_cut_row + END FUNCTION find_cut_row + - ! ****************************************************************************** -!> \brief +!> \brief !> \author JV -! ****************************************************************************** +! ****************************************************************************** PURE FUNCTION find_cut_col(ai,af,a,val) RESULT(res) INTEGER, INTENT(IN) :: ai, af INTEGER, DIMENSION(3, 1:af), INTENT(IN) :: a @@ -648,11 +617,11 @@ CONTAINS !res=i END FUNCTION find_cut_col - - + + ! ****************************************************************************** !> \brief Packs a globally-indexed array into a locally-indexed array. -! ****************************************************************************** +! ****************************************************************************** PURE SUBROUTINE remap_local2global(row_i, col_i, local_rows, local_cols,& first, last) INTEGER, INTENT(in) :: last, first @@ -727,7 +696,7 @@ CONTAINS local_data(l) = full_data(local_elements(l)) END FORALL END SUBROUTINE local_filter_sp - + END MODULE dbcsr_mm_multrec diff --git a/src/dbcsr_lib/dbcsr_mm_stack.F b/src/dbcsr_lib/dbcsr_mm_stack.F index dba0492f09..365ef81c84 100644 --- a/src/dbcsr_lib/dbcsr_mm_stack.F +++ b/src/dbcsr_lib/dbcsr_mm_stack.F @@ -13,43 +13,24 @@ ! - 2011-09-26 Split dbcsr_internal_operations ! ***************************************************************************** MODULE dbcsr_mm_stack - USE dbcsr_block_operations, ONLY: dbcsr_data_clear - USE dbcsr_config, ONLY: & - driver_is_async, mm_async, mm_driver, mm_driver_blas, mm_driver_cuda, & - mm_driver_matmul, mm_driver_plasma, mm_driver_smm, mm_thread_workshare - USE dbcsr_cuda_device, ONLY: dbcsr_cuda_device_sync,& - dbcsr_cuda_stream_sync - USE dbcsr_cuda_memory, ONLY: dbcsr_cuda_dev_mem_alloc,& - dbcsr_cuda_dev_mem_dealloc,& - dbcsr_cuda_dev_mem_realloc,& - dbcsr_cuda_dev_mem_zero - USE dbcsr_cuda_methods, ONLY: dbcsr_cuda_dev_mem_get_alloc + USE dbcsr_config, ONLY: driver_is_async,& + mm_driver_blas,& + mm_driver_matmul,& + mm_driver_plasma,& + mm_driver_smm USE dbcsr_cuda_operations, ONLY: dbcsr_cuda_cp_dev_to_host,& dbcsr_cuda_cp_host_to_dev,& dbcsr_cuda_do_mm_stack USE dbcsr_cuda_types, ONLY: dbcsr_cuda_mem_type - USE dbcsr_data_methods, ONLY: dbcsr_data_ensure_size,& - dbcsr_data_get_size,& - dbcsr_data_set_size_referenced + USE dbcsr_data_methods, ONLY: dbcsr_data_get_size USE dbcsr_error_handling USE dbcsr_kinds, ONLY: dp,& real_4,& real_8,& sp - USE dbcsr_pq_methods, ONLY: & - dbcsr_pq_add_stack, dbcsr_pq_flush_level_chg, dbcsr_pq_get_any_stack, & - dbcsr_pq_get_far_stack, dbcsr_pq_get_own_stack, & - dbcsr_pq_handoff_level_chg, dbcsr_ps_set_get_group_p, & - dbcsr_ps_set_get_n_working, dbcsr_ps_target_lock_main, & - dbcsr_ps_target_lock_regions, dbcsr_ps_target_new_regions, & - dbcsr_ps_target_unlock_main, dbcsr_ps_target_unlock_regions, & - dbcsr_psg_get_state, dbcsr_psg_set_state - USE dbcsr_pq_types, ONLY: & - dbcsr_pq_type, dbcsr_ps_group_type, dbcsr_ps_obj, dbcsr_ps_set_type, & - dbcsr_ps_state_empty, dbcsr_ps_state_queued, dbcsr_ps_state_working, & - dbcsr_ps_target_obj, dbcsr_ps_target_type, dbcsr_ps_type, & - dbcsr_ps_width, max_regions, p_a_first, p_b_first, p_c_first, p_k, & - p_m, p_n + USE dbcsr_mm_types, ONLY: & + dbcsr_ps_state_empty, dbcsr_ps_state_working, dbcsr_ps_width, & + p_a_first, p_b_first, p_c_first, p_k, p_m, p_n USE dbcsr_toollib, ONLY: sort USE dbcsr_types, ONLY: dbcsr_data_obj,& dbcsr_type_complex_4,& @@ -76,548 +57,13 @@ MODULE dbcsr_mm_stack LOGICAL, PARAMETER, PUBLIC :: show_levels = .FALSE. LOGICAL, PARAMETER :: verbose_acc = .FALSE. - PUBLIC :: enqueue_ps_group - PUBLIC :: process_queue_mine,& - process_queue_others,& - process_queue_preempt,& - get_stack_or_process_queue - + PUBLIC :: process_mm_stack_cpu, process_mm_stack_cuda LOGICAL, PARAMETER :: debug_mod = .FALSE. LOGICAL, PARAMETER :: careful_mod = .FALSE. - !> \var max_stack_block_size The maximal block size to be specially - !> treated. - INTEGER, PARAMETER :: max_stack_block_size = HUGE (INT (0)) - - !$ INTEGER(KIND=omp_lock_kind), SAVE :: accel_lock - CONTAINS -! ***************************************************************************** -!> \brief Puts stacks ready to be processed into a queue -!> -!> All non-empty stacks in the param_group are added to the queue. -!> \par Non-worksharing -!> When mm_thread_workshare is FALSE the stacks are instead processessed -!> immediately, bypassing the queue. -!> \param[in,out] queue My queue, to which parameter stacks are added. -!> \param[in] param_group Parameter stacks to add to queue -!> \param[in,out] error error -!> \note The queue and param_groups parameters could be INTENT(INOUT) -!> when OpenMP is not used. -! ***************************************************************************** - SUBROUTINE enqueue_ps_group (queue, param_group, error) - TYPE(dbcsr_pq_type), POINTER :: queue - TYPE(dbcsr_ps_group_type), POINTER :: param_group - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - CHARACTER(len=*), PARAMETER :: routineN = 'enqueue_ps_group', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: careful = careful_mod, & - dbg = debug_mod - - INTEGER :: error_handle, i - - IF (careful_mod) & - CALL dbcsr_error_set(routineN, error_handle, error) - CALL dbcsr_psg_set_state (param_group, dbcsr_ps_state_queued, error) - param_group%master%s%driver = mm_driver - !$ if (dbg) write(*,*)" lckng targt", OMP_GET_THREAD_NUM(),& - !$ param_group%master%s%t%t%owner - CALL process_ps_target_low (param_group%master%s%t,& - param_group%master%s%t%t%product_data_area,& - param_group%master%s%t%t%zero_first,& - param_group%master%s%t%t%zero_last,& - param_group%master%s%t%t%last_c_blk,& - param_group%master%s%driver,& - param_group%master%s%t%t%product_data_cuda,& - param_group%master%s%t%t%c_locks_dev,& - error) - DO i = SIZE(param_group%stacks), 1, -1 - param_group%stacks(i)%s%driver = mm_driver - IF (param_group%stacks(i)%s%stack_p .EQ. 0) THEN - param_group%stacks(i)%s%state = dbcsr_ps_state_empty - IF (dbg) WRITE(*,*)routineN//" not adding empty stack" - ELSE - IF (dbg) WRITE(*,*)routineN//" adding stack len", param_group%stacks(i)%s%stack_p - IF (mm_thread_workshare .OR. mm_async) THEN - CALL dbcsr_pq_add_stack (queue, param_group%stacks(i), error=error) - ELSE - ! If no worksharing is active, just process the stack immediately. - param_group%stacks(i)%s%driver = mm_driver - CALL process_ps_stack (param_group%stacks(i)%s, error=error) - ENDIF - ENDIF - ENDDO - IF (careful_mod) & - CALL dbcsr_error_stop(error_handle, error) - END SUBROUTINE enqueue_ps_group - - -! ***************************************************************************** -!> \brief Processes stacks from my queue -!> -!> \param[in,out] queue My queue -!> \param[in] driver Driver to use for processing queue -!> \param[in,out] error error -!> \note The queue parameter could be INTENT(INOUT) when OpenMP is not used. -! ***************************************************************************** - SUBROUTINE process_queue_mine (queue, driver, error) - TYPE(dbcsr_pq_type), POINTER :: queue - INTEGER, INTENT(IN) :: driver - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - CHARACTER(len=*), PARAMETER :: routineN = 'process_queue_mine', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: careful = careful_mod, & - dbg = debug_mod - - INTEGER :: cnt, error_handle, max_handoff - LOGICAL :: easy, found - TYPE(dbcsr_ps_obj) :: stack - - IF (careful_mod) & - CALL dbcsr_error_set(routineN, error_handle, error) - easy = driver_is_async (driver) - cnt = 0 - IF (easy) THEN - max_handoff = queue%handoff - queue%nworking - ENDIF - DO - CALL dbcsr_pq_get_own_stack (queue, stack, found,& - easy = easy, error=error) - IF (dbg) THEN - !$omp master - WRITE(*,*)"Found my stack" - !$omp end master - ENDIF - IF (found) THEN - stack%s%driver = driver - CALL process_ps_stack(stack%s, error=error) - cnt = cnt + 1 - IF (easy .AND. cnt .GT. max_handoff) EXIT - ELSE - EXIT - ENDIF - ENDDO - ! - IF (careful_mod) & - CALL dbcsr_error_stop(error_handle, error) - END SUBROUTINE process_queue_mine - - -! ***************************************************************************** -!> \brief Processes stacks from other threads -!> -!> \param[in,out] queue My queue -!> \param[in] forever Processes until all other threads declare -!> they are done. -!> \param[in] driver Driver to use for processing queue -!> \param[in,out] error error -!> \note The queue parameter could be INTENT(INOUT) when OpenMP is not used. -! ***************************************************************************** - SUBROUTINE process_queue_others (queue, forever, driver, error) - TYPE(dbcsr_pq_type), POINTER :: queue - LOGICAL, INTENT(IN) :: forever - INTEGER, INTENT(IN) :: driver - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - CHARACTER(len=*), PARAMETER :: routineN = 'process_queue_others', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: careful = careful_mod, & - dbg = debug_mod - - INTEGER :: cnt, error_handle, nt, & - old_thread_ptr, t, thread_ptr - LOGICAL :: easy, found, keep_cycling - TYPE(dbcsr_ps_obj) :: stack - - IF (careful_mod) & - CALL dbcsr_error_set(routineN, error_handle, error) - ! - ! - nt = 1 - !$nt = omp_get_num_threads() - easy = driver_is_async (driver) - cnt = 1 - old_thread_ptr = 0 - thread_ptr = 1 - found = .TRUE. - keep_cycling = found .OR.& - (forever .AND. queue%all_queues%n_working .GT. 0) - DO WHILE (keep_cycling) - CALL dbcsr_pq_get_any_stack (queue, stack, found,& - easy = easy,& - anyways = easy,& - thread_ptr = thread_ptr, error=error) - IF (thread_ptr .NE. old_thread_ptr) cnt = 1 - old_thread_ptr = thread_ptr - IF (found) THEN - IF (dbg) THEN - !$omp master - WRITE(*,*)"Found other stack owned by", stack%s%t%t%owner - !$omp end master - ENDIF - stack%s%driver = driver - CALL process_ps_stack(stack%s, error=error) - cnt = cnt + 1 - t = 0 - !$ t = omp_get_thread_num () - t = MOD(thread_ptr + t, nt)+1 - IF (easy .AND.& - cnt .GT. queue%all_queues%queues(t)%pq%handoff& - - queue%all_queues%queues(t)%pq%nworking) THEN - thread_ptr = thread_ptr + 1 - WRITE(*,*)'new thread', thread_ptr - ENDIF - ENDIF - !$OMP FLUSH - keep_cycling = found .OR.& - (forever .AND. queue%all_queues%n_working .GT. 0) - ENDDO - ! - IF (careful_mod) & - CALL dbcsr_error_stop(error_handle, error) - END SUBROUTINE process_queue_others - - -! ***************************************************************************** -!> \brief Processes stacks while the accelerator processor is busy. -!> -!> Processing is not done if number of stacks being processed is less -!> than the queue's flush_level. -!> \see get_stack_or_process_queue -!> \see csr_multiply -!> \param[in,out] queue My queue -!> \param[in,out] param_sets Parameter group sets -!> \param[in] driver Driver to use for processing queue -!> \param[in,out] error error -!> \note The queue parameter could be INTENT(INOUT) when OpenMP is not used. -! ***************************************************************************** - SUBROUTINE process_queue_preempt (queue, param_set, driver, error) - TYPE(dbcsr_pq_type), POINTER :: queue - TYPE(dbcsr_ps_set_type), INTENT(INOUT) :: param_set - INTEGER, INTENT(IN) :: driver - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - CHARACTER(len=*), PARAMETER :: routineN = 'process_queue_preempt', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: careful = careful_mod, & - dbg = debug_mod - - INTEGER :: error_handle, iam, n - LOGICAL :: found - TYPE(dbcsr_ps_obj) :: stack - - IF (careful_mod) & - CALL dbcsr_error_set(routineN, error_handle, error) - ! - ! Fetch & process only if no one else is done (i.e., has spare - ! time to process my stacks). - found = .TRUE. - n = dbcsr_ps_set_get_n_working (param_set, error) - !$ if (.FALSE. .AND. dbg) & - !$ write(*,*)routineN, omp_get_thread_num(), n, queue%flush_level - DO WHILE (n .GT. queue%flush_level .AND. found) - CALL dbcsr_pq_get_far_stack (queue, stack, found, error=error) - IF (found) THEN - IF (dbg) THEN - iam = 0 - !$ iam = omp_get_thread_num () - WRITE(*,*)"Preempt: Found own stack", iam - ENDIF - stack%s%driver = driver - CALL process_ps_stack(stack%s, error=error) - ENDIF - IF (dbg) THEN - n = dbcsr_ps_set_get_n_working (param_set, error) - IF (n .EQ. 0) WRITE(*,*)"oops" - ENDIF - ENDDO - ! - IF (careful_mod) & - CALL dbcsr_error_stop(error_handle, error) - END SUBROUTINE process_queue_preempt - - -! ***************************************************************************** -!> \brief Gets a new stack group prepared for writing. -!> \par Dealing with busy stack groups. -!> The queue will be processed while the stack group is busy (it is -!> queued or in processing). -!> -!> If the stack_group is not immediately available the queue's -!> flush_level is lowered. It thus becomes more favorable to have the -!> host CPU process stacks. -!> \see process_queue_preempt -!> \see csr_multiply -!> \param[in,out] param_sets The parameter group sets -!> \param[in,out] queue My queue -!> \param[out] stack_group Retrieved stack group -!> \param[in] driver Driver to use for processing queue -!> \param[in,out] error error -!> \note The queue parameter could be INTENT(INOUT) when OpenMP is not used. -! ***************************************************************************** - SUBROUTINE get_stack_or_process_queue (param_sets, queue, stack_group,& - driver, error) - TYPE(dbcsr_ps_set_type), INTENT(INOUT) :: param_sets - TYPE(dbcsr_pq_type), POINTER :: queue - TYPE(dbcsr_ps_group_type), POINTER :: stack_group - INTEGER, INTENT(IN) :: driver - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - LOGICAL, PARAMETER :: dbg = debug_mod - - INTEGER :: cnt, n, stack_state - LOGICAL :: found - TYPE(dbcsr_ps_obj) :: stack - - stack_group => dbcsr_ps_set_get_group_p (param_sets, wait=.FALSE.,& - error=error) - IF (mm_thread_workshare) THEN - !$OMP FLUSH - ENDIF - ! If the parameter stack we get is still busy then - ! just do more crunching. - cnt = 1 - stack_state = dbcsr_psg_get_state (stack_group, error) - IF (stack_state .GE. dbcsr_ps_state_queued .AND. mm_async) THEN - ! The parameter stack is still busy. The others processors are - ! too slow so we lower the threshold for local computation. - ! - !$ if (dbg) write(*,*)"still in queue:", queue%nstacks, omp_get_thread_num() - n = dbcsr_ps_set_get_n_working (param_sets, error) - CALL dbcsr_pq_flush_level_chg (queue, -(n/4),& - param_sets) - CALL dbcsr_pq_handoff_level_chg (queue, -MAX((param_sets%group_size*3)/2,1),& - param_sets) - ENDIF - DO WHILE (stack_state .GE. dbcsr_ps_state_queued) - ! Just process the queue until the parameter stack is clear. - CALL dbcsr_pq_get_far_stack (queue, stack, found, error=error) - IF (found) THEN - stack%s%driver = driver - CALL process_ps_stack(stack%s, error=error) - ENDIF - IF (mm_thread_workshare) THEN - !$OMP FLUSH - ENDIF - cnt = cnt + 1 - stack_state = dbcsr_psg_get_state (stack_group, error) - ENDDO - END SUBROUTINE get_stack_or_process_queue - - -! ***************************************************************************** -!> \brief Prepares the target for stack processing. -!> \note Resizes data area, zeros new data, resets device locks, ... -! ***************************************************************************** - SUBROUTINE process_ps_target_low (target_desc,& - product_data_area,& - zero_first, zero_last, nblks, driver, card_data, c_locks_dev, error) - TYPE(dbcsr_ps_target_obj), INTENT(INOUT) :: target_desc - TYPE(dbcsr_data_obj), INTENT(INOUT) :: product_data_area - INTEGER, INTENT(INOUT) :: zero_first, zero_last - INTEGER, INTENT(IN) :: nblks, driver - TYPE(dbcsr_cuda_mem_type), POINTER :: card_data, c_locks_dev - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - CHARACTER(len=*), PARAMETER :: routineN = 'process_ps_target_low', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: careful = careful_mod, & - dbg = debug_mod, & - info = .FALSE. - REAL, PARAMETER :: resize_factor = 1.618034 - - INTEGER :: c_size, istat, maxs, tmp_i - LOGICAL :: stream_is_synced - -! --------------------------------------------------------------------------- -! -! Resize target data area if necessary. -! Here we want the actual allocation size. - - maxs = dbcsr_data_get_size(product_data_area) - IF (zero_last .GT. maxs) THEN - ! Resize the target data area if the stack references a target - ! matrix data element outside of its current range. When - ! appropriate a lock on the data area is taken. - IF (dbg) WRITE(*,*)"Target too small" - maxs = zero_last - IF (mm_thread_workshare) THEN - ! Lock the target and wait for others to unlock their - ! regions. - CALL dbcsr_ps_target_lock_main (target_desc%t,& - flush=.TRUE.,& - error=error) - ENDIF - IF (dbg) & - WRITE(*,*)routineN//" Resizing to", LOG(REAL(maxs))/LOG(10.0) - CALL dbcsr_data_ensure_size (product_data_area,& - maxs, factor=resize_factor, error=error) - IF (mm_thread_workshare) THEN - ! Potentially resize locks. The number of region locks is - ! adjusted to the allocated size of the new data area (to - ! prevent changing them whenever the last addressed block is - ! changed). - maxs = dbcsr_data_get_size(product_data_area) - CALL dbcsr_ps_target_new_regions (target_desc%t,& - maxs, error=error) - CALL dbcsr_ps_target_unlock_main (target_desc%t, error) - ENDIF - ENDIF - IF (dbg) WRITE(*,*)"Setting referenced size" - CALL dbcsr_data_set_size_referenced (product_data_area, zero_last) - IF (dbg) WRITE(*,*)"Done" - ! - ! Zero new blocks - IF (zero_last .GE. zero_first) THEN - IF (dbg) WRITE(*,*)"Zeroing" - CALL dbcsr_data_clear (product_data_area, lb=zero_first, ub=zero_last) - IF (dbg) WRITE(*,*)"Done" - ENDIF - ! - ! Cuda on-device resizing - cuda_process_target: IF (driver .EQ. mm_driver_cuda) THEN - stream_is_synced = .FALSE. - IF (dbg) WRITE(*,*)"Getting allocated size..." - !$ IF (dbg) WRITE(*,*)"thread, target", omp_get_thread_num(),& - !$ target_desc%t%owner - c_size = dbcsr_cuda_dev_mem_get_alloc(card_data) - IF (dbg) WRITE(*,*)"done", c_size, "vs", zero_last - ! Resize & zero product data if too big. - IF (zero_last .GT. c_size) THEN - ! - ! All kernels in the stream must be finished before - ! reallocation is performed. - CALL dbcsr_cuda_stream_sync (target_desc%t%owner+1, error=error) - stream_is_synced = .TRUE. - IF (dbg .OR. info) WRITE(*,*)routineN//" reallocating c_dev",& - c_size, zero_last - tmp_i = MAX(zero_last, INT(REAL(zero_last)*resize_factor) ) - IF (verbose_acc) WRITE(*,*)routineN//" reallocating c_dev",& - tmp_i, c_size - !--- !$OMP CRITICAL (crit_cuda) - !$ IF (mm_thread_workshare) CALL OMP_SET_LOCK (accel_lock) - CALL dbcsr_cuda_dev_mem_realloc (card_data, tmp_i, stat=istat) - IF (istat /= 0) THEN - ! If the resize, including pre-oversizing failed, try to - ! resize it to the actual number of locks used. - IF (verbose_acc) WRITE(*,*)routineN//" Running out of memory" - CALL dbcsr_cuda_dev_mem_realloc (card_data, zero_last, stat=istat) - ENDIF - c_size = dbcsr_cuda_dev_mem_get_alloc(card_data) - IF (dbg) WRITE(*,*)routineN//" zeroing c_dev" - CALL dbcsr_cuda_dev_mem_zero(card_data,& - first=zero_first, last=c_size, error=error) - !$ IF (mm_thread_workshare) CALL OMP_UNSET_LOCK (accel_lock) - !--- !$OMP END CRITICAL (crit_cuda) - ELSE IF (dbg) THEN - WRITE(*,*)"not reallocating c_dev" - ENDIF - ! - ! Resize locks, which are equal to the new block count. - IF (dbg) WRITE(*,*)routineN//" lock size..." - IF (dbg) WRITE(*,*)routineN, dbcsr_cuda_dev_mem_get_alloc(c_locks_dev) - IF (nblks .GT. dbcsr_cuda_dev_mem_get_alloc(c_locks_dev)) THEN - ! - ! All kernels in the stream must be finished before - ! reallocation is performed. - IF (.NOT. stream_is_synced) THEN - CALL dbcsr_cuda_stream_sync (target_desc%t%owner+1, error=error) - ENDIF - stream_is_synced = .TRUE. - IF (dbg) WRITE(*,*)routineN//" reallocing locks" - maxs = dbcsr_cuda_dev_mem_get_alloc(c_locks_dev) - IF (dbg) WRITE(*,*)routineN//" lock size", maxs - IF (dbg) WRITE(*,*)routineN//" reallocing locks" - IF (verbose_acc .OR. info) WRITE(*,*)routineN//" reallocating locks", maxs - IF (dbg) WRITE(*,*)routineN//" deallocating..." - !--- !$OMP CRITICAL (crit_cuda) - !$ IF (mm_thread_workshare) CALL OMP_SET_LOCK (accel_lock) - CALL dbcsr_cuda_dev_mem_dealloc(c_locks_dev, error=error) - tmp_i = INT(REAL(nblks*4,kind=dp)*default_resize_factor) - !WRITE(*,*)routineN//" reallocating locks", tmp_i, maxs - IF (dbg) WRITE(*,*)routineN//" allocating..." - CALL dbcsr_cuda_dev_mem_alloc(c_locks_dev, tmp_i, stat=istat) - IF (istat /= 0) THEN - IF (verbose_acc) WRITE(*,*)routineN//" Trying smaller allocation" - tmp_i = nblks - IF (dbg) WRITE(*,*)routineN//" failed, trying smaller..." - CALL dbcsr_cuda_dev_mem_alloc(c_locks_dev, tmp_i, error=error) - ENDIF - IF (dbg) WRITE(*,*)routineN//" zeroing..." - CALL dbcsr_cuda_dev_mem_zero(c_locks_dev,& - first=1, last=dbcsr_cuda_dev_mem_get_alloc(c_locks_dev),& - error=error) - !$ IF (mm_thread_workshare) CALL OMP_UNSET_LOCK (accel_lock) - !--- !$OMP END CRITICAL (crit_cuda) - !write(*,*)routineN//" done zeroing" - ENDIF - ENDIF cuda_process_target - IF (dbg) WRITE(*,*)routineN//" done" - zero_first = zero_last + 1 - END SUBROUTINE process_ps_target_low - - -! ***************************************************************************** -!> \brief Unpacks stack variables to call lower-level stack processing -!> drivers. -!***************************************************************************** - SUBROUTINE process_ps_stack(param_stack, error) - TYPE(dbcsr_ps_type), INTENT(INOUT) :: param_stack - TYPE(dbcsr_error_type), INTENT(INOUT) :: error - - CHARACTER(len=*), PARAMETER :: routineN = 'process_ps_stack', & - routineP = moduleN//':'//routineN - LOGICAL, PARAMETER :: careful = careful_mod - - INTEGER :: error_handle, stack_size - - IF (careful_mod) & - CALL dbcsr_error_set(routineN, error_handle, error) - IF (careful_mod) THEN - IF (param_stack%driver .EQ. mm_driver_cuda) THEN - CALL dbcsr_assert (param_stack%has_cuda_ab_data,& - dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& - "A or B matrix data not present in stack.",& - __LINE__, error=error) - ELSE - CALL dbcsr_assert (param_stack%has_ab_data,& - dbcsr_fatal_level, dbcsr_wrong_args_error, routineN,& - "A or B matrix data not present in stack.",& - __LINE__, error=error) - ENDIF - ENDIF - !if (dbg) & - ! write(*,*)routineN, OMP_GET_THREAD_NUM(), param_stack%stack_p,& - ! param_stack%id, param_stack%sid, param_stack%t%t%owner - !$ IF (.FALSE.) & - !$ WRITE(*,*)"process_ps_stack stack size is", param_stack%stack_p,& - !$ omp_get_thread_num(), param_stack%t%t%owner, param_stack%driver,& - !$ param_stack%sid, param_stack%id - ! This has to be reset before the stack may be marked as empty. - stack_size = param_stack%stack_p - param_stack%stack_p = 0 - CALL process_mm_stack(param_stack%parameters,& - param_stack%driver,& - stack_size,& - param_stack%left_data_area, param_stack%right_data_area,& - param_stack%t%t%product_data_area,& - param_stack%t%t%product_data_cuda, param_stack%t%t%has_cuda_c_data,& - param_stack%left_data_cuda, param_stack%right_data_cuda,& - param_stack%state, param_stack%t%t%stack_state_dev,& - param_stack%m, param_stack%n, param_stack%k,& - param_stack%max_m, param_stack%max_n, param_stack%max_k,& - param_stack%defined_mnk,& - param_stack%t%t%c_locks_dev, param_stack%t%t%params_dev,& - param_stack%t%t, & - error=error) - IF (careful_mod) & - CALL dbcsr_error_stop(error_handle, error) - END SUBROUTINE process_ps_stack - ! ***************************************************************************** !> \brief Calls the various drivers that process the stack. @@ -632,15 +78,11 @@ CONTAINS !> \param[in] lastblk Number of blocks in product !> \param[in,out] product_data_area Data for results ! ***************************************************************************** - SUBROUTINE process_mm_stack(params, driver,& + SUBROUTINE process_mm_stack_cpu(params, driver,& stack_size, & left_data_area, right_data_area, product_data_area,& - product_data_card, has_product_data_card,& - a_dev, b_dev,& - state, stack_state_dev,& - m, n, k, max_m, max_n, max_k, defined_mnk,& - c_locks_dev, params_dev, & - target_desc, & + state, m, n, k, max_m, max_n, max_k, defined_mnk,& + stack_id,& error) INTEGER, INTENT(IN) :: stack_size, driver INTEGER, DIMENSION(1:dbcsr_ps_width, & @@ -648,30 +90,21 @@ CONTAINS TYPE(dbcsr_data_obj), INTENT(IN) :: left_data_area, & right_data_area TYPE(dbcsr_data_obj), INTENT(INOUT) :: product_data_area - TYPE(dbcsr_cuda_mem_type), POINTER :: product_data_card - LOGICAL, INTENT(IN) :: has_product_data_card - TYPE(dbcsr_cuda_mem_type), POINTER :: a_dev, b_dev INTEGER, POINTER :: state - TYPE(dbcsr_cuda_mem_type), POINTER :: stack_state_dev INTEGER, INTENT(IN) :: m, n, k, max_m, max_n, max_k LOGICAL, INTENT(IN) :: defined_mnk - TYPE(dbcsr_cuda_mem_type), POINTER :: c_locks_dev, params_dev - TYPE(dbcsr_ps_target_type), POINTER :: target_desc + INTEGER, INTENT(IN) :: stack_id TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'process_mm_stack', & + CHARACTER(len=*), PARAMETER :: routineN = 'process_mm_stack_cpu', & routineP = moduleN//':'//routineN LOGICAL, PARAMETER :: careful = careful_mod, & dbg = .FALSE. REAL, PARAMETER :: resize_factor = 1.618034 - INTEGER :: nregions, sp - LOGICAL, DIMENSION(max_regions) :: which_locks + INTEGER :: sp REAL(KIND=dp) :: rnd -!stack_size), INTENT(IN) :: params -! --------------------------------------------------------------------------- - state = dbcsr_ps_state_working IF (dbg) THEN CALL RANDOM_NUMBER (rnd) @@ -680,7 +113,7 @@ CONTAINS CALL print_gemm_parameters(params(:,1:stack_size)) ENDIF ENDIF - ! + ! Verify stack consistency. Only the upper bound is verified. IF (careful) THEN DO sp = 1, stack_size @@ -701,21 +134,7 @@ CONTAINS "C data out of bounds.", __LINE__, error=error) ENDDO ENDIF - ! - ! Locks the target (data) area if there could be an access - ! conflict there. - ! - !$ IF (mm_thread_workshare .AND. .NOT. driver_is_async (driver)) THEN - !$ CALL dbcsr_ps_target_lock_regions (target_desc,& - !$ stack_size, params,& - !$ target_desc%bit_shift,& - !$ which_locks, nregions,& - !$ error=error) - !$ ENDIF - IF (mm_thread_workshare) THEN - !$OMP FLUSH - ENDIF - + SELECT CASE (driver) CASE (mm_driver_matmul) SELECT CASE (product_data_area%d%data_type) @@ -821,43 +240,15 @@ CONTAINS CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& routineN, "Invalid data type",__LINE__,error) END SELECT - CASE (mm_driver_cuda) - IF (.NOT. has_product_data_card) & - CALL dbcsr_assert (.FALSE.,& - dbcsr_fatal_level, dbcsr_internal_error, routineN,& - "No C data on card is specified.",& - __LINE__, error=error) - CALL cuda_process_mm_stack (params,& - stack_size,& - a_dev, b_dev, product_data_card,& - c_locks_dev,& - params_dev,& - m, n, k, max_m, max_n, max_k, defined_mnk,& - state, stack_state_dev,& - target_desc%owner,& - error=error) CASE default CALL dbcsr_assert (.FALSE., dbcsr_fatal_level, dbcsr_caller_error,& routineN, "Invalid multiplication driver",__LINE__,error) END SELECT - ! - ! These writes have to be ordered. Specifically the state should not - ! be set before the stack has been used and the results written. - IF (mm_thread_workshare) THEN - !$OMP FLUSH - ENDIF + IF (.NOT. driver_is_async (driver)) THEN state = dbcsr_ps_state_empty ENDIF - IF (mm_thread_workshare) THEN - !$OMP FLUSH - ENDIF - !$ IF (mm_thread_workshare .AND. .NOT. driver_is_async (driver)) THEN - !$ CALL dbcsr_ps_target_unlock_regions (target_desc,& - !$ which_locks, nregions,& - !$ error=error) - !$ ENDIF - END SUBROUTINE process_mm_stack + END SUBROUTINE process_mm_stack_cpu ! ***************************************************************************** @@ -870,13 +261,14 @@ CONTAINS !> \param[in,out] c_data Product data !> \param[in,out] error error ! ***************************************************************************** - SUBROUTINE cuda_process_mm_stack(params,& + SUBROUTINE process_mm_stack_cuda(params,& stack_size,& data_a_dev, data_b_dev, data_c_dev,& c_locks,& params_dev,& m, n, k, max_m, max_n, max_k, defined_mnk,& - state, stack_state_dev, owner, & + state, stack_state_dev,& + stack_id,& error) INTEGER, INTENT(IN) :: stack_size INTEGER, & @@ -889,46 +281,45 @@ CONTAINS LOGICAL, INTENT(IN) :: defined_mnk INTEGER, POINTER :: state TYPE(dbcsr_cuda_mem_type), INTENT(IN) :: stack_state_dev - INTEGER, INTENT(IN) :: owner + INTEGER, INTENT(IN) :: stack_id TYPE(dbcsr_error_type), INTENT(INOUT) :: error - CHARACTER(len=*), PARAMETER :: routineN = 'cuda_process_mm_stack', & + CHARACTER(len=*), PARAMETER :: routineN = 'process_mm_stack_cuda', & routineP = moduleN//':'//routineN INTEGER, PARAMETER :: flops_to_sort = 2*13*13*13 INTEGER :: error_handle, error_handle2, & - i, k_max, m_max, n_max, stream + i, ithread, k_max, m_max, & + n_max, nthreads, stream INTEGER, DIMENSION(:), POINTER :: params_p INTEGER, DIMENSION(stack_size) :: c_sort, c_sort_ind INTEGER, & DIMENSION(dbcsr_ps_width, stack_size) :: params_sort, params_tmp -! sort for matrices 13x13 and larger, this parameter needs tuning -! --------------------------------------------------------------------------- + nthreads = 1; ithread = 0 + !$ nthreads = OMP_GET_NUM_THREADS () ; ithread = OMP_GET_THREAD_NUM () IF (stack_size .EQ. 0) THEN - !$OMP FLUSH state = dbcsr_ps_state_empty - !$OMP FLUSH WRITE(*,*)routineN//" Stack size is 0" - !$ write(*,*)"from thread", omp_get_thread_num() RETURN ENDIF - stream = owner+1 - !$ IF (.FALSE.) & - !$ WRITE(*,*)routineN//" Stack size is", stack_size, omp_get_thread_num() - ! IF (careful_mod) & - CALL dbcsr_error_set (routineN, error_handle, error) - + + ! ithread is 0-based, stack_id is 1-based, stream should be 1-based + stream = ithread + nthreads*(stack_id-1) + 1 + CALL dbcsr_error_set (routineN, error_handle, error) + params_p => params IF (m .GT. 0) THEN ; m_max = m ; ELSE ; m_max = -max_m ; ENDIF IF (n .GT. 0) THEN ; n_max = n ; ELSE ; n_max = -max_n ; ENDIF IF (k .GT. 0) THEN ; k_max = k ; ELSE ; k_max = -max_k ; ENDIF - !======================================== + + !=========================================================================== ! sort the stack. Since this costs CPU time, only a good idea if the CPUs ! are not too busy, or GPU gain is very large CALL dbcsr_error_set (routineN//"_sort", error_handle2, error) - IF (2*m*n*k>=flops_to_sort .AND. stack_size .GT. 1) THEN + !TODO: now we are allways sorting + !IF (2*m*n*k>=flops_to_sort .AND. stack_size .GT. 1) THEN params_tmp = RESHAPE(params, (/dbcsr_ps_width, stack_size/)) ! sort by the C-blocks c_sort = params_tmp(6,:) @@ -937,34 +328,31 @@ CONTAINS params_sort(:, i)=params_tmp(:, c_sort_ind(i)) END DO params = RESHAPE(params_sort, (/dbcsr_ps_width*stack_size/)) - ENDIF + !ENDIF CALL dbcsr_error_stop (error_handle2, error) - !======================================== + !=========================================================================== + + CALL dbcsr_cuda_cp_host_to_dev (params_p,& params_dev%d_i, dbcsr_ps_width*stack_size,& async=.TRUE., stream=stream,& error=error) - + ! Schedule the resetting of the state of this stack as soon as the ! parameter upload finishes. N.B. This must be the last change to ! the stack: its stack_p must be set to 0 and its data must be ! used before the state is set to dbcsr_ps_state_empty. CALL dbcsr_cuda_cp_dev_to_host (stack_state_dev%d_i, state,& async=.TRUE., stream=stream, error=error) - - !--- !$OMP CRITICAL (crit_cuda) - !$ IF (mm_thread_workshare) CALL OMP_SET_LOCK (accel_lock) + + !TODO: dbcsr_ps_width is a constant, shouldn't need to pass it as argument CALL dbcsr_cuda_do_mm_stack (params_dev%d_i, stack_size, dbcsr_ps_width,& data_a_dev, data_b_dev, data_c_dev,& c_locks%d_i, ABS(m_max), ABS(n_max), ABS(k_max), defined_mnk,& stream=stream, error=error) - !$ IF (mm_thread_workshare) CALL OMP_UNSET_LOCK (accel_lock) - !--- !$OMP END CRITICAL (crit_cuda) - IF (.FALSE.) CALL dbcsr_cuda_device_sync (error=error) -! IF (careful_mod) & - CALL dbcsr_error_stop (error_handle, error) - END SUBROUTINE cuda_process_mm_stack + CALL dbcsr_error_stop (error_handle, error) + END SUBROUTINE process_mm_stack_cuda diff --git a/src/dbcsr_lib/dbcsr_mm_types.F b/src/dbcsr_lib/dbcsr_mm_types.F index dd2e1c3849..10169b9845 100644 --- a/src/dbcsr_lib/dbcsr_mm_types.F +++ b/src/dbcsr_lib/dbcsr_mm_types.F @@ -18,9 +18,8 @@ MODULE dbcsr_mm_types int_8,& real_8,& sp - USE dbcsr_pq_types, ONLY: dbcsr_pq_type,& - dbcsr_ps_set_type - USE dbcsr_types, ONLY: dbcsr_work_type + USE dbcsr_types, ONLY: dbcsr_data_obj,& + dbcsr_work_type IMPLICIT NONE @@ -28,7 +27,23 @@ MODULE dbcsr_mm_types CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_mm_types' - PUBLIC :: carrier_type, hash_table_type, ele_type + PUBLIC :: multrec_carrier_type, csr_carrier_type + PUBLIC :: driver_carrier_type, stack_descriptor_type + PUBLIC :: hash_table_type, ele_type + + INTEGER, PARAMETER, PUBLIC :: dbcsr_ps_state_empty = 42424242 + INTEGER, PARAMETER, PUBLIC :: dbcsr_ps_state_working = 1234567890 + + ! Definitions for the members of a parameter stack. + INTEGER, PARAMETER, PUBLIC :: dbcsr_ps_width = 7 + INTEGER, PARAMETER, PUBLIC :: p_m = 1 + INTEGER, PARAMETER, PUBLIC :: p_n = 2 + INTEGER, PARAMETER, PUBLIC :: p_k = 3 + INTEGER, PARAMETER, PUBLIC :: p_a_first = 4 + INTEGER, PARAMETER, PUBLIC :: p_b_first = 5 + INTEGER, PARAMETER, PUBLIC :: p_c_first = 6 + INTEGER, PARAMETER, PUBLIC :: p_c_blk = 7 + ! ***************************************************************************** !> \brief Types needed for the hashtable. @@ -37,7 +52,7 @@ MODULE dbcsr_mm_types INTEGER :: c=0 INTEGER :: p=0 END TYPE ele_type - + TYPE hash_table_type TYPE(ele_type), DIMENSION(:), POINTER :: table INTEGER :: nele=0 @@ -45,15 +60,58 @@ MODULE dbcsr_mm_types INTEGER :: prime=0 END TYPE hash_table_type - + +! ***************************************************************************** +!> +! ***************************************************************************** + TYPE stack_descriptor_type + INTEGER :: m, n, k, max_m ,max_n, max_k + INTEGER :: total_entries + LOGICAL :: defined_mnk + END TYPE stack_descriptor_type + + +! ***************************************************************************** +!> +! ***************************************************************************** + TYPE driver_carrier_type + ! for cpu based drivers + TYPE(dbcsr_data_obj) :: left_data_area, right_data_area + TYPE(dbcsr_work_type), POINTER :: product_wm + ! for the cuda driver + END TYPE driver_carrier_type + + +! ***************************************************************************** +!> +! ***************************************************************************** + TYPE csr_carrier_type + TYPE(hash_table_type), DIMENSION(:), POINTER :: c_hashes + INTEGER :: nm_stacks, nn_stacks, nk_stacks + INTEGER(KIND=int_4), DIMENSION(:), POINTER :: m_size_maps,& + n_size_maps,& + k_size_maps + INTEGER :: max_m, max_n, max_k + INTEGER :: m_size_maps_size,& + n_size_maps_size,& + k_size_maps_size + + INTEGER(KIND=int_1), DIMENSION(:,:,:), POINTER :: stack_map + + INTEGER, DIMENSION(:,:,:,:), POINTER :: stackgrid_data + INTEGER, DIMENSION(:,:), POINTER :: stackgrid_fillcount + INTEGER, DIMENSION(:,:), POINTER :: stackgrid_state + TYPE(stack_descriptor_type), DIMENSION(:), POINTER :: stackrow_descr + TYPE(driver_carrier_type) :: drv_carrier + END TYPE csr_carrier_type + + ! ***************************************************************************** !> \brief Used to carry data among the various calls. Each thread has !> its own private copy. -!> \var id Unique ID of each carrier_type instance !> \var c_has_symmetry The product matrix has symmetry !> \var keep_sparsity Sparsity of C matrix should be kept !> \var use_eps Use on-the-fly filtering -!> \var param_sets Set of parameter stacks !> \var local_indexing The A and B matrix indices and C matrix work indices !> are not global but local to process rows and columns !> \var m_sizes Block sizes of A and C matrix rows, indexed locally @@ -92,7 +150,6 @@ MODULE dbcsr_mm_types !> \var nk_stacks The number of most common k blocks sizes. !> \var stack_map Map from most common (n,k,m) block sizes to a stack !> number within a stack group. -!> \var default_stack Stack to use when stack members do not have common !> m, n, and k sizes. !> \var row_max_epss Maximum eps to be used for one row. !> \var a_norms Norms of A matrix blocks. @@ -105,38 +162,18 @@ MODULE dbcsr_mm_types !> \var original_lastblk Number of work matrix blocks before addition !> \var flop flop count ! ***************************************************************************** - TYPE carrier_type - INTEGER :: id + TYPE multrec_carrier_type LOGICAL :: c_has_symmetry, keep_sparsity, use_eps LOGICAL :: local_indexing - TYPE(hash_table_type), DIMENSION(:), POINTER :: c_hashes - TYPE(dbcsr_pq_type), POINTER :: queue - TYPE(dbcsr_ps_set_type) :: param_sets INTEGER, DIMENSION(:), POINTER :: m_sizes, n_sizes, k_sizes INTEGER, DIMENSION(:), POINTER :: c_local_rows, c_local_cols, k_locals,& c_global_rows, c_global_cols - INTEGER :: max_m, max_n, max_k - INTEGER(KIND=int_4), DIMENSION(:), POINTER :: m_size_maps,& - n_size_maps,& - k_size_maps - INTEGER :: m_size_maps_size,& - n_size_maps_size,& - k_size_maps_size - INTEGER :: nm_stacks, nn_stacks, nk_stacks - INTEGER(KIND=int_1), DIMENSION(:,:,:), POINTER :: stack_map - INTEGER :: default_stack + REAL(KIND=sp), DIMENSION(:), POINTER :: row_max_epss, a_norms, b_norms REAL(KIND=real_8) :: eps - TYPE(dbcsr_work_type) :: my_wm - INTEGER :: lastblk, datasize INTEGER :: original_lastblk INTEGER(kind=int_8) :: flop - INTEGER, DIMENSION(:,:), POINTER :: right_data_sr, right_data_rr,& - left_data_sr, left_data_rr,& - right_index_sr, right_index_rr,& - left_index_sr, left_index_rr - END TYPE carrier_type + TYPE(csr_carrier_type) :: csr_carrier + END TYPE multrec_carrier_type - - END MODULE dbcsr_mm_types diff --git a/src/dbcsr_lib/dbcsr_operations.F b/src/dbcsr_lib/dbcsr_operations.F index 39e2096004..39d93f6131 100644 --- a/src/dbcsr_lib/dbcsr_operations.F +++ b/src/dbcsr_lib/dbcsr_operations.F @@ -35,16 +35,11 @@ MODULE dbcsr_operations dbcsr_data_clear,& get_block2d_diagonal,& set_block2d_diagonal - USE dbcsr_config, ONLY: & - dbcsr_get_conf_mm_stacksize, dbcsr_get_conf_nstacks, dbcsr_init_conf, & - has_cuda, is_configured, mm_async, mm_driver, mm_driver_cuda, & - mm_driver_plasma - USE dbcsr_cuda_device, ONLY: dbcsr_cuda_get_n_devices,& - dbcsr_cuda_init - USE dbcsr_cuda_memory, ONLY: dbcsr_cuda_dev_mem_alloc,& - dbcsr_cuda_dev_mem_dealloc - USE dbcsr_cuda_methods, ONLY: dbcsr_cuda_dev_mem_setup - USE dbcsr_cuda_types, ONLY: dbcsr_cuda_mem_type + USE dbcsr_config, ONLY: dbcsr_init_conf,& + is_configured,& + mm_async,& + mm_driver,& + mm_driver_plasma USE dbcsr_data_methods, ONLY: & dbcsr_data_clear_pointer, dbcsr_data_ensure_size, dbcsr_data_get_size, & dbcsr_data_get_type, dbcsr_data_init, dbcsr_data_new, & @@ -80,7 +75,6 @@ MODULE dbcsr_operations USE dbcsr_message_passing, ONLY: dmp_max,& mp_allgather,& mp_bcast,& - mp_environ,& mp_recv,& mp_send,& mp_sum @@ -105,13 +99,13 @@ MODULE dbcsr_operations dbcsr_nblkrows_total, dbcsr_nfullcols_total, dbcsr_nfullrows_total, & dbcsr_release, dbcsr_release_locals, dbcsr_row_block_offsets, & dbcsr_row_block_sizes, dbcsr_switch_data_area, dbcsr_valid_index - USE dbcsr_mm_cannon, ONLY: dbcsr_mult_m_e_e + USE dbcsr_mm_cannon, ONLY: dbcsr_mm_cannon_lib_finalize,& + dbcsr_mm_cannon_lib_init,& + dbcsr_mm_cannon_multiply USE dbcsr_mp_operations, ONLY: dbcsr_recv_any,& dbcsr_send_any USE dbcsr_plasma_interface, ONLY: dbcsr_plasma_finalize,& dbcsr_plasma_init - USE dbcsr_pq_methods, ONLY: dbcsr_ps_set_finalize,& - dbcsr_ps_set_init USE dbcsr_ptr_util, ONLY: ensure_array_size,& pointer_view USE dbcsr_toollib, ONLY: ceil_log2,& @@ -126,15 +120,14 @@ MODULE dbcsr_operations USE dbcsr_types, ONLY: & dbcsr_2d_array_type, dbcsr_conjugate_transpose, dbcsr_data_obj, & dbcsr_distribution_obj, dbcsr_filter_frobenius, & - dbcsr_imagedistribution_obj, dbcsr_iterator, & - dbcsr_memory_CUDA_host_pinned, dbcsr_memory_MPI, dbcsr_memory_default, & - dbcsr_mp_obj, dbcsr_no_transpose, dbcsr_norm_column, & - dbcsr_norm_frobenius, dbcsr_norm_gershgorin, dbcsr_norm_maxabsnorm, & - dbcsr_obj, dbcsr_repl_col, dbcsr_repl_full, dbcsr_repl_none, & - dbcsr_repl_row, dbcsr_scalar_type, dbcsr_transpose, dbcsr_type, & - dbcsr_type_antisymmetric, dbcsr_type_complex_4, dbcsr_type_complex_8, & - dbcsr_type_no_symmetry, dbcsr_type_real_4, dbcsr_type_real_8, & - dbcsr_type_symmetric + dbcsr_imagedistribution_obj, dbcsr_iterator, dbcsr_memory_MPI, & + dbcsr_memory_default, dbcsr_mp_obj, dbcsr_no_transpose, & + dbcsr_norm_column, dbcsr_norm_frobenius, dbcsr_norm_gershgorin, & + dbcsr_norm_maxabsnorm, dbcsr_obj, dbcsr_repl_col, dbcsr_repl_full, & + dbcsr_repl_none, dbcsr_repl_row, dbcsr_scalar_type, dbcsr_transpose, & + dbcsr_type, dbcsr_type_antisymmetric, dbcsr_type_complex_4, & + dbcsr_type_complex_8, dbcsr_type_no_symmetry, dbcsr_type_real_4, & + dbcsr_type_real_8, dbcsr_type_symmetric USE dbcsr_util, ONLY: dbcsr_checksum,& dbcsr_verify_matrix,& find_block_of_element @@ -142,8 +135,6 @@ MODULE dbcsr_operations dbcsr_create,& dbcsr_finalize,& dbcsr_work_create - USE ma_affinity, ONLY: ma_set_gpu_affinity - USE machine_architecture_types, ONLY: has_ma !$ USE OMP_LIB @@ -158,7 +149,7 @@ MODULE dbcsr_operations PUBLIC :: dbcsr_init_lib, dbcsr_finalize_lib PUBLIC :: dbcsr_multiply,& - dbcsr_mult_m_e_e, dbcsr_trace, dbcsr_add_on_diag,& + dbcsr_trace, dbcsr_add_on_diag,& dbcsr_set, dbcsr_scale, dbcsr_scale_mat, dbcsr_add, dbcsr_copy,& dbcsr_copy_submatrix, dbcsr_copy_into_existing,& dbcsr_get_diag, dbcsr_set_diag, & @@ -378,7 +369,6 @@ CONTAINS old_product_col_blk_sizes, old_product_row_blk_offsets, & old_product_row_blk_sizes TYPE(dbcsr_2d_array_type), POINTER :: m2s_left, m2s_right - TYPE(dbcsr_cuda_mem_type) :: a_tmp TYPE(dbcsr_distribution_obj) :: dense_product_distribution, & old_product_distribution TYPE(dbcsr_imagedistribution_obj) :: dense_rdist_left, & @@ -388,19 +378,6 @@ CONTAINS matrix_left, matrix_right, matrix_tmp, product_matrix TYPE(dbcsr_scalar_type) :: eps_any -! --------------------------------------------------------------------------- -! Pre-init card for nicer time acconting. - - IF (has_cuda) THEN - IF(mm_driver .NE. mm_driver_cuda) CALL dbcsr_ps_set_finalize(error=error) - ENDIF - - IF (mm_driver .EQ. mm_driver_cuda) THEN - CALL dbcsr_cuda_dev_mem_setup (a_tmp, dbcsr_type_real_8) - CALL dbcsr_cuda_dev_mem_alloc(a_tmp, 1, error=error) - CALL dbcsr_cuda_dev_mem_dealloc(a_tmp, error=error) - ENDIF - ! CALL dbcsr_error_set(routineN, error_handler, error) ! ! check parameters @@ -963,7 +940,7 @@ CONTAINS CALL dbcsr_access_flush (product_matrix, error=error) ! my_flop = 0 - CALL dbcsr_mult_m_e_e (m2s_left, m2s_right, product_matrix,& + CALL dbcsr_mm_cannon_multiply(m2s_left, m2s_right, product_matrix,& retain_sparsity=retain_sparsity,& filter_eps=filter_eps, error=error,& flop=my_flop) @@ -4478,12 +4455,12 @@ CONTAINS CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_init_lib', & routineP = moduleN//':'//routineN - INTEGER :: error_handle, group_size, mem_type, mynode, n_stack_buffers, & - n_stack_mem_regions, ngpus, nstacks, numnode, stack_size - INTEGER, DIMENSION(3) :: nxstacks - TYPE(dbcsr_error_type) :: t_error + INTEGER :: error_handle +!n_stack_buffers,mem_type, n_stack_mem_regions, stack_size, nstacks,& +!INTEGER, DIMENSION(3) :: nxstacks ! --------------------------------------------------------------------------- +!TODO: problem: init/finalize are called by cp2k_runs AND f77_interface IF (is_configured) RETURN CALL dbcsr_error_set(routineN, error_handle, error) @@ -4504,45 +4481,13 @@ CONTAINS dbcsr_fatal_level, dbcsr_internal_error, routineN,& "Incorrect assumption of a 64-bit integer size!",& __LINE__, error=error) - ! + CALL dbcsr_init_conf (error) - ! - CALL mp_environ (numnode, mynode, group) -#if defined (__DBCSR_CUDA) - IF (has_cuda) THEN - ngpus = dbcsr_cuda_get_n_devices (error) - mem_type = dbcsr_memory_CUDA_host_pinned - CALL dbcsr_get_conf_nstacks (nxstacks, n_stack_buffers, n_stack_mem_regions,& - error) + !$omp parallel default(none) shared(error) + CALL dbcsr_mm_cannon_lib_init(error) + !$omp end parallel - nstacks = nxstacks(1) * nxstacks(2) * nxstacks(3) + 1 - stack_size = dbcsr_get_conf_mm_stacksize()*n_stack_buffers*nstacks - group_size = n_stack_buffers*nstacks - - - !$OMP PARALLEL default (none), & - !$OMP private (t_error) & - !$OMP shared (mynode, ngpus, error, & - !$OMP group_size, n_stack_mem_regions,stack_size) - - ! use a critical section to allow for threads initializing static - ! variables without races - !$OMP CRITICAL - t_error = error - IF (has_ma) THEN - CALL dbcsr_cuda_init (card_num=ma_set_gpu_affinity(mynode), error=error) - ELSE - CALL dbcsr_cuda_init (card_num=MOD(mynode, ngpus), error=error) - ENDIF - !$OMP END CRITICAL - - !allocate host memory - CALL dbcsr_ps_set_init(group_size, n_stack_mem_regions,stack_size,error=error) - !$OMP END PARALLEL - ENDIF -#endif - ! is_configured = .TRUE. CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dbcsr_init_lib @@ -4562,12 +4507,20 @@ CONTAINS INTEGER :: error_handle - CALL dbcsr_ps_set_finalize(error=error) +!TODO: problem: init/finalize are called by cp2k_runs AND f77_interface + + IF (.NOT. is_configured) RETURN CALL dbcsr_error_set(routineN, error_handle, error) + + !$omp parallel default(none) shared(error) + CALL dbcsr_mm_cannon_lib_finalize(error) + !$omp end parallel + + is_configured = .FALSE. CALL dbcsr_error_stop (error_handle, error) END SUBROUTINE dbcsr_finalize_lib - + ! ***************************************************************************** !> \brief Adds blocks to a matrix diff --git a/src/dbcsr_lib/dbcsr_ptr_util.F b/src/dbcsr_lib/dbcsr_ptr_util.F index 8ef6f25486..7cc0eb6b92 100644 --- a/src/dbcsr_lib/dbcsr_ptr_util.F +++ b/src/dbcsr_lib/dbcsr_ptr_util.F @@ -302,7 +302,7 @@ CONTAINS CASE (dbcsr_memory_MPI) CALL mp_allocate(mem, n, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_alloc(mem, n, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& @@ -344,7 +344,7 @@ CONTAINS CASE (dbcsr_memory_MPI) CALL mp_deallocate(mem, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_dealloc(mem, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& diff --git a/src/dbcsr_lib/dbcsr_ptr_util__nametype1_.template b/src/dbcsr_lib/dbcsr_ptr_util__nametype1_.template index 4a02557c8d..0c5f9aa475 100644 --- a/src/dbcsr_lib/dbcsr_ptr_util__nametype1_.template +++ b/src/dbcsr_lib/dbcsr_ptr_util__nametype1_.template @@ -200,7 +200,7 @@ CASE (dbcsr_memory_MPI) CALL mp_allocate(mem, n, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_alloc(mem, n, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& @@ -240,7 +240,7 @@ CASE (dbcsr_memory_MPI) CALL mp_deallocate(mem, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_dealloc(mem, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& diff --git a/src/dbcsr_lib/dbcsr_ptr_util_c.F b/src/dbcsr_lib/dbcsr_ptr_util_c.F index 2262dc821b..dbf94f1384 100644 --- a/src/dbcsr_lib/dbcsr_ptr_util_c.F +++ b/src/dbcsr_lib/dbcsr_ptr_util_c.F @@ -200,7 +200,7 @@ CASE (dbcsr_memory_MPI) CALL mp_allocate(mem, n, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_alloc(mem, n, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& @@ -240,7 +240,7 @@ CASE (dbcsr_memory_MPI) CALL mp_deallocate(mem, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_dealloc(mem, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& diff --git a/src/dbcsr_lib/dbcsr_ptr_util_d.F b/src/dbcsr_lib/dbcsr_ptr_util_d.F index 1ef1d5391b..691f06c660 100644 --- a/src/dbcsr_lib/dbcsr_ptr_util_d.F +++ b/src/dbcsr_lib/dbcsr_ptr_util_d.F @@ -200,7 +200,7 @@ CASE (dbcsr_memory_MPI) CALL mp_allocate(mem, n, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_alloc(mem, n, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& @@ -240,7 +240,7 @@ CASE (dbcsr_memory_MPI) CALL mp_deallocate(mem, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_dealloc(mem, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& diff --git a/src/dbcsr_lib/dbcsr_ptr_util_s.F b/src/dbcsr_lib/dbcsr_ptr_util_s.F index 11437d063b..6801bcbafe 100644 --- a/src/dbcsr_lib/dbcsr_ptr_util_s.F +++ b/src/dbcsr_lib/dbcsr_ptr_util_s.F @@ -200,7 +200,7 @@ CASE (dbcsr_memory_MPI) CALL mp_allocate(mem, n, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_alloc(mem, n, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& @@ -240,7 +240,7 @@ CASE (dbcsr_memory_MPI) CALL mp_deallocate(mem, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_dealloc(mem, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& diff --git a/src/dbcsr_lib/dbcsr_ptr_util_z.F b/src/dbcsr_lib/dbcsr_ptr_util_z.F index e3f5c90a18..225bfac786 100644 --- a/src/dbcsr_lib/dbcsr_ptr_util_z.F +++ b/src/dbcsr_lib/dbcsr_ptr_util_z.F @@ -200,7 +200,7 @@ CASE (dbcsr_memory_MPI) CALL mp_allocate(mem, n, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_alloc(mem, n, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_alloc(mem, n, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& @@ -240,7 +240,7 @@ CASE (dbcsr_memory_MPI) CALL mp_deallocate(mem, stat=stat) CASE (dbcsr_memory_CUDA_host_pinned) - CALL dbcsr_cuda_host_mem_dealloc(mem, stat=stat, error=error) + CALL dbcsr_cuda_host_mem_dealloc(mem, error=error) CASE default CALL dbcsr_assert (.FALSE.,& dbcsr_fatal_level, dbcsr_unimplemented_error_nr, routineN,& diff --git a/src/input_cp2k.F b/src/input_cp2k.F index 04bb636738..0724a65012 100644 --- a/src/input_cp2k.F +++ b/src/input_cp2k.F @@ -28,7 +28,7 @@ MODULE input_cp2k dbcsr_get_conf_use_comm_thread, has_blas, has_cuda, has_plasma, & has_smm_gemm, mm_driver_blas, mm_driver_cuda, mm_driver_matmul, & mm_driver_plasma, mm_driver_smm, mm_name_blas, mm_name_cuda, & - mm_name_matmul, mm_name_plasma, mm_name_smm, mm_thread_workshare + mm_name_matmul, mm_name_plasma, mm_name_smm USE dbcsr_error_handling USE dbcsr_types, ONLY: dbcsr_type_complex_4,& dbcsr_type_complex_8,& @@ -802,7 +802,7 @@ CONTAINS CHARACTER(len=64) :: a_blas, a_cuda, a_plasma, & a_smm - INTEGER :: n_buffers, n_mem_regions + INTEGER :: n_buffers INTEGER, DIMENSION(3) :: nstacks LOGICAL :: failure TYPE(dbcsr_error_type) :: dbcsr_error @@ -904,7 +904,7 @@ CONTAINS CALL section_add_keyword(section,keyword,error=error) CALL keyword_release(keyword,error=error) ! - CALL dbcsr_get_conf_nstacks (nstacks, n_buffers, n_mem_regions, dbcsr_error) + CALL dbcsr_get_conf_nstacks (nstacks, n_buffers, dbcsr_error) CALL keyword_create(keyword, name="n_size_mnk_stacks",& description="Number of stacks to use for distinct atomic sizes" & // " (e.g., 2 for a system of mostly waters).",& @@ -919,36 +919,7 @@ CONTAINS default_i_val=n_buffers,error=error) CALL section_add_keyword(section,keyword,error=error) CALL keyword_release(keyword,error=error) - CALL keyword_create(keyword, name="n_stack_memory_regions",& - description="Number of memory regions to use for stacks" & - // " (e.g., number of GPU cards per MPI process)",& - usage="n_stack_memory_regions 2",& - default_i_val=n_mem_regions,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - ! - CALL keyword_create(keyword, name="mm_thread_workshare",& - description="Share matrix multiplication work between multiple threads",& - usage="mm_thread_workshare T",& - variants=(/"MM_WORKSHARE"/),& - default_l_val=mm_thread_workshare,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - ! - CALL keyword_create(keyword, name="detailed_timing",& - description="Output multiplication timing (development)",& - usage="detailed_timing T",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - ! - CALL keyword_create(keyword, name="kernel_timing",& - description="Time multiplication kernel (development)",& - usage="kernel_timing T",& - default_l_val=.FALSE.,error=error) - CALL section_add_keyword(section,keyword,error=error) - CALL keyword_release(keyword,error=error) - ! + CALL keyword_create(keyword, name="use_comm_thread",& description="During multiplication, use a thread to periodically poll" & // " MPI to progress outstanding message completions. This is" & diff --git a/tests/LIBTEST/dbcsr_multistack.inp b/tests/LIBTEST/dbcsr_multistack.inp index 936af3d16b..f104d6e6ba 100644 --- a/tests/LIBTEST/dbcsr_multistack.inp +++ b/tests/LIBTEST/dbcsr_multistack.inp @@ -8,7 +8,6 @@ &DBCSR n_size_mnk_stacks 2 n_stack_buffers 4 - n_stack_memory_regions 5 &END DBCSR &END GLOBAL &TEST