Skip to content

GitLab

elpa
elpa
Commit 2a9f9fa8 authored by Andreas Marek's avatar Andreas Marek
Browse files
Options

Better checking of allocation/deallocation errors in ELPA 2

parent b5a193e0
Expand all Show whitespace changes
Inline Side-by-side
Showing with 153 additions and 617 deletions
Makefile.am
View file @ 2a9f9fa8
......@@ -96,7 +96,7 @@ EXTRA_libelpa@SUFFIX@_private_la_DEPENDENCIES = \
src/elpa2/compute_hh_trafo.F90 \
src/elpa2/redist_band.F90 \
src/general/sanity.F90 \
src/general/error_checking_template.F90 \
src/general/error_checking.inc \
src/elpa1/elpa_cholesky_template.F90 \
src/elpa1/elpa_invert_trm.F90 \
src/elpa1/elpa_multiply_a_b.F90 \
......@@ -724,7 +724,7 @@ EXTRA_DIST = \
test/shared/test_precision_kinds.F90 \
src/general/prow_pcol.F90 \
src/general/sanity.F90 \
src/general/error_checking_template.F90 \
src/general/error_checking.inc \
src/general/elpa_ssr2_template.F90 \
src/general/elpa_ssmv_template.F90 \
test/Fortran/assert.h \
......
src/elpa1/elpa1_compute_template.F90
View file @ 2a9f9fa8
......@@ -57,7 +57,7 @@
#include "../general/sanity.F90"
#if REALCASE == 1
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
#endif
#if REALCASE == 1
......
src/elpa1/elpa1_template.F90
View file @ 2a9f9fa8
......@@ -53,7 +53,7 @@
#endif
#include "../general/sanity.F90"
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
function elpa_solve_evp_&
&MATH_DATATYPE&
......
src/elpa1/elpa_cholesky_template.F90
View file @ 2a9f9fa8
......@@ -43,7 +43,7 @@
! the original distribution, the GNU Lesser General Public License.
#include "../general/sanity.F90"
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
use elpa1_compute
use elpa_utilities
use elpa_mpi
......
src/elpa1/elpa_invert_trm.F90
View file @ 2a9f9fa8
......@@ -51,7 +51,7 @@
! distributed along with the original code in the file "COPYING".
#include "../general/sanity.F90"
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
use precision
use elpa1_compute
......
src/elpa1/elpa_multiply_a_b.F90
View file @ 2a9f9fa8
......@@ -54,7 +54,7 @@
#include "../general/sanity.F90"
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
use elpa1_compute
use elpa_mpi
......
src/elpa1/elpa_reduce_add_vectors.F90
View file @ 2a9f9fa8
......@@ -45,7 +45,7 @@
#include "config-f90.h"
#include "../general/sanity.F90"
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
subroutine elpa_reduce_add_vectors_&
&MATH_DATATYPE&
......
src/elpa1/elpa_transpose_vectors.F90
View file @ 2a9f9fa8
......@@ -49,7 +49,7 @@
#include "config-f90.h"
#include "../general/sanity.F90"
#include "../general/error_checking_template.F90"
#include "../general/error_checking.inc"
#undef ROUTINE_NAME
#ifdef SKEW_SYMMETRIC_BUILD
......
src/elpa2/elpa2_bandred_template.F90
View file @ 2a9f9fa8
......@@ -327,23 +327,14 @@
if (which_qr_decomposition == 1) then
call qr_pqrparam_init(obj,pqrparam(1:11), nblk,'M',0, nblk,'M',0, nblk,'M',1,'s')
allocate(tauvector(na), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when allocating tauvector "//errorMessage
stop 1
endif
check_allocate("bandred: tauvector", istat, errorMessage)
allocate(blockheuristic(nblk), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when allocating blockheuristic "//errorMessage
stop 1
endif
check_allocate("bandred: blockheuristic", istat, errorMessage)
l_rows = local_index(na, my_prow, np_rows, nblk, -1)
allocate(vmrCPU(max(l_rows,1),na), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when allocating vmrCPU "//errorMessage
stop 1
endif
check_allocate("bandred: vmrCPU", istat, errorMessage)
vmrCols = na
......@@ -365,16 +356,10 @@
work_size = int(dwork_size(1))
allocate(work_blocked(work_size), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when allocating work_blocked "//errorMessage
stop 1
endif
check_allocate("bandred: work_blocked", istat, errorMessage)
work_blocked = 0.0_rk
deallocate(vmrCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when deallocating vmrCPU "//errorMessage
stop 1
endif
check_deallocate("bandred: vmrCPU", istat, errorMessage)
endif ! which_qr_decomposition
......@@ -466,28 +451,13 @@
! Allocate vmr and umcCPU to their exact sizes so that they can be used in bcasts and reduces
allocate(vmrCPU(max(l_rows,1),2*n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating vmrCPU "//errorMessage
stop 1
endif
check_allocate("bandred: vmrCPU", istat, errorMessage)
allocate(umcCPU(max(l_cols,1),2*n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating umcCPU "//errorMessage
stop 1
endif
check_allocate("bandred: umcCPU", istat, errorMessage)
allocate(vr(l_rows+1), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating vr "//errorMessage
stop 1
endif
check_allocate("bandred: vr", istat, errorMessage)
endif ! use GPU
......@@ -1205,12 +1175,7 @@
if (useGPU) then
#ifdef WITH_MPI
allocate(tmpCUDA(l_cols * n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating tmpCUDA "//errorMessage
stop 1
endif
check_allocate("bandred: tmpCUDA", istat, errorMessage)
if (wantDebug) call obj%timer%start("mpi_communication")
......@@ -1223,23 +1188,13 @@
if (allocated(tmpCUDA)) then
deallocate(tmpCUDA, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating tmpCUDA "//errorMessage
stop 1
endif
check_deallocate("bandred: tmpCUDA", istat, errorMessage)
endif
else ! useGPU
allocate(tmpCPU(l_cols,n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating tmpCPU "//errorMessage
stop 1
endif
check_allocate("bandred: tmpCPU", istat, errorMessage)
#ifdef WITH_MPI
if (wantDebug) call obj%timer%start("mpi_communication")
......@@ -1250,12 +1205,7 @@
#endif /* WITH_MPI */
deallocate(tmpCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating tmpCPU "//errorMessage
stop 1
endif
check_deallocate("bandred: tmpCPU", istat, errorMessage)
endif ! useGPU
endif ! l_cols > 0
......@@ -1517,32 +1467,17 @@
if (.not.(useGPU)) then
if (allocated(vr)) then
deallocate(vr, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vr "//errorMessage
stop 1
endif
check_deallocate("bandred: vr", istat, errorMessage)
endif
if (allocated(umcCPU)) then
deallocate(umcCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating umcCPU "//errorMessage
stop 1
endif
check_deallocate("bandred: umcCPU", istat, errorMessage)
endif
if (allocated(vmrCPU)) then
deallocate(vmrCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vmrCPU "//errorMessage
stop 1
endif
check_deallocate("bandred: vmrCPU", istat, errorMessage)
endif
endif !useGPU
......@@ -1598,48 +1533,27 @@
if (allocated(vr)) then
deallocate(vr, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vr "//errorMessage
stop 1
endif
check_deallocate("bandred: vr", istat, errorMessage)
endif
if (allocated(umcCPU)) then
deallocate(umcCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating umcCPU "//errorMessage
stop 1
endif
check_deallocate("bandred: umcCPU", istat, errorMessage)
endif
if (allocated(vmrCPU)) then
deallocate(vmrCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vmrCPU "//errorMessage
stop 1
endif
check_deallocate("bandred: vmrCPU", istat, errorMessage)
endif
#if REALCASE == 1
if (useQR) then
if (which_qr_decomposition == 1) then
deallocate(work_blocked, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when deallocating work_blocked "//errorMessage
stop 1
endif
check_deallocate("bandred: work_blocked", istat, errorMessage)
deallocate(tauvector, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"bandred_real: error when deallocating tauvector "//errorMessage
stop 1
endif
check_deallocate("bandred: tauvector", istat, errorMessage)
endif
endif
#endif
......
src/elpa2/elpa2_compute_real_template.F90
View file @ 2a9f9fa8
......@@ -56,15 +56,7 @@
#include "../general/sanity.F90"
#if REALCASE == 1
!cannot use __FILE__ because filename with path can be too long for gfortran (max line length)
#define check_memcpy_cuda(file, success) call check_memcpy_CUDA_f(file, __LINE__, success)
#define check_alloc_cuda(file, success) call check_alloc_CUDA_f(file, __LINE__, success)
#define check_dealloc_cuda(file, success) call check_dealloc_CUDA_f(file, __LINE__, success)
#define check_host_register_cuda(file, success) call check_host_register_CUDA_f(file, __LINE__, success)
#define check_host_unregister_cuda(file, success) call check_host_unregister_CUDA_f(file, __LINE__, success)
#define check_host_alloc_cuda(file, success) call check_host_alloc_CUDA_f(file, __LINE__, success)
#define check_host_dealloc_cuda(file, success) call check_host_dealloc_CUDA_f(file, __LINE__, success)
#define check_memset_cuda(file, success) call check_memset_CUDA_f(file, __LINE__, success)
#include "../general/error_checking.inc"
#endif
......
src/elpa2/elpa2_template.F90
View file @ 2a9f9fa8
......@@ -53,6 +53,7 @@
#endif
#include "elpa/elpa_simd_constants.h"
#include "../general/error_checking.inc"
function elpa_solve_evp_&
&MATH_DATATYPE&
......@@ -72,7 +73,7 @@
q) result(success)
#endif
use matrix_plot
!use matrix_plot
use elpa_abstract_impl
use elpa_utilities
use elpa1_compute
......@@ -619,7 +620,8 @@
if (.not. obj%eigenvalues_only) then
q_actual => q(1:matrixRows,1:matrixCols)
else
allocate(q_dummy(1:matrixRows,1:matrixCols))
allocate(q_dummy(1:matrixRows,1:matrixCols), stat=istat, errmsg=errorMessage)
check_allocate("elpa2_template: q_dummy", istat, errorMessage)
q_actual => q_dummy(1:matrixRows,1:matrixCols)
endif
......@@ -707,14 +709,7 @@
! tmat is needed only in full->band and band->full steps, so alocate here
! (not allocated for banded matrix on input)
allocate(tmat(nbw,nbw,num_blocks), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION&
&" // ": error when allocating tmat "//errorMessage
stop 1
endif
check_allocate("elpa2_template: tmat", istat, errorMessage)
do_bandred = .true.
do_solve_tridi = .true.
......@@ -751,13 +746,7 @@
! Reduction band -> tridiagonal
if (do_tridiag) then
allocate(e(na), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION " // ": error when allocating e "//errorMessage
stop 1
endif
check_allocate("elpa2_template: e", istat, errorMessage)
call obj%timer%start("tridiag")
#ifdef HAVE_LIKWID
......@@ -806,12 +795,7 @@
allocate(q_real(l_rows,l_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage: error when allocating q_real"//errorMessage
stop 1
endif
check_allocate("elpa2_template: q_real", istat, errorMessage)
#endif
! Solve tridiagonal system
......@@ -839,12 +823,7 @@
endif ! do_solve_tridi
deallocate(e, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage: error when deallocating e "//errorMessage
stop 1
endif
check_deallocate("elpa2_template: e", istat, errorMessage)
if (obj%eigenvalues_only) then
do_trans_to_band = .false.
......@@ -881,12 +860,7 @@
q(1:l_rows,1:l_cols_nev) = q_real(1:l_rows,1:l_cols_nev)
deallocate(q_real, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage: error when deallocating q_real"//errorMessage
stop 1
endif
check_deallocate("elpa2_template: q_real", istat, errorMessage)
#endif
endif
......@@ -980,13 +954,7 @@
endif
! We can now deallocate the stored householder vectors
deallocate(hh_trans, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *, "solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION " // ": error when deallocating hh_trans "//errorMessage
stop 1
endif
check_deallocate("elpa2_template: hh_trans", istat, errorMessage)
endif
if (do_trans_to_full) then
......@@ -1009,13 +977,7 @@
endif
deallocate(tmat, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION " // ": error when deallocating tmat"//errorMessage
stop 1
endif
check_deallocate("elpa2_template: tmat", istat, errorMessage)
#ifdef HAVE_LIKWID
call likwid_markerStopRegion("trans_ev_to_full")
#endif
......@@ -1024,14 +986,7 @@
if (obj%eigenvalues_only) then
deallocate(q_dummy, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"solve_evp_&
&MATH_DATATYPE&
&_1stage_&
&PRECISION&
&" // ": error when deallocating q_dummy "//errorMessage
stop 1
endif
check_deallocate("elpa2_template: q_dummy", istat, errorMessage)
endif
! restore original OpenMP settings
......
src/elpa2/elpa2_trans_ev_band_to_full_template.F90
View file @ 2a9f9fa8
......@@ -221,45 +221,20 @@
else ! useGPU
allocate(tmp1(max_local_cols*cwy_blocking), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating tmp1 "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: tmp1", istat, errorMessage)
allocate(tmp2(max_local_cols*cwy_blocking), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating tmp2 "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: tmp2", istat, errorMessage)
allocate(hvm(max_local_rows,cwy_blocking), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating hvm "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: hvm", istat, errorMessage)
endif !useGPU
allocate(hvb(max_local_rows*cwy_blocking), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating hvb "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: hvb", istat, errorMessage)
allocate(tmat_complete(cwy_blocking,cwy_blocking), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating tmat_complete "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: tmat_complete", istat, errorMessage)
if (useGPU) then
successCUDA = cuda_host_register(int(loc(tmat_complete),kind=c_intptr_t), &
......@@ -270,20 +245,10 @@
if (blocking_factor > 1) then
allocate(t_tmp(cwy_blocking,nbw), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating t_tmp "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: t_tmp", istat, errorMessage)
allocate(t_tmp2(cwy_blocking,nbw), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when allocating t_tmp2 "//errorMessage
stop 1
endif
check_allocate("trans_ev_band_to_full: t_tmp2", istat, errorMessage)
endif
if (useGPU) then
......@@ -512,12 +477,7 @@
enddo ! istep
deallocate(hvb, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating hvb "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: hvb", istat, errorMessage)
if (useGPU) then
successCUDA = cuda_free(hvm_dev)
......@@ -556,54 +516,24 @@
check_host_unregister_cuda("trans_ev_band_to_full: tmat_complete", successCUDA)
else ! useGPU
deallocate(tmp1, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating tmp1 "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: tmp1", istat, errorMessage)
deallocate(tmp2, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating tmp2 "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: tmp2", istat, errorMessage)
deallocate(hvm, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating hvm "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: hvm", istat, errorMessage)
endif ! useGPU
deallocate(tmat_complete, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating tmat_complete "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: tmat_complete", istat, errorMessage)
if (blocking_factor > 1) then
deallocate(t_tmp, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating t_tmp "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: t_tmp", istat, errorMessage)
deallocate(t_tmp2, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"trans_ev_band_to_full_&
&MATH_DATATYPE&
&: error when deallocating t_tmp2 "//errorMessage
stop 1
endif
check_deallocate("trans_ev_band_to_full: t_tmp2", istat, errorMessage)
endif
call obj%timer%stop("trans_ev_band_to_full_&
......
src/elpa2/elpa2_tridiag_band_template.F90
View file @ 2a9f9fa8
......@@ -181,24 +181,14 @@
! Get global_id mapping 2D procssor coordinates to global id
allocate(global_id(0:np_rows-1,0:np_cols-1), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then
print *,"tridiag_band_&
&MATH_DATATYPE&
&: error when allocating global_id "//errorMessage
stop 1
endif
check_allocate("tridiag_band: global_id", istat, errorMessage)
global_id(:,:) = 0