From 58e71187ad96b9c1f5d33ccc191a3fa8f3888cbd Mon Sep 17 00:00:00 2001
From: Philippe WAUTELET <philippe.wautelet@aero.obs-mip.fr>
Date: Fri, 21 Jun 2024 15:25:52 +0200
Subject: [PATCH] Philippe 21/06/2024: IO_Field_read: 2D fields: ensure that
data can not be overwritten in case of read error
---
src/LIB/SURCOUCHE/src/mode_allocbuff.f90 | 78 +++++-
src/LIB/SURCOUCHE/src/mode_io_field_read.f90 | 239 ++++++++++---------
2 files changed, 196 insertions(+), 121 deletions(-)
diff --git a/src/LIB/SURCOUCHE/src/mode_allocbuff.f90 b/src/LIB/SURCOUCHE/src/mode_allocbuff.f90
index 78c250031..17e624971 100644
--- a/src/LIB/SURCOUCHE/src/mode_allocbuff.f90
+++ b/src/LIB/SURCOUCHE/src/mode_allocbuff.f90
@@ -18,9 +18,9 @@ PRIVATE
INTERFACE ALLOCBUFFER_ll
MODULE PROCEDURE &
- ALLOCBUFFER_X1, ALLOCBUFFER_NEW_X1, ALLOCBUFFER_X2, ALLOCBUFFER_X3, &
+ ALLOCBUFFER_X1, ALLOCBUFFER_NEW_X1, ALLOCBUFFER_X2, ALLOCBUFFER_NEW_X2, ALLOCBUFFER_X3, &
ALLOCBUFFER_X4, ALLOCBUFFER_X5, ALLOCBUFFER_X6, &
- ALLOCBUFFER_N1, ALLOCBUFFER_NEW_N1, ALLOCBUFFER_N2, ALLOCBUFFER_N3, &
+ ALLOCBUFFER_N1, ALLOCBUFFER_NEW_N1, ALLOCBUFFER_N2, ALLOCBUFFER_NEW_N2, ALLOCBUFFER_N3, &
ALLOCBUFFER_N4, &
ALLOCBUFFER_L1, ALLOCBUFFER_NEW_L1
END INTERFACE
@@ -108,6 +108,35 @@ CASE default
END SELECT
END SUBROUTINE ALLOCBUFFER_N2
+SUBROUTINE ALLOCBUFFER_NEW_N2( KTAB_OUT, KTAB_IN, HDIR )
+ USE MODD_IO, ONLY: LPACK, L2D
+ !
+ INTEGER, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: KTAB_OUT
+ INTEGER, DIMENSION(:,:), INTENT(IN) :: KTAB_IN
+ CHARACTER(LEN=*), INTENT(IN) :: HDIR
+
+ INTEGER :: IIMAX, IJMAX
+
+ SELECT CASE(HDIR)
+ CASE('XX')
+ CALL GET_GLOBALDIMS_ll(IIMAX,IJMAX)
+ ALLOCATE(KTAB_OUT(IIMAX+2*JPHEXT,SIZE(KTAB_IN,2)))
+ CASE('YY')
+ CALL GET_GLOBALDIMS_ll(IIMAX,IJMAX)
+ ALLOCATE(KTAB_OUT(IJMAX+2*JPHEXT,SIZE(KTAB_IN,2)))
+ CASE('XY')
+ CALL GET_GLOBALDIMS_ll(IIMAX,IJMAX)
+ IF (LPACK .AND. L2D) THEN
+ ! 2D compact case
+ ALLOCATE(KTAB_OUT(IIMAX+2*JPHEXT,1))
+ ELSE
+ ALLOCATE(KTAB_OUT(IIMAX+2*JPHEXT,IJMAX+2*JPHEXT))
+ END IF
+ CASE default
+ ALLOCATE( KTAB_OUT, MOLD = KTAB_IN )
+ END SELECT
+END SUBROUTINE ALLOCBUFFER_NEW_N2
+
SUBROUTINE ALLOCBUFFER_N3(KTAB_P,KTAB,HDIR,OALLOC)
USE MODD_IO, ONLY: LPACK, L2D
!
@@ -340,6 +369,51 @@ CASE default
END SELECT
END SUBROUTINE ALLOCBUFFER_X2
+SUBROUTINE ALLOCBUFFER_NEW_X2( PTAB_OUT, PTAB_IN, HDIR, KIMAX_ll, KJMAX_ll )
+ USE MODD_IO, ONLY: LPACK, L2D
+ !
+ REAL, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: PTAB_OUT
+ REAL, DIMENSION(:,:), INTENT(IN) :: PTAB_IN
+ CHARACTER(LEN=*), INTENT(IN) :: HDIR
+ INTEGER, OPTIONAL, INTENT(IN) ::KIMAX_ll
+ INTEGER, OPTIONAL, INTENT(IN) ::KJMAX_ll
+
+ INTEGER :: IIMAX,IJMAX
+
+ SELECT CASE(HDIR)
+ CASE('XX')
+ IF( PRESENT(KIMAX_ll) .AND. PRESENT(KJMAX_ll) ) THEN
+ IIMAX = KIMAX_ll
+ IJMAX = KJMAX_ll
+ ELSE
+ CALL GET_GLOBALDIMS_ll(IIMAX,IJMAX)
+ ENDIF
+ ALLOCATE(PTAB_OUT(IIMAX+2*JPHEXT,SIZE(PTAB_IN,2)))
+ CASE('YY')
+ IF( PRESENT(KIMAX_ll) .AND. PRESENT(KJMAX_ll) ) THEN
+ IIMAX = KIMAX_ll
+ IJMAX = KJMAX_ll
+ ELSE
+ CALL GET_GLOBALDIMS_ll(IIMAX,IJMAX)
+ ENDIF
+ ALLOCATE(PTAB_OUT(IJMAX+2*JPHEXT,SIZE(PTAB_IN,2)))
+ CASE('XY')
+ IF( PRESENT(KIMAX_ll) .AND. PRESENT(KJMAX_ll) ) THEN
+ IIMAX = KIMAX_ll
+ IJMAX = KJMAX_ll
+ ELSE
+ CALL GET_GLOBALDIMS_ll(IIMAX,IJMAX)
+ ENDIF
+ IF (LPACK .AND. L2D) THEN ! 2D compact case
+ ALLOCATE(PTAB_OUT(IIMAX+2*JPHEXT,1))
+ ELSE
+ ALLOCATE(PTAB_OUT(IIMAX+2*JPHEXT,IJMAX+2*JPHEXT))
+ END IF
+ CASE default
+ ALLOCATE( PTAB_OUT, MOLD = PTAB_IN )
+ END SELECT
+END SUBROUTINE ALLOCBUFFER_NEW_X2
+
SUBROUTINE ALLOCBUFFER_X3(PTAB_P,PTAB,HDIR,OALLOC)
USE MODD_IO, ONLY: LPACK, L2D
!
diff --git a/src/LIB/SURCOUCHE/src/mode_io_field_read.f90 b/src/LIB/SURCOUCHE/src/mode_io_field_read.f90
index 44a565132..30a1f0987 100644
--- a/src/LIB/SURCOUCHE/src/mode_io_field_read.f90
+++ b/src/LIB/SURCOUCHE/src/mode_io_field_read.f90
@@ -344,7 +344,6 @@ USE MODD_PARAMETERS_ll, ONLY: JPHEXT
USE MODD_STRUCTURE_ll, ONLY: ZONE_ll
USE MODD_TIMEZ, ONLY: TIMEZ
!
-USE MODE_ALLOCBUFFER_ll
#ifdef MNH_GA
USE MODE_GA
#endif
@@ -365,10 +364,9 @@ INTEGER, OPTIONAL, INTENT(IN) :: KJMAX_ll
TYPE(ZONE_ll), DIMENSION(ISNPROC), OPTIONAL, INTENT(IN) :: TPSPLITTING ! splitting of the domain
!
INTEGER :: IERR
-real :: zfieldp0d
-real, dimension(:), pointer :: zfieldp1d
-REAL, DIMENSION(:,:), POINTER :: ZFIELDP
-LOGICAL :: GALLOC
+real :: zfield0d
+real, dimension(:), allocatable :: zfield1d
+real, dimension(:,:), allocatable :: zfield2d
logical :: glfi, gnc4
INTEGER :: IRESP
INTEGER :: IHEXTOT
@@ -384,9 +382,7 @@ INTEGER :: IINFO_ll
CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_Field_read_byfield_X2',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME))
!
CALL SECOND_MNH2(ZT11)
-GALLOC = .FALSE.
IRESP = 0
-ZFIELDP => NULL()
!
IHEXTOT = 2*JPHEXT+1
CALL IO_File_read_check(TPFILE,'IO_Field_read_byfield_X2',IRESP)
@@ -396,45 +392,49 @@ call IO_Format_read_select( tpfile, glfi, gnc4 )
IF (IRESP==0) THEN
IF (GSMONOPROC) THEN ! sequential execution
if ( lpack .and. l1d .and. Size( pfield, 1 ) == ihextot .and. Size( pfield, 2 ) == ihextot ) then
- Allocate( tzfield, source = tpfield )
+ allocate( tzfield, source = tpfield )
if ( tpfile%ldimreduced ) then
tzfield%ndims = tzfield%ndims - 2
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(1) = tzfield%ndimlist(3) !Necessary if time dimension
tzfield%ndimlist(2:) = NMNHDIM_UNUSED
end if
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfieldp0d, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfieldp0d, iresp )
- pfield(:, :) = Spread( Spread( zfieldp0d, dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfield0d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfield0d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ pfield(:, :) = Spread( Spread( zfield0d, dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
else
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(1:2) = NMNHDIM_ONE
end if
- zfieldp => pfield(jphext + 1 : jphext + 1, jphext + 1 : jphext + 1)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfieldp, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfieldp, iresp )
- pfield(:, :) = Spread( Spread( pfield(jphext + 1, jphext + 1), dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
+ allocate( zfield2d(1,1) )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfield2d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfield2d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ pfield(:, :) = Spread( Spread( zfield2d(1,1), dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
endif
else if ( lpack .and. l2d .and. Size( pfield, 2 ) == ihextot ) then
- Allocate( tzfield, source = tpfield )
+ allocate( tzfield, source = tpfield )
if ( tpfile%ldimreduced ) then
tzfield%ndims = tzfield%ndims - 1
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(2) = tzfield%ndimlist(3) !Necessary if time dimension
tzfield%ndimlist(3:) = NMNHDIM_UNUSED
end if
- zfieldp1d => pfield(:, jphext + 1)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfieldp1d, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfieldp1d, iresp )
- pfield(:, :) = Spread( pfield(:, jphext + 1), dim = 2, ncopies = ihextot )
+ allocate( zfield1d(size(pfield,1)) )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfield1d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfield1d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ pfield(:, :) = Spread( zfield1d(:), dim = 2, ncopies = ihextot )
else
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(2) = NMNHDIM_ONE
end if
- zfieldp => pfield(:, jphext + 1 : jphext + 1)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfieldp, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfieldp, iresp )
- pfield(:,:) = Spread( pfield(:, jphext + 1), dim = 2, ncopies = ihextot )
+ allocate( zfield2d(size(pfield,1),1) )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, zfield2d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, zfield2d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ pfield(:,:) = Spread( zfield2d(:,1), dim = 2, ncopies = ihextot )
endif
else
if ( gnc4 ) call IO_Field_read_nc4( tpfile, tpfield, pfield, iresp )
@@ -444,13 +444,12 @@ IF (IRESP==0) THEN
CALL SECOND_MNH2(ZT0)
IF (ISP == TPFILE%NMASTER_RANK) THEN
! I/O process case
- CALL ALLOCBUFFER_ll(ZFIELDP,PFIELD,TPFIELD%CDIR,GALLOC, KIMAX_ll, KJMAX_ll)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tpfield, zfieldp, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tpfield, zfieldp, iresp )
+ call Allocbuffer_ll( zfield2d, pfield, tpfield%cdir, kimax_ll, kjmax_ll )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tpfield, zfield2d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tpfield, zfield2d, iresp )
ELSE
!Not really necessary but useful to suppress alerts with Valgrind
- ALLOCATE(ZFIELDP(0,0))
- GALLOC = .TRUE.
+ allocate( zfield2d(0,0) )
END IF
CALL SECOND_MNH2(ZT1)
TIMEZ%T_READ2D_READ=TIMEZ%T_READ2D_READ + ZT1 - ZT0
@@ -461,60 +460,62 @@ IF (IRESP==0) THEN
!because metadata of field has been modified in IO_Field_read_xxx
IF (IRESP==-111) CALL IO_Field_metadata_bcast(TPFILE,TPFIELD)
!
- IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN
- ! XX or YY Scatter Field
- CALL SCATTER_XXFIELD(TPFIELD%CDIR,ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING)
- ELSE IF (TPFIELD%CDIR == 'XY') THEN
- IF (LPACK .AND. L2D) THEN
- ! 2D compact case
- call Print_msg( NVERB_FATAL, 'GEN', 'IO_Field_read_byfield_X2', '2D not (yet) allowed for parallel execution' )
- CALL SCATTER_XXFIELD('XX',ZFIELDP(:,1),PFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING)
- PFIELD(:,:) = SPREAD(PFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT)
- ELSE
+ !Share data only if no error
+ if ( iresp == 0 .or. iresp == -111 ) then
+ IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN
+ ! XX or YY Scatter Field
+ CALL SCATTER_XXFIELD(TPFIELD%CDIR,zfield2d,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING)
+ ELSE IF (TPFIELD%CDIR == 'XY') THEN
+ IF (LPACK .AND. L2D) THEN
+ ! 2D compact case
+ call Print_msg( NVERB_FATAL, 'GEN', 'IO_Field_read_byfield_X2', '2D not (yet) allowed for parallel execution' )
+ CALL SCATTER_XXFIELD('XX',zfield2d(:,1),PFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM,TPSPLITTING)
+ PFIELD(:,:) = SPREAD(PFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT)
+ ELSE
#ifdef MNH_GA
- !
- ! init/create the ga , dim3 = 1
- !
- CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),1,TPFIELD%CMNHNAME,"READ")
- IF (ISP == TPFILE%NMASTER_RANK) THEN
!
- ! put the data in the g_a , this proc get this 1 slide
+ ! init/create the ga , dim3 = 1
!
- lo_zplan(JPIZ) = 1
- hi_zplan(JPIZ) = 1
- !print*,"IO_READ_FIELD_BYFIELD_X2::nga_put=",g_a, lo_zplan, hi_zplan, ld_zplan, TPFIELD%CMNHNAME ; call flush(6)
- call nga_put(g_a, lo_zplan, hi_zplan,ZFIELDP, ld_zplan)
- END IF
- call ga_sync()
- !
- ! get the columun data in this proc
- !
- ! temp buf to avoid problem with none stride PFIELDS buffer with HALO
- ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2)))
- !print*,"IO_READ_FIELD_BYFIELD_X2::nga_get=",g_a, lo_col, hi_col, ld_col, TPFIELD%CMNHNAME ; call flush(6)
- call nga_get(g_a, lo_col, hi_col,ZFIELD_GA(1,1) , ld_col)
- PFIELD = ZFIELD_GA
- call ga_sync()
- NULLIFY(TZFIELD_ll)
- CALL ADD2DFIELD_ll(TZFIELD_ll,PFIELD )
- CALL UPDATE_HALO_ll(TZFIELD_ll,IINFO_ll)
- CALL CLEANLIST_ll(TZFIELD_ll)
- DEALLOCATE(ZFIELD_GA)
+ CALL MNH_INIT_GA(SIZE(PFIELD,1),SIZE(PFIELD,2),1,TPFIELD%CMNHNAME,"READ")
+ IF (ISP == TPFILE%NMASTER_RANK) THEN
+ !
+ ! put the data in the g_a , this proc get this 1 slide
+ !
+ lo_zplan(JPIZ) = 1
+ hi_zplan(JPIZ) = 1
+ !print*,"IO_READ_FIELD_BYFIELD_X2::nga_put=",g_a, lo_zplan, hi_zplan, ld_zplan, TPFIELD%CMNHNAME ; call flush(6)
+ call nga_put(g_a, lo_zplan, hi_zplan,zfield2d, ld_zplan)
+ END IF
+ call ga_sync()
+ !
+ ! get the columun data in this proc
+ !
+ ! temp buf to avoid problem with none stride PFIELDS buffer with HALO
+ ALLOCATE (ZFIELD_GA (SIZE(PFIELD,1),SIZE(PFIELD,2)))
+ !print*,"IO_READ_FIELD_BYFIELD_X2::nga_get=",g_a, lo_col, hi_col, ld_col, TPFIELD%CMNHNAME ; call flush(6)
+ call nga_get(g_a, lo_col, hi_col,ZFIELD_GA(1,1) , ld_col)
+ PFIELD = ZFIELD_GA
+ call ga_sync()
+ NULLIFY(TZFIELD_ll)
+ CALL ADD2DFIELD_ll(TZFIELD_ll,PFIELD )
+ CALL UPDATE_HALO_ll(TZFIELD_ll,IINFO_ll)
+ CALL CLEANLIST_ll(TZFIELD_ll)
+ DEALLOCATE(ZFIELD_GA)
#else
- ! XY Scatter Field
- CALL SCATTER_XYFIELD(ZFIELDP,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
+ ! XY Scatter Field
+ CALL SCATTER_XYFIELD(zfield2d,PFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
#endif
+ END IF
+ ELSE
+ if ( isp == tpfile%nmaster_rank ) pfield(:,:) = zfield2d(:,:)
+ CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MNHREAL_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
END IF
- ELSE
- CALL MPI_BCAST(PFIELD,SIZE(PFIELD),MNHREAL_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
END IF
CALL SECOND_MNH2(ZT2)
TIMEZ%T_READ2D_SCAT=TIMEZ%T_READ2D_SCAT + ZT2 - ZT1
END IF
END IF
!
-IF (GALLOC) DEALLOCATE (ZFIELDP)
-!
IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed)
!
IF (PRESENT(KRESP)) KRESP = IRESP
@@ -1521,7 +1522,6 @@ USE MODD_IO, ONLY: GSMONOPROC, ISP, LPACK, L1D, L2D
USE MODD_PARAMETERS_ll, ONLY: JPHEXT
USE MODD_TIMEZ, ONLY: TIMEZ
!
-USE MODE_ALLOCBUFFER_ll
USE MODE_SCATTER_ll
!
TYPE(TFILEDATA), INTENT(IN) :: TPFILE
@@ -1530,10 +1530,9 @@ INTEGER, DIMENSION(:,:), TARGET, INTENT(INOUT) :: KFIELD ! array containing th
INTEGER, OPTIONAL, INTENT(OUT) :: KRESP ! return-code
!
INTEGER :: IERR
-integer :: ifieldp0d
-integer, dimension(:), pointer :: ifieldp1d
-INTEGER, DIMENSION(:,:), POINTER :: IFIELDP
-LOGICAL :: GALLOC
+integer :: ifield0d
+integer, dimension(:), ALLOCATABLE :: ifield1d
+INTEGER, DIMENSION(:,:), ALLOCATABLE :: ifield2d
logical :: glfi, gnc4
INTEGER :: IRESP
INTEGER :: IHEXTOT
@@ -1541,9 +1540,7 @@ class(tfieldmetadata), allocatable :: tzfield
!
CALL PRINT_MSG(NVERB_DEBUG,'IO','IO_Field_read_byfield_N2',TRIM(TPFILE%CNAME)//': reading '//TRIM(TPFIELD%CMNHNAME))
!
-GALLOC = .FALSE.
IRESP = 0
-IFIELDP => NULL()
!
IHEXTOT = 2*JPHEXT+1
CALL IO_File_read_check(TPFILE,'IO_Field_read_byfield_N2',IRESP)
@@ -1553,45 +1550,49 @@ call IO_Format_read_select( tpfile, glfi, gnc4 )
IF (IRESP==0) THEN
IF (GSMONOPROC) THEN ! sequential execution
if ( lpack .and. l1d .and. Size( kfield, 1 ) == ihextot .and. Size( kfield, 2 ) == ihextot ) then
- Allocate( tzfield, source = tpfield )
+ allocate( tzfield, source = tpfield )
if ( tpfile%ldimreduced ) then
tzfield%ndims = tzfield%ndims - 2
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(1) = tzfield%ndimlist(3) !Necessary if time dimension
tzfield%ndimlist(2:) = NMNHDIM_UNUSED
end if
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifieldp0d, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifieldp0d, iresp )
- kfield(:, :) = Spread( Spread( ifieldp0d, dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifield0d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifield0d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ kfield(:, :) = Spread( Spread( ifield0d, dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
else
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(1:2) = NMNHDIM_ONE
end if
- ifieldp => kfield(jphext + 1 : jphext + 1, jphext + 1 : jphext + 1)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifieldp, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifieldp, iresp )
- kfield(:, :) = Spread( Spread( kfield(jphext + 1, jphext + 1), dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
+ allocate( ifield2d(1,1) )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifield2d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifield2d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ kfield(:, :) = Spread( Spread( ifield2d(1,1), dim = 1, ncopies = ihextot ), dim = 2, ncopies = ihextot )
endif
else if ( lpack .and. l2d .and. Size( kfield, 2 ) == ihextot ) then
- Allocate( tzfield, source = tpfield )
+ allocate( tzfield, source = tpfield )
if ( tpfile%ldimreduced ) then
tzfield%ndims = tzfield%ndims - 1
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(2) = tzfield%ndimlist(3) !Necessary if time dimension
tzfield%ndimlist(3:) = NMNHDIM_UNUSED
end if
- ifieldp1d => kfield(:, jphext + 1)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifieldp1d, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifieldp1d, iresp )
- kfield(:, :) = Spread( kfield(:, jphext + 1), dim = 2, ncopies = ihextot )
+ allocate( ifield1d(size(kfield,1)) )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifield1d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifield1d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ kfield(:, :) = Spread( ifield1d(:), dim = 2, ncopies = ihextot )
else
if ( tzfield%ndimlist(1) /= NMNHDIM_UNKNOWN ) then
tzfield%ndimlist(2) = NMNHDIM_ONE
end if
- ifieldp => kfield(:, jphext + 1 : jphext + 1)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifieldp, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifieldp, iresp )
- kfield(:, :) = Spread( kfield(:, jphext + 1), dim = 2, ncopies = ihextot )
+ allocate( ifield2d(size(kfield,1),1) )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tzfield, ifield2d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tzfield, ifield2d, iresp )
+ if ( iresp == 0 .or. iresp == -111 ) &
+ kfield(:, :) = Spread( ifield2d(:,1), dim = 2, ncopies = ihextot )
endif
else
if ( gnc4 ) call IO_Field_read_nc4( tpfile, tpfield, kfield, iresp )
@@ -1600,13 +1601,12 @@ IF (IRESP==0) THEN
ELSE
IF (ISP == TPFILE%NMASTER_RANK) THEN
! I/O process case
- CALL ALLOCBUFFER_ll(IFIELDP,KFIELD,TPFIELD%CDIR,GALLOC)
- if ( gnc4 ) call IO_Field_read_nc4( tpfile, tpfield, ifieldp, iresp )
- if ( glfi ) call IO_Field_read_lfi( tpfile, tpfield, ifieldp, iresp )
+ call Allocbuffer_ll( ifield2d, kfield, tpfield%cdir )
+ if ( gnc4 ) call IO_Field_read_nc4( tpfile, tpfield, ifield2d, iresp )
+ if ( glfi ) call IO_Field_read_lfi( tpfile, tpfield, ifield2d, iresp )
ELSE
!Not really necessary but useful to suppress alerts with Valgrind
- ALLOCATE(IFIELDP(0,0))
- GALLOC = .TRUE.
+ allocate( ifield2d(0,0) )
END IF
!
CALL MPI_BCAST(IRESP,1,MNHINT_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
@@ -1615,30 +1615,31 @@ IF (IRESP==0) THEN
!because metadata of field has been modified in IO_Field_read_xxx
IF (IRESP==-111) CALL IO_Field_metadata_bcast(TPFILE,TPFIELD)
!
- IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN
- ! XX or YY Scatter Field
- CALL SCATTER_XXFIELD(TPFIELD%CDIR,IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
- ! Broadcast Field
- CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MNHREAL_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
- ELSE IF (TPFIELD%CDIR == 'XY') THEN
- IF (LPACK .AND. L2D) THEN
- ! 2D compact case
- call Print_msg( NVERB_FATAL, 'GEN', 'IO_Field_read_byfield_N2', '2D not (yet) allowed for parallel execution' )
- CALL SCATTER_XXFIELD('XX',IFIELDP(:,1),KFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
- KFIELD(:,:) = SPREAD(KFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT)
+ !Share data only if no error
+ if ( iresp == 0 .or. iresp == -111 ) then
+ IF (TPFIELD%CDIR == 'XX' .OR. TPFIELD%CDIR == 'YY') THEN
+ ! XX or YY Scatter Field
+ CALL SCATTER_XXFIELD(TPFIELD%CDIR,ifield2d,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
+ ! Broadcast Field
+ CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MNHREAL_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
+ ELSE IF (TPFIELD%CDIR == 'XY') THEN
+ IF (LPACK .AND. L2D) THEN
+ ! 2D compact case
+ call Print_msg( NVERB_FATAL, 'GEN', 'IO_Field_read_byfield_N2', '2D not (yet) allowed for parallel execution' )
+ CALL SCATTER_XXFIELD('XX',ifield2d(:,1),KFIELD(:,JPHEXT+1),TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
+ KFIELD(:,:) = SPREAD(KFIELD(:,JPHEXT+1),DIM=2,NCOPIES=IHEXTOT)
+ ELSE
+ ! XY Scatter Field
+ CALL SCATTER_XYFIELD(ifield2d,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
+ END IF
ELSE
- ! XY Scatter Field
- CALL SCATTER_XYFIELD(IFIELDP,KFIELD,TPFILE%NMASTER_RANK,TPFILE%NMPICOMM)
+ if (isp == tpfile%nmaster_rank) kfield = ifield2d
+ CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MNHINT_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
END IF
- ELSE
- IF (ISP == TPFILE%NMASTER_RANK) KFIELD = IFIELDP
- CALL MPI_BCAST(KFIELD,SIZE(KFIELD),MNHINT_MPI,TPFILE%NMASTER_RANK-1,TPFILE%NMPICOMM,IERR)
- END IF
+ end if
END IF
END IF
!
-IF (GALLOC) DEALLOCATE (IFIELDP)
-!
IF (IRESP==-111) IRESP = 0 !-111 is not really an error (metadata has changed)
!
IF (PRESENT(KRESP)) KRESP = IRESP
--
GitLab