From 313e454349c07f237d7831e07dea2964ed14177a Mon Sep 17 00:00:00 2001 From: ignis Date: Fri, 29 May 2026 11:29:38 +0000 Subject: [PATCH] HPC post-processing safety & precision unification: added MPI_Abort for allocation error checks and completed real(real64) precision unification across source files and code generator templates --- code/Compact.f90 | 1 + code/code_gen/post.py | 40 ++++++++++++------ code/code_gen/resources/m_template.py | 1 + code/m_arrays.f90 | 33 ++++++++++++--- code/m_calculate.f90 | 61 ++++++++++++++++++--------- code/post.f90 | 28 ++++++++---- 6 files changed, 118 insertions(+), 46 deletions(-) diff --git a/code/Compact.f90 b/code/Compact.f90 index d3f6525..3eec03d 100644 --- a/code/Compact.f90 +++ b/code/Compact.f90 @@ -1,4 +1,5 @@ MODULE Compact + use, intrinsic :: iso_fortran_env, only: real64 IMPLICIT NONE REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: lxf,lxs,wxf,wxs, & diff --git a/code/code_gen/post.py b/code/code_gen/post.py index 0efd712..7488960 100644 --- a/code/code_gen/post.py +++ b/code/code_gen/post.py @@ -271,6 +271,17 @@ class ExpToCode(Transformer): +def make_allocate(name, shape, init_zero=True): + alloc_str = f"allocate({name}({shape}), stat=ierr)\n" + alloc_str += f"if (ierr /= 0) then\n" + alloc_str += f" write(0,*) 'Error: allocation of {name} failed on process', myid\n" + alloc_str += f" call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err)\n" + alloc_str += f"end if" + if init_zero: + alloc_str += f"\n{name} = 0." + return alloc_str + + class FieldBase (object): def __init__ (self, name, fdict): self.name = name @@ -323,12 +334,11 @@ class FieldBase (object): def code_decl (self): - real_array_decl = "real*8, allocatable, dimension({1}) :: {0}" + real_array_decl = "real(real64), allocatable, dimension({1}) :: {0}" return real_array_decl.format(self.name, self.dim) def code_alloc (self): - real_array_alloc = "allocate({0}({1}), stat=ierr) ; {0} = 0." - return real_array_alloc.format(self.name, self.shape) + return make_allocate(self.name, self.shape) def code_free (self): real_array_free = "deallocate({})" @@ -385,7 +395,7 @@ integer(kind=MPI_INTEGER_KIND) :: {field_name}_fh integer(kind=MPI_INTEGER_KIND) :: {field_name}_info ! - buffer -real*8, allocatable, dimension(:,:,:) :: {field_name}_export_array +real(real64), allocatable, dimension(:,:,:) :: {field_name}_export_array integer, allocatable, dimension(:) :: {field_name}_xpts ''' @@ -393,8 +403,17 @@ integer, allocatable, dimension(:) :: {field_name}_xpts ! init call MPI_INFO_CREATE({field_name}_info, mpi_err) call MPI_FILE_OPEN(MPI_COMM_TASK,'export-{field_name}.dat',MPI_MODE_WRONLY+MPI_MODE_CREATE,{field_name}_info,{field_name}_fh,mpi_err) -allocate({field_name}_export_array(1:{len_xpts},{ys}:{ye},{zs}:{ze}), stat=ierr) ; {field_name}_export_array = 0. +allocate({field_name}_export_array(1:{len_xpts},{ys}:{ye},{zs}:{ze}), stat=ierr) +if (ierr /= 0) then + write(0,*) 'Error: allocation of {field_name}_export_array failed on process', myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) +end if +{field_name}_export_array = 0. allocate({field_name}_xpts(1:{len_xpts}), stat=ierr) +if (ierr /= 0) then + write(0,*) 'Error: allocation of {field_name}_xpts failed on process', myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) +end if {xpts_init} ''' @@ -991,13 +1010,10 @@ class Stage4(): array_names = [self.array_name.format(i) for i in range(self.narr)] - real_array_decl = "real*8, allocatable, dimension(:,:,:) :: {0}" - real_array_alloc = "allocate({0}(nxp,nyp,nzp), stat=ierr) ; {0} = 0." - real_array_free = "deallocate({})" - + real_array_decl = "real(real64), allocatable, dimension(:,:,:) :: {0}" decl = "\n".join([real_array_decl.format(v) for v in array_names]) - alloc = "\n".join([real_array_alloc.format(v) for v in array_names]) - free = "\n".join([real_array_free.format(v) for v in array_names]) + alloc = "\n".join([make_allocate(v, "nxp,nyp,nzp") for v in array_names]) + free = "\n".join(["deallocate({})".format(v) for v in array_names]) return decl, alloc, free @@ -1005,7 +1021,7 @@ class Stage4(): def write_avg_codes (self, avglist): avg_array_write = ''' -real*8, dimension(nxp) :: xbuffer +real(real64), dimension(nxp) :: xbuffer integer :: i open (200, file="qEdge_X.dat") diff --git a/code/code_gen/resources/m_template.py b/code/code_gen/resources/m_template.py index 3d2ef83..572c575 100644 --- a/code/code_gen/resources/m_template.py +++ b/code/code_gen/resources/m_template.py @@ -1,5 +1,6 @@ mod_form='''module m_{0[module_name]} +use, intrinsic :: iso_fortran_env, only: real64 use m_openmpi use m_parameters use m_arrays diff --git a/code/m_arrays.f90 b/code/m_arrays.f90 index da70123..9bf3881 100644 --- a/code/m_arrays.f90 +++ b/code/m_arrays.f90 @@ -1,10 +1,11 @@ module m_arrays +use, intrinsic :: iso_fortran_env, only: real64 use m_parameters implicit none -real*8, allocatable, dimension(:,:,:) :: u,v,w,y +real(real64), allocatable, dimension(:,:,:) :: u,v,w,y contains @@ -12,11 +13,33 @@ subroutine m_arrays_init integer :: ierr -ALLOCATE(u(nxp,nyp,nzp),STAT=ierr) ; u=0. ! Main variables -ALLOCATE(v(nxp,nyp,nzp),STAT=ierr) ; v=0. ! Main variables -ALLOCATE(w(nxp,nyp,nzp),STAT=ierr) ; w=0. ! Main variables +ALLOCATE(u(nxp,nyp,nzp),STAT=ierr) +if (ierr /= 0) then + write(0,*) "Error: allocation of u failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) +end if +u=0. -ALLOCATE(y(nxp,nyp,nzp),STAT=ierr) ; y=0. +ALLOCATE(v(nxp,nyp,nzp),STAT=ierr) +if (ierr /= 0) then + write(0,*) "Error: allocation of v failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) +end if +v=0. + +ALLOCATE(w(nxp,nyp,nzp),STAT=ierr) +if (ierr /= 0) then + write(0,*) "Error: allocation of w failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) +end if +w=0. + +ALLOCATE(y(nxp,nyp,nzp),STAT=ierr) +if (ierr /= 0) then + write(0,*) "Error: allocation of y failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) +end if +y=0. end subroutine m_arrays_init diff --git a/code/m_calculate.f90 b/code/m_calculate.f90 index 8ef09f9..791959e 100644 --- a/code/m_calculate.f90 +++ b/code/m_calculate.f90 @@ -1,15 +1,16 @@ module m_calculate + use, intrinsic :: iso_fortran_env, only: real64 use Compact use m_parameters implicit none - real*8, allocatable, dimension(:,:) :: xsrc - real*8, allocatable, dimension(:,:) :: xdst + real(real64), allocatable, dimension(:,:) :: xsrc + real(real64), allocatable, dimension(:,:) :: xdst - real*8, allocatable, dimension(:,:) :: rsrc - real*8, allocatable, dimension(:,:) :: rdst + real(real64), allocatable, dimension(:,:) :: rsrc + real(real64), allocatable, dimension(:,:) :: rdst integer, parameter :: nb = BLOCKSIZE @@ -25,10 +26,28 @@ contains call ludcmp(nxp,nyp,nzp,1,0,0) ! 1,1,0 allocate(xsrc(nb, nxp), stat=ierr) + if (ierr /= 0) then + write(0,*) "Error: allocation of xsrc failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) + end if + allocate(xdst(nb, nxp), stat=ierr) + if (ierr /= 0) then + write(0,*) "Error: allocation of xdst failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) + end if allocate(rsrc(nxp, nzp), stat=ierr) + if (ierr /= 0) then + write(0,*) "Error: allocation of rsrc failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) + end if + allocate(rdst(nxp, nzp), stat=ierr) + if (ierr /= 0) then + write(0,*) "Error: allocation of rdst failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) + end if end subroutine m_calculate_init @@ -240,12 +259,12 @@ contains end subroutine tp2 - real function rxn_rate (c) + real(real64) function rxn_rate (c) - real :: c + real(real64) :: c - if(c.lt.0.) c=0. - if(c.gt.1.) c=1. + if(c.lt.0._real64) c=0._real64 + if(c.gt.1._real64) c=1._real64 if (c.le.c_cut) then @@ -265,39 +284,39 @@ contains end function rxn_rate - real function threshold_min_max (c, minc, maxc) + real(real64) function threshold_min_max (c, minc, maxc) - real :: c - real :: minc, maxc + real(real64) :: c + real(real64) :: minc, maxc if ((c.lt.minc) .or. (c.gt.maxc)) then - threshold_min_max = 0. + threshold_min_max = 0._real64 else - threshold_min_max = 1.0 + threshold_min_max = 1.0_real64 end if end function threshold_min_max - real function positive (c) + real(real64) function positive (c) - real :: c + real(real64) :: c - if (c > 0.0d0) then + if (c > 0.0_real64) then positive = c else - positive = 0. + positive = 0._real64 end if end function positive - real function negative (c) + real(real64) function negative (c) - real :: c + real(real64) :: c - if (c < 0.0d0) then + if (c < 0.0_real64) then negative = c else - negative = 0. + negative = 0._real64 end if end function negative diff --git a/code/post.f90 b/code/post.f90 index 3ea3b19..cf9c9e9 100644 --- a/code/post.f90 +++ b/code/post.f90 @@ -1,4 +1,5 @@ - MODULE post +MODULE post + use, intrinsic :: iso_fortran_env, only: real64 USE Compact USE m_parameters USE m_calculate @@ -11,9 +12,9 @@ INTEGER :: nprogress INTEGER :: ipass INTEGER :: num_, dummyu_ ! hybrid - REAL :: tnow + real(real64) :: tnow - REAL, DIMENSION(:,:,:,:), ALLOCATABLE :: old_scalar, new_scalar + real(real64), DIMENSION(:,:,:,:), ALLOCATABLE :: old_scalar, new_scalar PUBLIC :: main, main_lb CONTAINS @@ -273,10 +274,10 @@ SUBROUTINE READ_FILE(num) INTEGER, INTENT(IN) :: num - REAL, DIMENSION(2) :: tmpr + real(real64), DIMENSION(2) :: tmpr INTEGER :: nx, ny, nz - REAL :: tmp1,tmp2 - REAL :: dt,dummyu + real(real64) :: tmp1,tmp2 + real(real64) :: dt,dummyu INTEGER :: ncyc integer(8) :: ctime_i @@ -340,8 +341,19 @@ CALL m_calculate_init CALL m_terms_init - ALLOCATE(old_scalar(2,nxp,nyp,nzp),STAT=ierr) ; old_scalar=0. ! Main variables - ALLOCATE(new_scalar(nxp,nyp,nzp,2),STAT=ierr) ; new_scalar=0. + ALLOCATE(old_scalar(2,nxp,nyp,nzp),STAT=ierr) + if (ierr /= 0) then + write(0,*) "Error: allocation of old_scalar failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) + end if + old_scalar=0. ! Main variables + + ALLOCATE(new_scalar(nxp,nyp,nzp,2),STAT=ierr) + if (ierr /= 0) then + write(0,*) "Error: allocation of new_scalar failed on process", myid + call MPI_ABORT(MPI_COMM_TASK, 1, mpi_err) + end if + new_scalar=0. WRITE(*,'(a6,i3,a8,i3,a8,i3)') ' NX = ',nxp,' / NY = ',nyp,' / NZ = ',nzp WRITE(*,*) ' Preparing memory space for COMPACT SCHEME'