Commit 2a9f9fa8 authored by Andreas Marek's avatar Andreas Marek

Better checking of allocation/deallocation errors in ELPA 2

parent b5a193e0
...@@ -96,7 +96,7 @@ EXTRA_libelpa@SUFFIX@_private_la_DEPENDENCIES = \ ...@@ -96,7 +96,7 @@ EXTRA_libelpa@SUFFIX@_private_la_DEPENDENCIES = \
src/elpa2/compute_hh_trafo.F90 \ src/elpa2/compute_hh_trafo.F90 \
src/elpa2/redist_band.F90 \ src/elpa2/redist_band.F90 \
src/general/sanity.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_cholesky_template.F90 \
src/elpa1/elpa_invert_trm.F90 \ src/elpa1/elpa_invert_trm.F90 \
src/elpa1/elpa_multiply_a_b.F90 \ src/elpa1/elpa_multiply_a_b.F90 \
...@@ -724,7 +724,7 @@ EXTRA_DIST = \ ...@@ -724,7 +724,7 @@ EXTRA_DIST = \
test/shared/test_precision_kinds.F90 \ test/shared/test_precision_kinds.F90 \
src/general/prow_pcol.F90 \ src/general/prow_pcol.F90 \
src/general/sanity.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_ssr2_template.F90 \
src/general/elpa_ssmv_template.F90 \ src/general/elpa_ssmv_template.F90 \
test/Fortran/assert.h \ test/Fortran/assert.h \
......
...@@ -57,7 +57,7 @@ ...@@ -57,7 +57,7 @@
#include "../general/sanity.F90" #include "../general/sanity.F90"
#if REALCASE == 1 #if REALCASE == 1
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
#endif #endif
#if REALCASE == 1 #if REALCASE == 1
......
...@@ -53,7 +53,7 @@ ...@@ -53,7 +53,7 @@
#endif #endif
#include "../general/sanity.F90" #include "../general/sanity.F90"
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
function elpa_solve_evp_& function elpa_solve_evp_&
&MATH_DATATYPE& &MATH_DATATYPE&
......
...@@ -43,7 +43,7 @@ ...@@ -43,7 +43,7 @@
! the original distribution, the GNU Lesser General Public License. ! the original distribution, the GNU Lesser General Public License.
#include "../general/sanity.F90" #include "../general/sanity.F90"
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
use elpa1_compute use elpa1_compute
use elpa_utilities use elpa_utilities
use elpa_mpi use elpa_mpi
......
...@@ -51,7 +51,7 @@ ...@@ -51,7 +51,7 @@
! distributed along with the original code in the file "COPYING". ! distributed along with the original code in the file "COPYING".
#include "../general/sanity.F90" #include "../general/sanity.F90"
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
use precision use precision
use elpa1_compute use elpa1_compute
......
...@@ -54,7 +54,7 @@ ...@@ -54,7 +54,7 @@
#include "../general/sanity.F90" #include "../general/sanity.F90"
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
use elpa1_compute use elpa1_compute
use elpa_mpi use elpa_mpi
......
...@@ -45,7 +45,7 @@ ...@@ -45,7 +45,7 @@
#include "config-f90.h" #include "config-f90.h"
#include "../general/sanity.F90" #include "../general/sanity.F90"
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
subroutine elpa_reduce_add_vectors_& subroutine elpa_reduce_add_vectors_&
&MATH_DATATYPE& &MATH_DATATYPE&
......
...@@ -49,7 +49,7 @@ ...@@ -49,7 +49,7 @@
#include "config-f90.h" #include "config-f90.h"
#include "../general/sanity.F90" #include "../general/sanity.F90"
#include "../general/error_checking_template.F90" #include "../general/error_checking.inc"
#undef ROUTINE_NAME #undef ROUTINE_NAME
#ifdef SKEW_SYMMETRIC_BUILD #ifdef SKEW_SYMMETRIC_BUILD
......
...@@ -327,23 +327,14 @@ ...@@ -327,23 +327,14 @@
if (which_qr_decomposition == 1) then if (which_qr_decomposition == 1) then
call qr_pqrparam_init(obj,pqrparam(1:11), nblk,'M',0, nblk,'M',0, nblk,'M',1,'s') 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) allocate(tauvector(na), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: tauvector", istat, errorMessage)
print *,"bandred_real: error when allocating tauvector "//errorMessage
stop 1
endif
allocate(blockheuristic(nblk), stat=istat, errmsg=errorMessage) allocate(blockheuristic(nblk), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: blockheuristic", istat, errorMessage)
print *,"bandred_real: error when allocating blockheuristic "//errorMessage
stop 1
endif
l_rows = local_index(na, my_prow, np_rows, nblk, -1) l_rows = local_index(na, my_prow, np_rows, nblk, -1)
allocate(vmrCPU(max(l_rows,1),na), stat=istat, errmsg=errorMessage) allocate(vmrCPU(max(l_rows,1),na), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: vmrCPU", istat, errorMessage)
print *,"bandred_real: error when allocating vmrCPU "//errorMessage
stop 1
endif
vmrCols = na vmrCols = na
...@@ -365,16 +356,10 @@ ...@@ -365,16 +356,10 @@
work_size = int(dwork_size(1)) work_size = int(dwork_size(1))
allocate(work_blocked(work_size), stat=istat, errmsg=errorMessage) allocate(work_blocked(work_size), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: work_blocked", istat, errorMessage)
print *,"bandred_real: error when allocating work_blocked "//errorMessage
stop 1
endif
work_blocked = 0.0_rk work_blocked = 0.0_rk
deallocate(vmrCPU, stat=istat, errmsg=errorMessage) deallocate(vmrCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: vmrCPU", istat, errorMessage)
print *,"bandred_real: error when deallocating vmrCPU "//errorMessage
stop 1
endif
endif ! which_qr_decomposition endif ! which_qr_decomposition
...@@ -466,28 +451,13 @@ ...@@ -466,28 +451,13 @@
! Allocate vmr and umcCPU to their exact sizes so that they can be used in bcasts and reduces ! 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) allocate(vmrCPU(max(l_rows,1),2*n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: vmrCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating vmrCPU "//errorMessage
stop 1
endif
allocate(umcCPU(max(l_cols,1),2*n_cols), stat=istat, errmsg=errorMessage) allocate(umcCPU(max(l_cols,1),2*n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: umcCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating umcCPU "//errorMessage
stop 1
endif
allocate(vr(l_rows+1), stat=istat, errmsg=errorMessage) allocate(vr(l_rows+1), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: vr", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating vr "//errorMessage
stop 1
endif
endif ! use GPU endif ! use GPU
...@@ -1205,12 +1175,7 @@ ...@@ -1205,12 +1175,7 @@
if (useGPU) then if (useGPU) then
#ifdef WITH_MPI #ifdef WITH_MPI
allocate(tmpCUDA(l_cols * n_cols), stat=istat, errmsg=errorMessage) allocate(tmpCUDA(l_cols * n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: tmpCUDA", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating tmpCUDA "//errorMessage
stop 1
endif
if (wantDebug) call obj%timer%start("mpi_communication") if (wantDebug) call obj%timer%start("mpi_communication")
...@@ -1223,23 +1188,13 @@ ...@@ -1223,23 +1188,13 @@
if (allocated(tmpCUDA)) then if (allocated(tmpCUDA)) then
deallocate(tmpCUDA, stat=istat, errmsg=errorMessage) deallocate(tmpCUDA, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: tmpCUDA", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating tmpCUDA "//errorMessage
stop 1
endif
endif endif
else ! useGPU else ! useGPU
allocate(tmpCPU(l_cols,n_cols), stat=istat, errmsg=errorMessage) allocate(tmpCPU(l_cols,n_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("bandred: tmpCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when allocating tmpCPU "//errorMessage
stop 1
endif
#ifdef WITH_MPI #ifdef WITH_MPI
if (wantDebug) call obj%timer%start("mpi_communication") if (wantDebug) call obj%timer%start("mpi_communication")
...@@ -1250,12 +1205,7 @@ ...@@ -1250,12 +1205,7 @@
#endif /* WITH_MPI */ #endif /* WITH_MPI */
deallocate(tmpCPU, stat=istat, errmsg=errorMessage) deallocate(tmpCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: tmpCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating tmpCPU "//errorMessage
stop 1
endif
endif ! useGPU endif ! useGPU
endif ! l_cols > 0 endif ! l_cols > 0
...@@ -1517,32 +1467,17 @@ ...@@ -1517,32 +1467,17 @@
if (.not.(useGPU)) then if (.not.(useGPU)) then
if (allocated(vr)) then if (allocated(vr)) then
deallocate(vr, stat=istat, errmsg=errorMessage) deallocate(vr, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: vr", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vr "//errorMessage
stop 1
endif
endif endif
if (allocated(umcCPU)) then if (allocated(umcCPU)) then
deallocate(umcCPU, stat=istat, errmsg=errorMessage) deallocate(umcCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: umcCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating umcCPU "//errorMessage
stop 1
endif
endif endif
if (allocated(vmrCPU)) then if (allocated(vmrCPU)) then
deallocate(vmrCPU, stat=istat, errmsg=errorMessage) deallocate(vmrCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: vmrCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vmrCPU "//errorMessage
stop 1
endif
endif endif
endif !useGPU endif !useGPU
...@@ -1598,48 +1533,27 @@ ...@@ -1598,48 +1533,27 @@
if (allocated(vr)) then if (allocated(vr)) then
deallocate(vr, stat=istat, errmsg=errorMessage) deallocate(vr, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: vr", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vr "//errorMessage
stop 1
endif
endif endif
if (allocated(umcCPU)) then if (allocated(umcCPU)) then
deallocate(umcCPU, stat=istat, errmsg=errorMessage) deallocate(umcCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: umcCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating umcCPU "//errorMessage
stop 1
endif
endif endif
if (allocated(vmrCPU)) then if (allocated(vmrCPU)) then
deallocate(vmrCPU, stat=istat, errmsg=errorMessage) deallocate(vmrCPU, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: vmrCPU", istat, errorMessage)
print *,"bandred_&
&MATH_DATATYPE&
&: error when deallocating vmrCPU "//errorMessage
stop 1
endif
endif endif
#if REALCASE == 1 #if REALCASE == 1
if (useQR) then if (useQR) then
if (which_qr_decomposition == 1) then if (which_qr_decomposition == 1) then
deallocate(work_blocked, stat=istat, errmsg=errorMessage) deallocate(work_blocked, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: work_blocked", istat, errorMessage)
print *,"bandred_real: error when deallocating work_blocked "//errorMessage
stop 1
endif
deallocate(tauvector, stat=istat, errmsg=errorMessage) deallocate(tauvector, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("bandred: tauvector", istat, errorMessage)
print *,"bandred_real: error when deallocating tauvector "//errorMessage
stop 1
endif
endif endif
endif endif
#endif #endif
......
...@@ -56,15 +56,7 @@ ...@@ -56,15 +56,7 @@
#include "../general/sanity.F90" #include "../general/sanity.F90"
#if REALCASE == 1 #if REALCASE == 1
!cannot use __FILE__ because filename with path can be too long for gfortran (max line length) #include "../general/error_checking.inc"
#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)
#endif #endif
......
...@@ -53,6 +53,7 @@ ...@@ -53,6 +53,7 @@
#endif #endif
#include "elpa/elpa_simd_constants.h" #include "elpa/elpa_simd_constants.h"
#include "../general/error_checking.inc"
function elpa_solve_evp_& function elpa_solve_evp_&
&MATH_DATATYPE& &MATH_DATATYPE&
...@@ -72,7 +73,7 @@ ...@@ -72,7 +73,7 @@
q) result(success) q) result(success)
#endif #endif
use matrix_plot !use matrix_plot
use elpa_abstract_impl use elpa_abstract_impl
use elpa_utilities use elpa_utilities
use elpa1_compute use elpa1_compute
...@@ -619,7 +620,8 @@ ...@@ -619,7 +620,8 @@
if (.not. obj%eigenvalues_only) then if (.not. obj%eigenvalues_only) then
q_actual => q(1:matrixRows,1:matrixCols) q_actual => q(1:matrixRows,1:matrixCols)
else 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) q_actual => q_dummy(1:matrixRows,1:matrixCols)
endif endif
...@@ -707,14 +709,7 @@ ...@@ -707,14 +709,7 @@
! tmat is needed only in full->band and band->full steps, so alocate here ! tmat is needed only in full->band and band->full steps, so alocate here
! (not allocated for banded matrix on input) ! (not allocated for banded matrix on input)
allocate(tmat(nbw,nbw,num_blocks), stat=istat, errmsg=errorMessage) allocate(tmat(nbw,nbw,num_blocks), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("elpa2_template: tmat", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION&
&" // ": error when allocating tmat "//errorMessage
stop 1
endif
do_bandred = .true. do_bandred = .true.
do_solve_tridi = .true. do_solve_tridi = .true.
...@@ -751,13 +746,7 @@ ...@@ -751,13 +746,7 @@
! Reduction band -> tridiagonal ! Reduction band -> tridiagonal
if (do_tridiag) then if (do_tridiag) then
allocate(e(na), stat=istat, errmsg=errorMessage) allocate(e(na), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("elpa2_template: e", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION " // ": error when allocating e "//errorMessage
stop 1
endif
call obj%timer%start("tridiag") call obj%timer%start("tridiag")
#ifdef HAVE_LIKWID #ifdef HAVE_LIKWID
...@@ -806,12 +795,7 @@ ...@@ -806,12 +795,7 @@
allocate(q_real(l_rows,l_cols), stat=istat, errmsg=errorMessage) allocate(q_real(l_rows,l_cols), stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_allocate("elpa2_template: q_real", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage: error when allocating q_real"//errorMessage
stop 1
endif
#endif #endif
! Solve tridiagonal system ! Solve tridiagonal system
...@@ -839,12 +823,7 @@ ...@@ -839,12 +823,7 @@
endif ! do_solve_tridi endif ! do_solve_tridi
deallocate(e, stat=istat, errmsg=errorMessage) deallocate(e, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("elpa2_template: e", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage: error when deallocating e "//errorMessage
stop 1
endif
if (obj%eigenvalues_only) then if (obj%eigenvalues_only) then
do_trans_to_band = .false. do_trans_to_band = .false.
...@@ -881,12 +860,7 @@ ...@@ -881,12 +860,7 @@
q(1:l_rows,1:l_cols_nev) = q_real(1:l_rows,1:l_cols_nev) q(1:l_rows,1:l_cols_nev) = q_real(1:l_rows,1:l_cols_nev)
deallocate(q_real, stat=istat, errmsg=errorMessage) deallocate(q_real, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("elpa2_template: q_real", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage: error when deallocating q_real"//errorMessage
stop 1
endif
#endif #endif
endif endif
...@@ -980,13 +954,7 @@ ...@@ -980,13 +954,7 @@
endif endif
! We can now deallocate the stored householder vectors ! We can now deallocate the stored householder vectors
deallocate(hh_trans, stat=istat, errmsg=errorMessage) deallocate(hh_trans, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("elpa2_template: hh_trans", istat, errorMessage)
print *, "solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION " // ": error when deallocating hh_trans "//errorMessage
stop 1
endif
endif endif
if (do_trans_to_full) then if (do_trans_to_full) then
...@@ -1009,13 +977,7 @@ ...@@ -1009,13 +977,7 @@
endif endif
deallocate(tmat, stat=istat, errmsg=errorMessage) deallocate(tmat, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("elpa2_template: tmat", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_2stage_&
&PRECISION " // ": error when deallocating tmat"//errorMessage
stop 1
endif
#ifdef HAVE_LIKWID #ifdef HAVE_LIKWID
call likwid_markerStopRegion("trans_ev_to_full") call likwid_markerStopRegion("trans_ev_to_full")
#endif #endif
...@@ -1024,14 +986,7 @@ ...@@ -1024,14 +986,7 @@
if (obj%eigenvalues_only) then if (obj%eigenvalues_only) then
deallocate(q_dummy, stat=istat, errmsg=errorMessage) deallocate(q_dummy, stat=istat, errmsg=errorMessage)
if (istat .ne. 0) then check_deallocate("elpa2_template: q_dummy", istat, errorMessage)
print *,"solve_evp_&
&MATH_DATATYPE&
&_1stage_&
&PRECISION&
&" // ": error when deallocating q_dummy "//errorMessage
stop 1
endif
endif endif
! restore original OpenMP settings