From 148d87593b4d3a42745a99951a7c2574c7928f9a Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Wed, 13 Sep 2023 17:56:08 -0400 Subject: [PATCH 01/86] added changes for hybrid --- base/Base/Base_Base_implementation.F90 | 567 ++++++++++++------------- gridcomps/Cap/MAPL_Cap.F90 | 17 +- 2 files changed, 284 insertions(+), 300 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 60126a5d0b26..e873bc264f85 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -119,13 +119,13 @@ end subroutine MAPL_AllocateCoupling module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & hw, ungrid, default_value, rc) type(ESMF_Field), intent(INOUT) :: field - integer, intent(IN ) :: dims - integer, intent(IN ) :: location + integer, intent(IN ) :: dims + integer, intent(IN ) :: location integer, intent(IN ) :: typekind integer, intent(IN ) :: hw !halowidth integer, optional, intent(IN ) :: ungrid(:) real, optional, intent(IN ) :: default_value - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status @@ -146,7 +146,14 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & integer :: lb1, lb2, lb3 integer :: ub1, ub2, ub3 - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) +! SSI + character(len=ESMF_MAXSTR) :: name + type(ESMF_Pin_Flag) :: pinflag + type(ESMF_VM) :: vm + logical :: ssiSharedMemoryEnabled +! SSI + + call ESMF_FieldGet(field, grid=GRID, name=name, RC=STATUS) _VERIFY(STATUS) call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) _VERIFY(STATUS) @@ -161,7 +168,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end do ! ALT: the next allocation should have been griddedDims, ! but this compilcates the code unnecessery - allocate(haloWidth(gridRank), stat=status) + allocate(haloWidth(gridRank), stat=status) _VERIFY(STATUS) haloWidth = (/HW,HW,0/) @@ -176,6 +183,18 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & szungrd = size(UNGRID) end if +! SSI + call ESMF_VMGetCurrent(vm, rc=status) + _VERIFY(status) + + call ESMF_VMGet(vm, ssiSharedMemoryEnabledFlag=ssiSharedMemoryEnabled, & + rc=status) + _VERIFY(status) + + _ASSERT(ssiSharedMemoryEnabled, 'SSI shared memory is NOT supported') + pinflag=ESMF_PIN_DE_TO_SSI_CONTIG ! requires support for SSI shared memory +! SSI + Dimensionality: select case(DIMS) ! Horizontal and vertical @@ -185,7 +204,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & rank = szungrd !ALT: This is special case - array does not map any gridded dims - gridToFieldMap= 0 + gridToFieldMap= 0 if (typekind == ESMF_KIND_R4) then select case (rank) case (1) @@ -274,77 +293,87 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then RankCase2d: select case (rank) case (2) - allocate(VAR_2D(lb1:ub1, lb2:ub2), STAT=STATUS) + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_2D, rc = status) _VERIFY(STATUS) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + case (3) + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) - case (3) - allocate(VAR_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) + ungriddedLBound=(/1/), ungriddedUBound=(/UNGRID(1)/), & + pinflag=pinflag,rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, rc = status) _VERIFY(STATUS) VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + case (4) + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) - case (4) - allocate(VAR_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) + ungriddedLBound=(/1,1/), ungriddedUBound=(/UNGRID(1),UNGRID(2)/), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, rc = status) _VERIFY(STATUS) VAR_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) case default - _FAIL( 'only up to 4D are supported') + _ASSERT(.false., 'only up to 4D are supported') end select RankCase2d else select case (rank) case (2) - allocate(VR8_2D(lb1:ub1, lb2:ub2), STAT=STATUS) - _VERIFY(STATUS) - VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_2D, rc = status) + _VERIFY(STATUS) + VR8_2D = INIT_VALUE case (3) - allocate(VR8_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) - VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=(/1/), ungriddedUBound=(/UNGRID(1)/), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, rc = status) + _VERIFY(STATUS) + VR8_3D = INIT_VALUE case (4) - allocate(VR8_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) - _VERIFY(STATUS) - VR8_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - totalLWidth=haloWidth(1:griddedDims), & - totalUWidth=haloWidth(1:griddedDims), & - rc = status) + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & + gridToFieldMap=gridToFieldMap, & + totalLWidth=haloWidth(1:griddedDims), & + totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=(/1,1/), ungriddedUBound=(/UNGRID(1),UNGRID(2)/), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, rc = status) + _VERIFY(STATUS) + VR8_4D = INIT_VALUE case default - _FAIL( 'only up to 4D are supported') + _ASSERT(.false., 'only up to 4D are supported') end select end if _VERIFY(STATUS) - ! Horz + Vert + ! Horz + Vert ! ----------- case(MAPL_DimsHorzVert) lb1 = 1-HW @@ -371,62 +400,65 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & RankCase3d: select case(rank) case (3) if (typekind == ESMF_KIND_R4) then - NULLIFY(VAR_3D) - allocate(VAR_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) - _VERIFY(STATUS) - VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) - else - NULLIFY(VR8_3D) - allocate(VR8_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) + ungriddedLBound=(/lb3/), ungriddedUBound=(/ub3/), & + pinflag=pinflag, rc = status) _VERIFY(STATUS) - VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, rc = status) + _VERIFY(STATUS) + VAR_3D = INIT_VALUE + else + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/lb3/), ungriddedUBound=(/ub3/), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, rc = status) + _VERIFY(STATUS) + VR8_3D = INIT_VALUE endif _VERIFY(STATUS) case (4) if (typekind == ESMF_KIND_R4) then - NULLIFY(VAR_4D) - allocate(VAR_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) - _VERIFY(STATUS) - VAR_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) - else - NULLIFY(VR8_4D) - allocate(VR8_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) + ungriddedLBound=(/lb3,1/), ungriddedUBound=(/ub3,ungrid(1)/), & + pinflag=pinflag, rc = status) _VERIFY(STATUS) - VR8_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_4D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, rc = status) + _VERIFY(STATUS) + VAR_4D = INIT_VALUE + else + !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) + call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + ungriddedLBound=(/lb3,1/), ungriddedUBound=(/ub3,ungrid(1)/), & + pinflag=pinflag, rc = status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, rc = status) + _VERIFY(STATUS) + VR8_4D = INIT_VALUE endif - _VERIFY(STATUS) case default _RETURN(ESMF_FAILURE) end select RankCase3d ! Tiles - ! ----- + ! ----- case(MAPL_DimsTileOnly) rank = 1 + szungrd _ASSERT(gridRank == 1, 'gridRank /= 1') @@ -522,7 +554,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & ! Invalid dimensionality ! ---------------------- - case default + case default _RETURN(ESMF_FAILURE) end select Dimensionality @@ -531,7 +563,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (present(default_value)) then call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & VALUE=MAPL_InitialDefault, RC=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) end if ! Clean up @@ -1297,7 +1329,6 @@ module subroutine MAPL_SetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromState - module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) type (ESMF_Field), intent(INOUT) :: FIELD !ALT: IN character(len=*), intent(IN ) :: NAME @@ -1305,10 +1336,10 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) integer, optional, intent( OUT) :: RC type (ESMF_Field) :: F - ! we are creating new field so that we can change the name of the field; - ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) - ! are the SAME as the one in the original Field, if DoCopy flag is present - ! and set to true we create a new array and copy the data, not just reference it + ! we are creating new field so that we can change the name of the field; + ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) + ! are the SAME as the one in the original Field, if DoCopy flag is present + ! and set to true we create a new array and copy the data, not just reference it type(ESMF_Grid) :: grid character(len=ESMF_MAXSTR) :: fieldName @@ -1322,22 +1353,21 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) integer :: notGridded logical :: DoCopy_ type(ESMF_DataCopy_Flag):: datacopy - real, pointer :: var_1d(:) - real, pointer :: var_2d(:,:) - real, pointer :: var_3d(:,:,:) - real, pointer :: var_4d(:,:,:,:) - real(kind=REAL64), pointer :: vr8_1d(:) - real(kind=REAL64), pointer :: vr8_2d(:,:) - real(kind=REAL64), pointer :: vr8_3d(:,:,:) - real(kind=REAL64), pointer :: vr8_4d(:,:,:,:) + type(ESMF_Array) :: array + real, pointer :: var_1d(:), var_2d(:,:) + real(kind=REAL64), pointer :: vr8_1d(:), vr8_2d(:,:) type(ESMF_TypeKind_Flag) :: tk +! SSI + integer, allocatable :: ulb(:), uub(:) +! SSI + DoCopy_ = .false. if (present(DoCopy) ) then DoCopy_ = DoCopy end if - call ESMF_FieldGet(FIELD, grid=GRID, dimCount=fieldRank, & + call ESMF_FieldGet(FIELD, grid=GRID, array=array, dimCount=fieldRank, & name=fieldName, RC=STATUS) _VERIFY(STATUS) call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) @@ -1350,98 +1380,95 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) hasUngridDims = .false. notGridded = count(gridToFieldMap==0) unGridDims = fieldRank - gridRank + notGridded + !if(MAPL_AM_I_ROOT()) print '(a,i6,6i3,a)', __FILE__, __LINE__, fieldRank, gridRank, notGridded, unGridDims, gridToFieldMap, " "//trim(fieldName) if (unGridDims > 0) then - hasUngridDims = .true. + !hasUngridDims = .true. + allocate(ulb(unGridDims), stat=status) + _VERIFY(STATUS) + allocate(uub(unGridDims), stat=status) + _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, ungriddedLBound=ulb, ungriddedUBound=uub, & + RC=STATUS) + _VERIFY(STATUS) endif - if (doCopy_) then + + if (doCopy_) then datacopy = ESMF_DATACOPY_VALUE else datacopy = ESMF_DATACOPY_REFERENCE end if - f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, rc=status) - _VERIFY(STATUS) - - if (tk == ESMF_TypeKind_R4) then - select case (fieldRank) - case (1) - call ESMF_FieldGet(field, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (2) - call ESMF_FieldGet(field, farrayPtr=var_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (3) - call ESMF_FieldGet(field, farrayPtr=var_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_3D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (4) - call ESMF_FieldGet(field, farrayPtr=var_4d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_4D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case default - _FAIL( 'only upto 4D are supported') - end select - else if (tk == ESMF_TypeKind_R8) then - select case (fieldRank) + select case (fieldRank) case (1) - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) + f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, rc=status) _VERIFY(STATUS) + if (tk == ESMF_TypeKind_R4) then + call ESMF_FieldGet(field, farrayPtr=var_1d, rc=status) + _VERIFY(STATUS) + call ESMF_FieldEmptyComplete(F, farrayPtr=var_1d, & + gridToFieldMap=gridToFieldMap, & + datacopyFlag = datacopy, & + rc = status) + _VERIFY(STATUS) + else if (tk == ESMF_TypeKind_R8) then + call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) + _VERIFY(STATUS) + call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_1D, & + gridToFieldMap=gridToFieldMap, & + datacopyFlag = datacopy, & + rc = status) + _VERIFY(STATUS) + else + _ASSERT(.false., 'unsupported typekind') + endif case (2) - call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (3) - call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_3D, & + if (unGridDims == 0) then + !if(MAPL_AM_I_ROOT()) print '(a,i6,6i3,a)', __FILE__, __LINE__, fieldRank, gridRank, notGridded, unGridDims, gridToFieldMap, " "//trim(fieldName) + F = ESMF_FieldCreate(grid, array, & + gridToFieldMap=gridToFieldMap, & + datacopyFlag = datacopy, & + name=NAME, rc = status) + _VERIFY(STATUS) + else ! To handle some tile arrays + f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, _RC) + if (tk == ESMF_TypeKind_R4) then + call ESMF_FieldGet(field, farrayPtr=var_2d, _RC) + call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & + gridToFieldMap=gridToFieldMap, & + datacopyFlag = datacopy, _RC) + else if (tk == ESMF_TypeKind_R8) then + call ESMF_FieldGet(field, farrayPtr=vr8_2d, _RC) + call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_2D, & + gridToFieldMap=gridToFieldMap, & + datacopyFlag = datacopy, _RC) + endif + endif + case (3) ! Third dimension is assumed ungridded + F = ESMF_FieldCreate(grid, array, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (4) - call ESMF_FieldGet(field, farrayPtr=vr8_4d, rc=status) + ungriddedLBound=(/ulb(1)/), & + ungriddedUBound=(/uub(1)/), & + name=NAME, rc = status) _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_4D, & + case (4) ! Third and fourth dimensions are assumed ungridded + F = ESMF_FieldCreate(grid, array, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) + ungriddedLBound=(/ulb(1), ulb(2)/), & + ungriddedUBound=(/uub(1), uub(2)/), & + name=NAME, rc = status) _VERIFY(STATUS) case default - _FAIL( 'only 2D and 3D are supported') - end select - else - _FAIL( 'unsupported typekind') - endif + _ASSERT(.false., 'only upto 4D are supported') + end select + if (unGridDims > 0) then + deallocate(ulb) + deallocate(uub) + endif deallocate(gridToFieldMap) call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) @@ -3611,151 +3638,107 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) integer :: fieldRank integer, allocatable :: gridToFieldMap(:) integer, allocatable :: ungrd(:) + integer, allocatable :: localMinIndex(:), localMaxIndex(:) real, pointer :: ptr4d(:,:,:,:) => null() real, pointer :: ptr3d(:,:,:) => null() real, pointer :: ptr2d(:,:) => null() type(ESMF_Field) :: f, fld type(ESMF_Grid) :: grid + type(ESMF_Array) :: array, arraySlice type(ESMF_TypeKind_Flag) :: tk + integer, pointer :: ungl(:), ungu(:) character(len=ESMF_MAXSTR) :: name character(len=ESMF_MAXSTR) :: splitName character(len=ESMF_MAXSTR), allocatable :: splitNameArray(:) character(len=ESMF_MAXSTR) :: longName - ! get ptr - ! loop over 3-d or 4-d dim - ! create 2d or 3d field - ! put in state/bundle - ! end-of-loop - call ESMF_FieldGet(field, name=name, grid=grid, typekind=tk, rc=status) - _VERIFY(STATUS) + type(ESMF_Index_Flag) :: arrayIndexFlag, gridIndexFlag - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, grid=grid, typekind=tk, _RC) + + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) + call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, _RC) + + call ESMF_FieldGet(FIELD, dimCount=fieldRank, _RC) if (tk == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(FIELD, dimCount=fieldRank, rc=status) - _VERIFY(STATUS) if (fieldRank == 4) then + !ALT: get the pointer on the first PET + call ESMF_FieldGet(Field,0,ptr4D,_RC) + allocate(ungl(1), ungu(1), _STAT) + ungl(1)=lbound(ptr4d,3) + ungu(1)=ubound(ptr4d,3) + else if (fieldRank == 3) then + ungl => NULL() ! to emulate 'not present' argument + ungu => NULL() + call ESMF_FieldGet(Field,0,ptr3D,_RC) + else + _ASSERT(.false., 'unsupported rank') + end if + else + _ASSERT(.false., 'unsupported typekind') + end if - !ALT: assumes 1 DE per PET - call ESMF_FieldGet(Field,0,ptr4D,rc=status) - _VERIFY(STATUS) - n = size(ptr4d,4) - allocate(fields(n), stat=status) - _VERIFY(STATUS) - n = 0 - k1=lbound(ptr4d,4) - k2=ubound(ptr4d,4) - kk = k2-k1+1 - call genAlias(name, kk, splitNameArray, aliasName=aliasName,rc=status) - _VERIFY(STATUS) + allocate(localMinIndex(fieldRank),localMaxIndex(fieldRank), _STAT) + call ESMF_FieldGet(Field, array=array,& + localMinIndex=localMinIndex, localMaxIndex=localMaxIndex, _RC) - do k=k1,k2 - n = n+1 - ptr3d => ptr4d(:,:,:,k) - ! create a new field - splitName = splitNameArray(n) - f = MAPL_FieldCreateEmpty(name=splitName, grid=grid, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=ptr3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) - ! copy attributes and adjust as necessary - fld = field ! shallow copy to get around intent(in/out) - call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + k1 = localMinIndex(fieldRank) + k2 = localMaxIndex(fieldRank) + deallocate(localMinIndex,localMaxIndex) - ! adjust ungridded dims attribute (if any) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) - if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) - if (ungrd_cnt > 1) then - ungrd_cnt = ungrd_cnt - 1 - call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) - else - has_ungrd = .false. - end if - deallocate(ungrd) - end if + n = k2 - k1 + 1 - fields(n) = f - end do - else if (fieldRank == 3) then - !ALT: assumes 1 DE per PET - call ESMF_FieldGet(Field,0,ptr3D,rc=status) + allocate(fields(n), _STAT) + + call genAlias(name, n, splitNameArray, aliasName=aliasName,_RC) + _VERIFY(STATUS) + + n = 0 + do k=k1,k2 + n = n+1 + splitName = splitNameArray(n) + arraySlice = ESMF_ArrayCreate(array, & + datacopyFlag=ESMF_DATACOPY_REFERENCE, & + trailingUndistSlice=[k], _RC) + ! create a new field + f = ESMF_FieldCreate(name=splitName, grid=grid, & + array=arraySlice, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & + gridToFieldMap=gridToFieldMap, & + ungriddedLBound=ungl, ungriddedUBound=ungu, _RC) + + ! copy attributes and adjust as necessary + fld = field ! shallow copy to get around intent(in/out) + call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, _RC) + + ! adjust ungridded dims attribute (if any) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) + if (has_ungrd) then + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) _VERIFY(STATUS) - n = size(ptr3d,3) - allocate(fields(n), stat=status) + allocate(ungrd(UNGRD_CNT), stat=status) _VERIFY(STATUS) - n = 0 - k1=lbound(ptr3d,3) - k2=ubound(ptr3d,3) - kk = k2-k1+1 - call genAlias(name, kk, splitNameArray, aliasName=aliasName,rc=status) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) _VERIFY(STATUS) - do k=k1,k2 - n = n+1 - ptr2d => ptr3d(:,:,k) - ! create a new field - splitName = splitNameArray(n) - f = MAPL_FieldCreateEmpty(name=splitName, grid=grid, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=ptr2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) - ! copy attributes and adjust as necessary - fld = field ! shallow copy to get around intent(in/out) - call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) - - ! adjust ungridded dims attribute (if any) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) + call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) + _VERIFY(STATUS) + if (ungrd_cnt > 1) then + ungrd_cnt = ungrd_cnt - 1 + call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & + valueList=UNGRD(1:ungrd_cnt), RC=STATUS) _VERIFY(STATUS) - if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) - if (ungrd_cnt > 1) then - ungrd_cnt = ungrd_cnt - 1 - call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) - else - has_ungrd = .false. - end if - deallocate(ungrd) - end if - - fields(n) = f - end do + else + has_ungrd = .false. + end if + deallocate(ungrd) end if - else if (tk == ESMF_TYPEKIND_R8) then - _FAIL( "R8 overload not implemented yet") - end if + + fields(n) = f + end do + if (associated(ungl)) deallocate(ungl) + if (associated(ungu)) deallocate(ungu) deallocate(gridToFieldMap) deallocate(splitNameArray) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index dbb2640df122..b75e13d952f4 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -435,21 +435,22 @@ subroutine initialize_mpi(this, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: ierror + integer :: ierror, status integer :: provided integer :: npes_world _UNUSED_DUMMY(unusable) - call MPI_Initialized(this%mpi_already_initialized, ierror) - _VERIFY(ierror) + !call MPI_Initialized(this%mpi_already_initialized, ierror) + !_VERIFY(ierror) + call ESMF_InitializePreMPI(_RC) if (.not. this%mpi_already_initialized) then -!!$ call MPI_Init_thread(MPI_THREAD_MULTIPLE, provided, ierror) -!!$ _ASSERT(provided == MPI_THREAD_MULTIPLE, 'MPI_THREAD_MULTIPLE not supporte by this MPI.') - call MPI_Init_thread(MPI_THREAD_SINGLE, provided, ierror) - _VERIFY(ierror) - _ASSERT(provided == MPI_THREAD_SINGLE, "MPI_THREAD_SINGLE not supported by this MPI.") + call MPI_Init_thread(MPI_THREAD_MULTIPLE, provided, ierror) + _ASSERT(provided == MPI_THREAD_MULTIPLE, 'MPI_THREAD_MULTIPLE not supporte by this MPI.') +! call MPI_Init_thread(MPI_THREAD_SINGLE, provided, ierror) +! _VERIFY(ierror) +! _ASSERT(provided == MPI_THREAD_SINGLE, "MPI_THREAD_SINGLE not supported by this MPI.") end if call MPI_Comm_rank(this%comm_world, this%rank, ierror); _VERIFY(ierror) From 0dcd0fd3abfc5630b2f017057493d4e2a9a1e2d7 Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Thu, 14 Sep 2023 11:31:36 -0400 Subject: [PATCH 02/86] Reversed a code change wrongly made in MultiGroupServer.F90 --- pfio/MultiGroupServer.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index d9b188adeb11..9fe61430bb41 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -558,9 +558,9 @@ subroutine dispatch_work(collection_id, idleRank, num_idlePEs, FileName, rc) node_rank = maxloc(num_idlePEs, dim=1) - 1 do i = 0, nwriter_per_node -1 if (idleRank(node_rank,i) /= -1) then + idle_writer = idleRank(node_rank,i) idleRank(node_rank,i) = -1 ! set to -1 when it becomes busy num_idlePEs(node_rank) = num_idlePEs(node_rank)-1 - idle_writer = idleRank(node_rank,i) exit end if enddo From c36ff9fcc8ccb218ab9fc49997d6d839489c2125 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 3 Oct 2023 10:30:02 -0400 Subject: [PATCH 03/86] Fixes for NVHPC --- Apps/Regrid_Util.F90 | 2 +- CHANGELOG.md | 2 ++ docs/tutorial/driver_app/Example_Driver.F90 | 1 + generic/OpenMP_Support.F90 | 5 ++++- gridcomps/Cap/FargparseCLI.F90 | 8 ++++---- .../History/MAPL_HistoryTrajectoryMod.F90 | 6 +++--- .../MAPL_HistoryTrajectoryMod_smod.F90 | 4 ++-- griddedio/TileIO.F90 | 20 +++++++++---------- 8 files changed, 27 insertions(+), 21 deletions(-) diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index 7a247d05c615..5ce9f17d2d44 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -338,7 +338,7 @@ Program Regrid_Util subroutine main() - type(regrid_support) :: support + type(regrid_support), target :: support type(ESMF_VM) :: vm ! ESMF Virtual Machine diff --git a/CHANGELOG.md b/CHANGELOG.md index 71812fc383f8..05a14a0a6bc9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Various fixes for NVHPCP work + ### Removed ### Deprecated diff --git a/docs/tutorial/driver_app/Example_Driver.F90 b/docs/tutorial/driver_app/Example_Driver.F90 index f974d002a624..b967506b94c0 100644 --- a/docs/tutorial/driver_app/Example_Driver.F90 +++ b/docs/tutorial/driver_app/Example_Driver.F90 @@ -5,6 +5,7 @@ program Example_Driver use MPI use MAPL + use mapl_CapOptionsMod, only: MAPL_CapOptions implicit none type (MAPL_Cap) :: cap diff --git a/generic/OpenMP_Support.F90 b/generic/OpenMP_Support.F90 index a6919efa4182..a00d53e3c4b8 100644 --- a/generic/OpenMP_Support.F90 +++ b/generic/OpenMP_Support.F90 @@ -595,6 +595,7 @@ subroutine copy_callbacks(state, multi_states, rc) type(CallbackMethodWrapper), pointer :: wrapper type(CallbackMap), pointer :: callbacks type(CallbackMapIterator) :: iter + procedure(), pointer :: userRoutine n_multi = size(multi_states) call get_callbacks(state, callbacks, _RC) @@ -604,7 +605,9 @@ subroutine copy_callbacks(state, multi_states, rc) do while (iter /= e) wrapper => iter%second() do i = 1, n_multi - call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=wrapper%userRoutine, _RC) + !call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=wrapper%userRoutine, _RC) + userRoutine => wrapper%userRoutine + call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=userRoutine, _RC) end do call iter%next() end do diff --git a/gridcomps/Cap/FargparseCLI.F90 b/gridcomps/Cap/FargparseCLI.F90 index 68360a1b0a5f..a20695b722fb 100644 --- a/gridcomps/Cap/FargparseCLI.F90 +++ b/gridcomps/Cap/FargparseCLI.F90 @@ -8,7 +8,7 @@ module MAPL_FargparseCLIMod use gFTL2_IntegerVector use mapl_KeywordEnforcerMod use mapl_ExceptionHandling - use mapl_CapOptionsMod, only: MAPL_CapOptions !Rename is for backward compatibility. Remove renaming for 3.0 + use mapl_CapOptionsMod, only: MAPL_CapOptions_ => MAPL_CapOptions !Rename is for backward compatibility. Remove renaming for 3.0 implicit none private @@ -45,7 +45,7 @@ subroutine I_extraoptions(parser, rc) function new_CapOptions_from_fargparse(unusable, dummy, extra, rc) result (cap_options) class(KeywordEnforcer), optional, intent(in) :: unusable - type (MAPL_CapOptions) :: cap_options + type (MAPL_CapOptions_) :: cap_options character(*), intent(in) :: dummy !Needed for backward compatibility. Remove after 3.0 procedure(I_extraoptions), optional :: extra integer, optional, intent(out) :: rc @@ -230,7 +230,7 @@ end subroutine add_command_line_options subroutine fill_cap_options(fargparseCLI, cap_options, unusable, rc) class(MAPL_FargparseCLI), intent(inout) :: fargparseCLI - type(MAPL_CapOptions), intent(out) :: cap_options + type(MAPL_CapOptions_), intent(out) :: cap_options class(KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc integer :: status @@ -416,7 +416,7 @@ end subroutine fill_cap_options !Function for backward compatibility. Remove for 3.0 function old_CapOptions_from_Fargparse( fargparseCLI, unusable, rc) result (cap_options) - type (MAPL_CapOptions) :: cap_options + type (MAPL_CapOptions_) :: cap_options type (MAPL_FargparseCLI), intent(inout) :: fargparseCLI class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index aa5755f6aaf7..f9722b7693f4 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -78,7 +78,7 @@ module HistoryTrajectoryMod integer :: obsfile_Te_index logical :: is_valid contains - procedure :: initialize + procedure :: initialize => initialize_ procedure :: reinitialize procedure :: create_variable => create_metadata_variable procedure :: create_file_handle @@ -113,7 +113,7 @@ module function HistoryTrajectory_from_config(config,string,clock,rc) result(tra integer, optional, intent(out) :: rc end function HistoryTrajectory_from_config - module subroutine initialize(this,items,bundle,timeInfo,vdata,recycle_track,rc) + module subroutine initialize_(this,items,bundle,timeInfo,vdata,recycle_track,rc) class(HistoryTrajectory), intent(inout) :: this type(GriddedIOitemVector), target, intent(inout) :: items type(ESMF_FieldBundle), intent(inout) :: bundle @@ -121,7 +121,7 @@ module subroutine initialize(this,items,bundle,timeInfo,vdata,recycle_track,rc) type(VerticalData), optional, intent(inout) :: vdata logical, optional, intent(inout) :: recycle_track integer, optional, intent(out) :: rc - end subroutine initialize + end subroutine initialize_ module subroutine reinitialize(this,rc) class(HistoryTrajectory), intent(inout) :: this diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index 3760c8b54cbf..9a4e30309310 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -140,7 +140,7 @@ end procedure - module procedure initialize + module procedure initialize_ integer :: status type(ESMF_Grid) :: grid type(variable) :: v @@ -223,7 +223,7 @@ _RETURN(_SUCCESS) - end procedure initialize + end procedure initialize_ module procedure reinitialize diff --git a/griddedio/TileIO.F90 b/griddedio/TileIO.F90 index 7b55aca9609c..88a5a518c1d5 100644 --- a/griddedio/TileIO.F90 +++ b/griddedio/TileIO.F90 @@ -12,6 +12,10 @@ module MAPL_TileIOMod private + type tile_buffer + real, allocatable :: ptr(:) + end type + type, public :: MAPL_TileIO private type(ESMF_FieldBundle) :: bundle @@ -22,10 +26,6 @@ module MAPL_TileIOMod procedure :: process_data_from_file end type MAPL_TileIO - type tile_buffer - real, allocatable :: ptr(:) - end type - interface MAPL_TileIO module procedure new_MAPL_TileIO end interface MAPL_TileIO @@ -40,13 +40,13 @@ function new_MAPL_TileIO(bundle,read_collection_id) result(TileIO) TileIO%bundle = bundle TileIO%read_collection_id = read_collection_id end function - + subroutine request_data_from_file(this,filename,timeindex,rc) class(MAPL_TileIO), intent(inout) :: this character(len=*), intent(in) :: filename integer, intent(in) :: timeindex integer, intent(out), optional :: rc - + integer :: status integer :: num_vars,i,rank type(ArrayReference) :: ref @@ -76,10 +76,10 @@ subroutine request_data_from_file(this,filename,timeindex,rc) allocate(this%tile_buffer(i)%ptr((0)),_STAT) end if ref = ArrayReference(this%tile_buffer(i)%ptr) - call i_clients%collective_prefetch_data(this%read_collection_id, filename, trim(names(i)), ref, & + call i_clients%collective_prefetch_data(this%read_collection_id, filename, trim(names(i)), ref, & start=local_start, global_start=global_start, global_count = global_count) - deallocate(local_start,global_start,global_count) - else + deallocate(local_start,global_start,global_count) + else _FAIL("rank >1 tile fields not supported") end if end do @@ -117,5 +117,5 @@ subroutine process_data_from_file(this,rc) deallocate(this%tile_buffer) _RETURN(_SUCCESS) end subroutine - + end module From 7a479afc23553e36f9d9ed1aff7a8e4930f070ad Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 4 Oct 2023 11:54:30 -0400 Subject: [PATCH 04/86] Submodule issue --- gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index 9a4e30309310..704c2fb28993 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -540,7 +540,9 @@ if (mapl_am_I_root()) then - call sort_multi_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) + ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time + !call sort_multi_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) + call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) call ESMF_ClockGet(this%clock,currTime=current_time,_RC) timeset(1) = current_time timeset(2) = current_time + this%epoch_frequency From d3fee4116d13551cb1915963d1533e28c205dd28 Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Tue, 28 Nov 2023 00:18:46 -0500 Subject: [PATCH 05/86] Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field --- base/Base/Base_Base_implementation.F90 | 401 ++++++++----------------- 1 file changed, 122 insertions(+), 279 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 151616a5ffd6..b422c44f098c 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -192,9 +192,12 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_1D(UNGRID(1)), STAT=STATUS) _VERIFY(STATUS) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & rc = status) case default _FAIL( 'unsupported rank > 1') @@ -206,9 +209,12 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VR8_1D(UNGRID(1)), STAT=STATUS) _VERIFY(STATUS) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & rc = status) case default _FAIL( 'unsupported rank > 1') @@ -242,8 +248,12 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & _VERIFY(STATUS) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=var_1d, & + call ESMF_FieldEmptyComplete(FIELD, farray=var_1d, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & + ungriddedLBound=[lb1],& + ungriddedUBound=[ub1], & RC=status) _VERIFY(STATUS) else @@ -251,8 +261,12 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & _VERIFY(STATUS) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=vr8_1d, & + call ESMF_FieldEmptyComplete(FIELD, farray=vr8_1d, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & + ungriddedLBound=[lb1],& + ungriddedUBound=[ub1], & RC=status) _VERIFY(STATUS) end if @@ -277,7 +291,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_2D(lb1:ub1, lb2:ub2), STAT=STATUS) _VERIFY(STATUS) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & @@ -287,21 +302,27 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) _VERIFY(STATUS) VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & rc = status) case (4) allocate(VAR_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) _VERIFY(STATUS) VAR_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_4D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_4D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[1,1],& + ungriddedUBound=[ungrid(1),ungrid(2)], & rc = status) case default _FAIL( 'only up to 4D are supported') @@ -312,7 +333,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VR8_2D(lb1:ub1, lb2:ub2), STAT=STATUS) _VERIFY(STATUS) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & @@ -322,21 +344,27 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VR8_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) _VERIFY(STATUS) VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & rc = status) case (4) allocate(VR8_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) _VERIFY(STATUS) VR8_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_4D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_4D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[1,1],& + ungriddedUBound=[ungrid(1),ungrid(2)], & rc = status) case default _FAIL( 'only up to 4D are supported') @@ -375,22 +403,28 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) _VERIFY(STATUS) VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[lb3],& + ungriddedUBound=[ub3], & rc = status) else NULLIFY(VR8_3D) allocate(VR8_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) _VERIFY(STATUS) VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[lb3],& + ungriddedUBound=[ub3], & rc = status) endif _VERIFY(STATUS) @@ -401,22 +435,28 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) _VERIFY(STATUS) VAR_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_4D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_4D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[lb3,1],& + ungriddedUBound=[ub3,ungrid(1)], & rc = status) else NULLIFY(VR8_4D) allocate(VR8_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) _VERIFY(STATUS) VR8_4D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_4D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_4D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & + ungriddedLBound=[lb3,1],& + ungriddedUBound=[ub3,ungrid(1)], & rc = status) endif _VERIFY(STATUS) @@ -437,14 +477,16 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_1D(COUNTS(1)), STAT=STATUS) _VERIFY(STATUS) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & rc = status) case (2) allocate(VAR_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) _VERIFY(STATUS) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & rc = status) @@ -453,7 +495,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & STAT=STATUS) _VERIFY(STATUS) VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & rc = status) @@ -467,14 +510,16 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VR8_1D(COUNTS(1)), STAT=STATUS) _VERIFY(STATUS) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_1D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & rc = status) case (2) allocate(VR8_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) _VERIFY(STATUS) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & rc = status) @@ -483,7 +528,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & STAT=STATUS) _VERIFY(STATUS) VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & rc = status) @@ -502,7 +548,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VAR_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) _VERIFY(STATUS) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & @@ -511,7 +558,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & allocate(VR8_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) _VERIFY(STATUS) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & @@ -1275,139 +1323,23 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) ! are the SAME as the one in the original Field, if DoCopy flag is present ! and set to true we create a new array and copy the data, not just reference it - type(ESMF_Grid) :: grid - character(len=ESMF_MAXSTR) :: fieldName - integer, allocatable :: gridToFieldMap(:) - integer :: gridRank - integer :: fieldRank integer :: status - integer :: unGridDims character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_FieldCreateRename' - logical :: hasUngridDims - integer :: notGridded logical :: DoCopy_ type(ESMF_DataCopy_Flag):: datacopy - real, pointer :: var_1d(:) - real, pointer :: var_2d(:,:) - real, pointer :: var_3d(:,:,:) - real, pointer :: var_4d(:,:,:,:) - real(kind=REAL64), pointer :: vr8_1d(:) - real(kind=REAL64), pointer :: vr8_2d(:,:) - real(kind=REAL64), pointer :: vr8_3d(:,:,:) - real(kind=REAL64), pointer :: vr8_4d(:,:,:,:) - type(ESMF_TypeKind_Flag) :: tk DoCopy_ = .false. if (present(DoCopy) ) then DoCopy_ = DoCopy end if - call ESMF_FieldGet(FIELD, grid=GRID, dimCount=fieldRank, & - name=fieldName, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, typekind=tk, RC=STATUS) - _VERIFY(STATUS) - - hasUngridDims = .false. - notGridded = count(gridToFieldMap==0) - unGridDims = fieldRank - gridRank + notGridded - - if (unGridDims > 0) then - hasUngridDims = .true. - endif - if (doCopy_) then datacopy = ESMF_DATACOPY_VALUE else datacopy = ESMF_DATACOPY_REFERENCE end if - f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, rc=status) - _VERIFY(STATUS) - - if (tk == ESMF_TypeKind_R4) then - select case (fieldRank) - case (1) - call ESMF_FieldGet(field, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (2) - call ESMF_FieldGet(field, farrayPtr=var_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (3) - call ESMF_FieldGet(field, farrayPtr=var_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_3D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (4) - call ESMF_FieldGet(field, farrayPtr=var_4d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_4D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case default - _FAIL( 'only upto 4D are supported') - end select - else if (tk == ESMF_TypeKind_R8) then - select case (fieldRank) - case (1) - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (2) - call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (3) - call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_3D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case (4) - call ESMF_FieldGet(field, farrayPtr=vr8_4d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_4D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - case default - _FAIL( 'only 2D and 3D are supported') - end select - else - _FAIL( 'unsupported typekind') - endif - - deallocate(gridToFieldMap) + f = ESMF_FieldCreate(field, datacopyflag=datacopy, name=NAME, _RC) call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) _VERIFY(STATUS) @@ -3210,7 +3142,7 @@ function grid_is_ok(grid) result(OK) type(ESMF_Grid), intent(inout) :: grid logical :: OK integer :: I1, I2, J1, J2, j - real(ESMF_KIND_R8), pointer :: corner_lons(:,:), corner_lats(:,:) + real(ESMF_KIND_R8), allocatable :: corner_lons(:,:), corner_lats(:,:) real(ESMF_KIND_R8) :: accurate_lat, accurate_lon real :: tolerance @@ -3218,11 +3150,9 @@ function grid_is_ok(grid) result(OK) call MAPL_GridGetInterior(grid,I1,I2,J1,J2) OK = .true. ! check the edge of face 1 along longitude - call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner_lons, rc=status) - call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner_lats, rc=status) - + allocate(corner_lons(I2-I1+2, J2-J1+2)) + allocate(corner_lats(I2-I1+2, J2-J1+2)) + call MAPL_GridGetCorners(Grid,corner_lons,corner_lats) if ( I1 ==1 .and. J2<=IM_WORLD ) then if (J1 == 1) then accurate_lon = 1.750d0*MAPL_PI_R8 - shift @@ -3235,7 +3165,7 @@ function grid_is_ok(grid) result(OK) endif endif - do j = J1+1, J2 + do j = J1, J2+1 accurate_lat = -alpha + (j-1)*dalpha if ( abs(accurate_lat - corner_lats(1,j-J1+1)) > 5.0*tolerance) then print*, "accurate_lat: ", accurate_lat @@ -3570,160 +3500,73 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) integer :: status integer :: k, n integer :: k1,k2,kk - integer :: gridRank - logical :: has_ungrd integer :: ungrd_cnt integer :: fieldRank - integer, allocatable :: gridToFieldMap(:) integer, allocatable :: ungrd(:) - real, pointer :: ptr4d(:,:,:,:) => null() - real, pointer :: ptr3d(:,:,:) => null() - real, pointer :: ptr2d(:,:) => null() + integer, allocatable :: localMinIndex(:), localMaxIndex(:) type(ESMF_Field) :: f, fld - type(ESMF_Grid) :: grid - type(ESMF_TypeKind_Flag) :: tk character(len=ESMF_MAXSTR) :: name character(len=ESMF_MAXSTR) :: splitName character(len=ESMF_MAXSTR), allocatable :: splitNameArray(:) character(len=ESMF_MAXSTR) :: longName - ! get ptr - ! loop over 3-d or 4-d dim - ! create 2d or 3d field - ! put in state/bundle - ! end-of-loop - call ESMF_FieldGet(field, name=name, grid=grid, typekind=tk, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, dimCount=fieldRank, _RC) - if (tk == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(FIELD, dimCount=fieldRank, rc=status) - _VERIFY(STATUS) - if (fieldRank == 4) then + allocate(localMinIndex(fieldRank),localMaxIndex(fieldRank), _STAT) + call ESMF_FieldGet(Field, & + localMinIndex=localMinIndex, localMaxIndex=localMaxIndex, _RC) - !ALT: assumes 1 DE per PET - call ESMF_FieldGet(Field,0,ptr4D,rc=status) - _VERIFY(STATUS) - n = size(ptr4d,4) - allocate(fields(n), stat=status) - _VERIFY(STATUS) - n = 0 - k1=lbound(ptr4d,4) - k2=ubound(ptr4d,4) - kk = k2-k1+1 - call genAlias(name, kk, splitNameArray, aliasName=aliasName,rc=status) - _VERIFY(STATUS) + k1 = localMinIndex(fieldRank) + k2 = localMaxIndex(fieldRank) + deallocate(localMinIndex,localMaxIndex) - do k=k1,k2 - n = n+1 - ptr3d => ptr4d(:,:,:,k) - ! create a new field - splitName = splitNameArray(n) - f = MAPL_FieldCreateEmpty(name=splitName, grid=grid, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=ptr3D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) - ! copy attributes and adjust as necessary - fld = field ! shallow copy to get around intent(in/out) - call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + n = k2 - k1 + 1 - ! adjust ungridded dims attribute (if any) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) - if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) - if (ungrd_cnt > 1) then - ungrd_cnt = ungrd_cnt - 1 - call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) - else - has_ungrd = .false. - end if - deallocate(ungrd) - end if + allocate(fields(n), _STAT) - fields(n) = f - end do - else if (fieldRank == 3) then - !ALT: assumes 1 DE per PET - call ESMF_FieldGet(Field,0,ptr3D,rc=status) + call genAlias(name, n, splitNameArray, aliasName=aliasName,_RC) + _VERIFY(STATUS) + + n = 0 + do k=k1,k2 + n = n+1 + splitName = splitNameArray(n) + f = ESMF_FieldCreate(field, & + datacopyflag=ESMF_DATACOPY_REFERENCE, & + trailingUngridSlice=[k], name=splitName, _RC) + + ! copy attributes and adjust as necessary + fld = field ! shallow copy to get around intent(in/out) + call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, _RC) + + ! adjust ungridded dims attribute (if any) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) + if (has_ungrd) then + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) _VERIFY(STATUS) - n = size(ptr3d,3) - allocate(fields(n), stat=status) + allocate(ungrd(UNGRD_CNT), stat=status) _VERIFY(STATUS) - n = 0 - k1=lbound(ptr3d,3) - k2=ubound(ptr3d,3) - kk = k2-k1+1 - call genAlias(name, kk, splitNameArray, aliasName=aliasName,rc=status) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) _VERIFY(STATUS) - do k=k1,k2 - n = n+1 - ptr2d => ptr3d(:,:,k) - ! create a new field - splitName = splitNameArray(n) - f = MAPL_FieldCreateEmpty(name=splitName, grid=grid, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=ptr2D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) - ! copy attributes and adjust as necessary - fld = field ! shallow copy to get around intent(in/out) - call MAPL_FieldCopyAttributes(FIELD_IN=fld, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) - - ! adjust ungridded dims attribute (if any) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) + call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) + _VERIFY(STATUS) + if (ungrd_cnt > 1) then + ungrd_cnt = ungrd_cnt - 1 + call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & + valueList=UNGRD(1:ungrd_cnt), RC=STATUS) _VERIFY(STATUS) - if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) - if (ungrd_cnt > 1) then - ungrd_cnt = ungrd_cnt - 1 - call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) - else - has_ungrd = .false. - end if - deallocate(ungrd) - end if - - fields(n) = f - end do + else + has_ungrd = .false. + end if + deallocate(ungrd) end if - else if (tk == ESMF_TYPEKIND_R8) then - _FAIL( "R8 overload not implemented yet") - end if - deallocate(gridToFieldMap) + fields(n) = f + end do + deallocate(splitNameArray) ! fields SHOULD be deallocated by the caller!!! From 4ebccad70fac84c402f9d854449b6bd5a97fe831 Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Tue, 28 Nov 2023 00:37:10 -0500 Subject: [PATCH 06/86] Added split field change description --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 86d6e8fb5493..416799c7bf43 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +### Changed - 2023-11-28 +Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. ### Added - New directory (`docs/tutorial/grid_comps/automatic_code_generator`) containing an example showing how to automatically generate the source code using the `MAPL_GridCompSpecs_ACG.py` tool. From be3f10bb849dfa727e0c61f42ec5bea1eef9334c Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Tue, 28 Nov 2023 19:24:28 -0500 Subject: [PATCH 07/86] Replaced RC=STATUS plus _VERIFY(RC) in Base_Base_implementation.F90 with just _RC in line with our new convention --- base/Base/Base_Base_implementation.F90 | 888 +++++++++---------------- 1 file changed, 306 insertions(+), 582 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index b422c44f098c..e1212c5048d8 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -54,56 +54,41 @@ module subroutine MAPL_AllocateCoupling(field, rc) logical :: defaultProvided real :: default_value - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if (fieldStatus /= ESMF_FIELDSTATUS_COMPLETE) then !ALT: if the attributeGet calls fail, this would very likely indicate ! that the field was NOT created by MAPL (or something terrible happened) ! For now we just abort - call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=LOCATION, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='HALOWIDTH', VALUE=HW, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='PRECISION', VALUE=KND, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='DEFAULT_PROVIDED', value=defaultProvided, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, _RC) + call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=LOCATION, _RC) + call ESMF_AttributeGet(FIELD, NAME='HALOWIDTH', VALUE=HW, _RC) + call ESMF_AttributeGet(FIELD, NAME='PRECISION', VALUE=KND, _RC) + call ESMF_AttributeGet(FIELD, NAME='DEFAULT_PROVIDED', value=defaultProvided, _RC) if(defaultProvided) then - call ESMF_AttributeGet(FIELD, NAME='DEFAULT_VALUE', value=default_value, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='DEFAULT_VALUE', value=default_value, _RC) end if - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) if (has_ungrd) then - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, _RC) + allocate(ungrd(UNGRD_CNT), _STAT) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, _RC) if (defaultProvided) then call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, ungrid=ungrd, default_value=default_value, rc=status) - _VERIFY(STATUS) + hw=hw, ungrid=ungrd, default_value=default_value, _RC) else call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, ungrid=ungrd, rc=status) - _VERIFY(STATUS) + hw=hw, ungrid=ungrd, _RC) end if else if (defaultProvided) then call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, default_value=default_value, rc=status) - _VERIFY(STATUS) + hw=hw, default_value=default_value, _RC) else call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, rc=status) - _VERIFY(STATUS) + hw=hw, _RC) end if end if @@ -146,23 +131,18 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & integer :: lb1, lb2, lb3 integer :: ub1, ub2, ub3 - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) _ASSERT(gridRank <= 3,' MAPL restriction - only 2 and 3d are supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) gridToFieldMap = 0 do I = 1, gridRank gridToFieldMap(I) = I end do ! ALT: the next allocation should have been griddedDims, ! but this compilcates the code unnecessery - allocate(haloWidth(gridRank), stat=status) - _VERIFY(STATUS) + allocate(haloWidth(gridRank), _STAT) haloWidth = (/HW,HW,0/) if(present(default_value)) then @@ -189,8 +169,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then select case (rank) case (1) - allocate(VAR_1D(UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(UNGRID(1)), _STAT) VAR_1D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -198,7 +177,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & gridToFieldMap=gridToFieldMap, & ungriddedLBound=[1],& ungriddedUBound=[ungrid(1)], & - rc = status) + _RC) case default _FAIL( 'unsupported rank > 1') end select @@ -206,8 +185,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (1) - allocate(VR8_1D(UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(UNGRID(1)), _STAT) VR8_1D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -215,13 +193,12 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & gridToFieldMap=gridToFieldMap, & ungriddedLBound=[1],& ungriddedUBound=[ungrid(1)], & - rc = status) + _RC) case default _FAIL( 'unsupported rank > 1') end select endif - _VERIFY(STATUS) ! Vertical only ! ------------- @@ -244,8 +221,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end select if (typekind == ESMF_KIND_R4) then - allocate(VAR_1D(lb1:ub1), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(lb1:ub1), _STAT) VAR_1D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=var_1d, & @@ -254,11 +230,9 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & gridToFieldMap=gridToFieldMap, & ungriddedLBound=[lb1],& ungriddedUBound=[ub1], & - RC=status) - _VERIFY(STATUS) + _RC) else - allocate(VR8_1D(lb1:ub1), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(lb1:ub1), _STAT) VR8_1D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=vr8_1d, & @@ -267,8 +241,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & gridToFieldMap=gridToFieldMap, & ungriddedLBound=[lb1],& ungriddedUBound=[ub1], & - RC=status) - _VERIFY(STATUS) + _RC) end if ! Horizontal only @@ -288,8 +261,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then RankCase2d: select case (rank) case (2) - allocate(VAR_2D(lb1:ub1, lb2:ub2), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(lb1:ub1, lb2:ub2), _STAT) VAR_2D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -297,10 +269,9 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + _RC) case (3) - allocate(VAR_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_3D(lb1:ub1, lb2:ub2, UNGRID(1)), _STAT) VAR_3D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -310,10 +281,9 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[1],& ungriddedUBound=[ungrid(1)], & - rc = status) + _RC) case (4) - allocate(VAR_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), _STAT) VAR_4D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_4D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -323,15 +293,14 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[1,1],& ungriddedUBound=[ungrid(1),ungrid(2)], & - rc = status) + _RC) case default _FAIL( 'only up to 4D are supported') end select RankCase2d else select case (rank) case (2) - allocate(VR8_2D(lb1:ub1, lb2:ub2), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(lb1:ub1, lb2:ub2), _STAT) VR8_2D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -339,10 +308,9 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - rc = status) + _RC) case (3) - allocate(VR8_3D(lb1:ub1, lb2:ub2, UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_3D(lb1:ub1, lb2:ub2, UNGRID(1)), _STAT) VR8_3D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -352,10 +320,9 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[1],& ungriddedUBound=[ungrid(1)], & - rc = status) + _RC) case (4) - allocate(VR8_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_4D(lb1:ub1, lb2:ub2, UNGRID(1), UNGRID(2)), _STAT) VR8_4D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_4D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -365,12 +332,11 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[1,1],& ungriddedUBound=[ungrid(1),ungrid(2)], & - rc = status) + _RC) case default _FAIL( 'only up to 4D are supported') end select end if - _VERIFY(STATUS) ! Horz + Vert ! ----------- @@ -400,8 +366,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & case (3) if (typekind == ESMF_KIND_R4) then NULLIFY(VAR_3D) - allocate(VAR_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) - _VERIFY(STATUS) + allocate(VAR_3D(lb1:ub1, lb2:ub2, lb3:ub3), _STAT) VAR_3D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -411,11 +376,10 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[lb3],& ungriddedUBound=[ub3], & - rc = status) + _RC) else NULLIFY(VR8_3D) - allocate(VR8_3D(lb1:ub1, lb2:ub2, lb3:ub3), STAT=status) - _VERIFY(STATUS) + allocate(VR8_3D(lb1:ub1, lb2:ub2, lb3:ub3), _STAT) VR8_3D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -425,15 +389,13 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[lb3],& ungriddedUBound=[ub3], & - rc = status) + _RC) endif - _VERIFY(STATUS) case (4) if (typekind == ESMF_KIND_R4) then NULLIFY(VAR_4D) - allocate(VAR_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) - _VERIFY(STATUS) + allocate(VAR_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), _STAT) VAR_4D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_4D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -443,11 +405,10 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[lb3,1],& ungriddedUBound=[ub3,ungrid(1)], & - rc = status) + _RC) else NULLIFY(VR8_4D) - allocate(VR8_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), STAT=status) - _VERIFY(STATUS) + allocate(VR8_4D(lb1:ub1, lb2:ub2, lb3:ub3, ungrid(1)), _STAT) VR8_4D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_4D, & indexflag=ESMF_INDEX_DELOCAL, & @@ -457,9 +418,8 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=[lb3,1],& ungriddedUBound=[ub3,ungrid(1)], & - rc = status) + _RC) endif - _VERIFY(STATUS) case default _RETURN(ESMF_FAILURE) @@ -474,32 +434,28 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then select case (rank) case (1) - allocate(VAR_1D(COUNTS(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(COUNTS(1)), _STAT) VAR_1D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (2) - allocate(VAR_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(COUNTS(1),UNGRID(1)), _STAT) VAR_2D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (3) - allocate(VAR_3D(COUNTS(1), UNGRID(1), UNGRID(2)), & - STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_3D(COUNTS(1), UNGRID(1), UNGRID(2)), _STAT) VAR_3D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select @@ -507,65 +463,57 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (1) - allocate(VR8_1D(COUNTS(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(COUNTS(1)), _STAT) VR8_1D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (2) - allocate(VR8_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(COUNTS(1),UNGRID(1)), _STAT) VR8_2D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (3) - allocate(VR8_3D(COUNTS(1), UNGRID(1), UNGRID(2)), & - STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_3D(COUNTS(1), UNGRID(1), UNGRID(2)), _STAT) VR8_3D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select endif - _VERIFY(STATUS) case(MAPL_DimsTileTile) rank=2 _ASSERT(gridRank == 1, 'gridRank /= 1') if (typekind == ESMF_KIND_R4) then - allocate(VAR_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(COUNTS(1), COUNTS(2)), _STAT) VAR_2D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & - rc = status) + _RC) else - allocate(VR8_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(COUNTS(1), COUNTS(2)), _STAT) VR8_2D = INIT_VALUE call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & - rc = status) + _RC) endif - _VERIFY(STATUS) ! Invalid dimensionality ! ---------------------- @@ -574,12 +522,10 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & _RETURN(ESMF_FAILURE) end select Dimensionality - _VERIFY(STATUS) if (present(default_value)) then call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialDefault, RC=STATUS) - _VERIFY(STATUS) + VALUE=MAPL_InitialDefault, _RC) end if ! Clean up @@ -605,26 +551,20 @@ module subroutine MAPL_FieldF90Deallocate(field, rc) integer :: rank type(ESMF_TypeKind_Flag) :: tk - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if (fieldStatus == ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_FieldGet(field, Array=array, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, Array=array, _RC) - call ESMF_ArrayGet(array, localDeCount=localDeCount, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localDeCount=localDeCount, _RC) _ASSERT(localDeCount == 1, 'currently MAPL supports only 1 local array') - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias call ESMF_LocalArrayGet(larray, rank=rank, typekind=tk, & - rc=status) - _VERIFY(STATUS) + _RC) - call ESMF_LocalArrayF90Deallocate(larray, typekind=tk, rank=rank, rc=status) - _VERIFY(STATUS) + call ESMF_LocalArrayF90Deallocate(larray, typekind=tk, rank=rank, _RC) end if _RETURN(ESMF_SUCCESS) @@ -657,32 +597,24 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) loc = index(name,';;') if(loc/=0) then - call ESMF_StateGet(state, name(:loc-1), Bundle, rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(state, name(loc+2:), Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name(:loc-1), Bundle, _RC) + call ESMF_StateGet(state, name(loc+2:), Field, _RC) else - call ESMF_StateGet(state, name, Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name, Field, _RC) end if - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) _ASSERT(fieldStatus /= ESMF_FIELDSTATUS_COMPLETE, 'fieldStatus == ESMF_FIELDSTATUS_COMPLETE') - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) _ASSERT(size(ptr,1) == COUNTS(1), 'shape mismatch dim=1') _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) do I = 1, gridRank gridToFieldMap(I) = I end do @@ -693,8 +625,7 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) call ESMF_FieldEmptyComplete(FIELD, farrayPtr=ptr, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) + _RC) ! Clean up deallocate(gridToFieldMap) @@ -730,32 +661,24 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) loc = index(name,';;') if(loc/=0) then - call ESMF_StateGet(state, name(:loc-1), Bundle, rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(state, name(loc+2:), Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name(:loc-1), Bundle, _RC) + call ESMF_StateGet(state, name(loc+2:), Field, _RC) else - call ESMF_StateGet(state, name, Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name, Field, _RC) end if - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) _ASSERT(fieldStatus /= ESMF_FIELDSTATUS_COMPLETE, 'fieldStatus == ESMF_FIELDSTATUS_COMPLETE') - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) _ASSERT(size(ptr,1) == COUNTS(1), 'shape mismatch dim=1') _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) do I = 1, gridRank gridToFieldMap(I) = I end do @@ -763,8 +686,7 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) call ESMF_FieldEmptyComplete(FIELD, farrayPtr=ptr, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) + _RC) ! Clean up deallocate(gridToFieldMap) @@ -901,10 +823,8 @@ module subroutine MAPL_MakeDecomposition(nx, ny, unusable, reduceFactor, rc) _UNUSED_DUMMY(unusable) - call ESMF_VMGetCurrent(vm, rc=status) - _VERIFY(status) - call ESMF_VMGet(vm, petCount=pet_count, rc=status) - _VERIFY(status) + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, petCount=pet_count, _RC) if (present(reduceFactor)) pet_count=pet_count/reduceFactor ! count down from sqrt(n) @@ -988,32 +908,24 @@ module subroutine MAPL_ClimInterpFac (CLOCK,I1,I2,FAC, RC) type (ESMF_TimeInterval) :: oneMonth type (ESMF_Calendar) :: cal - call ESMF_ClockGet ( CLOCK, CurrTime=CurrTime, calendar=cal, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeGet ( CurrTime, midMonth=midMonth, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeIntervalSet( oneMonth, MM = 1, calendar=cal, rc=status ) - _VERIFY(STATUS) + call ESMF_ClockGet ( CLOCK, CurrTime=CurrTime, calendar=cal, _RC ) + call ESMF_TimeGet ( CurrTime, midMonth=midMonth, _RC ) + call ESMF_TimeIntervalSet( oneMonth, MM = 1, calendar=cal, _RC ) if( CURRTIME < midMonth ) then AFTER = midMonth midMonth = midMonth - oneMonth - call ESMF_TimeGet (midMonth, midMonth=BEFORE, rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (midMonth, midMonth=BEFORE, _RC ) else BEFORE = midMonth midMonth = midMonth + oneMonth - call ESMF_TimeGet (midMonth, midMonth=AFTER , rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (midMonth, midMonth=AFTER , _RC ) endif - call MAPL_Interp_Fac( CURRTIME, BEFORE, AFTER, FAC, RC=STATUS) - _VERIFY(STATUS) + call MAPL_Interp_Fac( CURRTIME, BEFORE, AFTER, FAC, _RC) - call ESMF_TimeGet (BEFORE, MM=I1, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeGet (AFTER , MM=I2, rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (BEFORE, MM=I1, _RC ) + call ESMF_TimeGet (AFTER , MM=I2, _RC ) _RETURN(ESMF_SUCCESS) @@ -1229,21 +1141,17 @@ module subroutine MAPL_GetFieldTimeFromField ( FIELD, TIME, RC ) character(len=ESMF_MAXSTR) :: TIMESTAMP logical :: isPresent - call ESMF_AttributeGet(FIELD, NAME="TimeStamp", isPresent=isPresent, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME="TimeStamp", isPresent=isPresent, _RC) if(.not. isPresent) then - call ESMF_TimeSet (TIME, YY=0, RC=STATUS) + call ESMF_TimeSet (TIME, YY=0, _RC) else - call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, _RC) call MAPL_TimeStringGet (TIMESTAMP, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND ) - _VERIFY(STATUS) call ESMF_TimeSet (TIME, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND, & - RC=STATUS) - _VERIFY(STATUS) + _RC) end if _RETURN(ESMF_SUCCESS) @@ -1261,10 +1169,8 @@ module subroutine MAPL_SetFieldTimeFromField (FIELD, TIME, RC ) character(len=ESMF_MAXSTR) :: TIMESTAMP - call ESMF_TimeGet (TIME, timeString=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) + call ESMF_TimeGet (TIME, timeString=TIMESTAMP, _RC) + call ESMF_AttributeSet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromField @@ -1281,10 +1187,8 @@ module subroutine MAPL_GetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) type(ESMF_FIELD) :: FIELD - call ESMF_StateGet (STATE, FIELDNAME, FIELD, RC=STATUS ) - _VERIFY(STATUS) - call MAPL_FieldGetTime (FIELD, TIME, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet (STATE, FIELDNAME, FIELD, _RC ) + call MAPL_FieldGetTime (FIELD, TIME, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GetFieldTimeFromState @@ -1302,10 +1206,8 @@ module subroutine MAPL_SetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) type(ESMF_FIELD) :: FIELD - call ESMF_StateGet (STATE, FIELDNAME, FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_FieldSetTime (FIELD, TIME, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet (STATE, FIELDNAME, FIELD, _RC) + call MAPL_FieldSetTime (FIELD, TIME, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromState @@ -1341,8 +1243,7 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) f = ESMF_FieldCreate(field, datacopyflag=datacopy, name=NAME, _RC) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateRename @@ -1385,43 +1286,32 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) character(len=ESMF_MAXSTR) :: newName_ character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_FieldCreateNewgrid' - call ESMF_FieldGet(FIELD, grid=fgrid, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, grid=fgrid, _RC) - call ESMF_GridGet(fGRID, dimCount=fgridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(fgridRank), stat=status) - _VERIFY(STATUS) + call ESMF_GridGet(fGRID, dimCount=fgridRank, _RC) + allocate(gridToFieldMap(fgridRank), _STAT) call ESMF_FieldGet(FIELD, Array=Array, name=name, & - gridToFieldMap=gridToFieldMap, RC=STATUS) - _VERIFY(STATUS) + gridToFieldMap=gridToFieldMap, _RC) griddedDims = fgridRank - count(gridToFieldMap == 0) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) - call ESMF_ArrayGet(array, rank=rank, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, rank=rank, _RC) ungriddedDims = rank - griddedDims - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) - call ESMF_ArrayGet(array, localDeCount=localDeCount, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localDeCount=localDeCount, _RC) _ASSERT(localDeCount == 1, 'MAPL supports only 1 local array') - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray, totalLBound=lbnds, totalUBound=ubnds, rc=status) - _VERIFY(STATUS) + call ESMF_LocalArrayGet(larray, totalLBound=lbnds, totalUBound=ubnds, _RC) newRank = rank if (griddedDims == 1 .and. gridRank > 1) then deallocate(gridToFieldMap) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) gridToFieldMap = 0 do I = 1, 2 gridToFieldMap(I) = I @@ -1438,8 +1328,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) if (newRank == 2) then F = ESMF_FieldCreate(GRID, typekind=ESMF_TYPEKIND_R4, & indexflag=ESMF_INDEX_DELOCAL, & - name=newName_, gridToFieldMap=gridToFieldMap, RC=STATUS ) - _VERIFY(STATUS) + name=newName_, gridToFieldMap=gridToFieldMap, _RC ) DIMS = MAPL_DimsHorzOnly else if (newRank == 3) then @@ -1453,7 +1342,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) F = ESMF_FieldCreate(GRID, typekind=ESMF_TYPEKIND_R4, & indexflag=ESMF_INDEX_DELOCAL, & name=newName_, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=[lb],ungriddedUBound=[ub],RC=STATUS ) + ungriddedLBound=[lb],ungriddedUBound=[ub],_RC ) if (ungriddedDims > 0) then DIMS = MAPL_DimsHorzOnly else @@ -1464,7 +1353,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) indexflag=ESMF_INDEX_DELOCAL, & name=newName_, gridToFieldMap=gridToFieldMap, & ungriddedLBound=[lbnds(griddedDims+1),lbnds(griddedDims+2)], & - ungriddedUBound=[ubnds(griddedDims+1),ubnds(griddedDims+2)],RC=STATUS ) + ungriddedUBound=[ubnds(griddedDims+1),ubnds(griddedDims+2)],_RC ) if (ungriddedDims > 0) then DIMS = MAPL_DimsHorzOnly else @@ -1476,12 +1365,10 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) deallocate(gridToFieldMap) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) ! we are saving DIMS attribute in case the FIELD did not contain one ! otherwise we will overwrite it - call ESMF_AttributeSet(F, NAME='DIMS', VALUE=DIMS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(F, NAME='DIMS', VALUE=DIMS, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateNewgrid @@ -1513,71 +1400,54 @@ module function MAPL_FieldCreateR4(FIELD, RC) RESULT(F) type(ESMF_TypeKind_Flag) :: tk call ESMF_FieldGet(FIELD, grid=GRID, dimCount=fieldRank, & - name=fieldName, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + name=fieldName, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R8, 'tk /= ESMF_TypeKind_R8') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, RC=STATUS) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) + call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, _RC) datacopy = ESMF_DATACOPY_REFERENCE select case (fieldRank) case (1) - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - allocate(var_1d(lbound(vr8_1d,1):ubound(vr8_1d,1)), stat=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_1d, _RC) + allocate(var_1d(lbound(vr8_1d,1):ubound(vr8_1d,1)), _STAT) var_1d=vr8_1d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_1D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case (2) - call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_2d, _RC) allocate(var_2d(lbound(vr8_2d,1):ubound(vr8_2d,1), & lbound(vr8_2d,2):ubound(vr8_2d,2)), & - stat=status) - _VERIFY(STATUS) + _STAT) var_2d=vr8_2d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case (3) - call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_3d, _RC) allocate(var_3d(lbound(vr8_3d,1):ubound(vr8_3d,1), & lbound(vr8_3d,2):ubound(vr8_3d,2), & lbound(vr8_3d,3):ubound(vr8_3d,3)), & - stat=status) - _VERIFY(STATUS) + _STAT) var_3d=vr8_3d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_3D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select deallocate(gridToFieldMap) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateR4 @@ -1591,14 +1461,12 @@ module function MAPL_FieldCreateEmpty(NAME, GRID, RC) RESULT(FIELD) character(len=ESMF_MAXSTR),parameter :: IAm=" MAPL_FieldCreateEmpty" integer :: STATUS - FIELD = ESMF_FieldEmptyCreate(name=name, rc=status) - _VERIFY(STATUS) + FIELD = ESMF_FieldEmptyCreate(name=name, _RC) call ESMF_FieldEmptySet(FIELD, & grid=GRID, & staggerloc = ESMF_STAGGERLOC_CENTER, & - rc = status) - _VERIFY(STATUS) + _RC) _RETURN(ESMF_SUCCESS) @@ -1610,8 +1478,7 @@ module subroutine MAPL_FieldCopyAttributes(FIELD_IN, FIELD_OUT, RC) integer, optional, intent( OUT) :: RC integer :: status - call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, rc=status) - _VERIFY(status) + call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_FieldCopyAttributes @@ -1637,40 +1504,30 @@ module subroutine MAPL_FieldCopy(from, to, RC) type(ESMF_TypeKind_Flag) :: tk call ESMF_FieldGet(from, dimCount=fieldRank, & - typekind=tk, RC=STATUS) - _VERIFY(STATUS) + typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R8, 'inconsistent typekind (should be ESMF_TypeKind_R8)') select case (fieldRank) case (1) - call ESMF_FieldGet(from, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_1d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==1, 'inconsistent fieldrank (should be 1)') - call ESMF_FieldGet(to, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_1d, _RC) var_1d = vr8_1d case (2) - call ESMF_FieldGet(from, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_2d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==2, 'inconsistent fieldRank (should be 2)') - call ESMF_FieldGet(to, farrayPtr=var_2d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_2d, _RC) var_2d = vr8_2d case (3) - call ESMF_FieldGet(from, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_3d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==3,'inconsistent fieldRank (should be 3)') - call ESMF_FieldGet(to, farrayPtr=var_3d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_3d, _RC) var_3d = vr8_3d case default _FAIL( 'unsupported fieldRank (> 3)') @@ -1714,24 +1571,25 @@ module subroutine MAPL_GRID_INTERIOR(GRID,I1,IN,J1,JN) integer :: deId integer :: gridRank integer, allocatable :: localDeToDeMap(:) + integer :: rc i1=-1 j1=-1 in=-1 jn=-1 - call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, rc=STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - call ESMF_DELayoutGet(layout, deCount = nDEs, localDeCount=localDeCount,rc=status) + call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, _RC) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, deCount = nDEs, localDeCount=localDeCount,_RC) if (localDeCount > 0) then - allocate(localDeToDeMap(localDeCount),stat=status) - call ESMF_DELayoutGet(layout, localDEtoDeMap=localDeToDeMap,rc=status) + allocate(localDeToDeMap(localDeCount),_STAT) + call ESMF_DELayoutGet(layout, localDEtoDeMap=localDeToDeMap,_RC) deId=localDeToDeMap(1) - allocate (AL(gridRank,0:nDEs-1), stat=status) - allocate (AU(gridRank,0:nDEs-1), stat=status) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPl_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) + minIndex=AL, maxIndex=AU, _RC) I1 = AL(1, deId) IN = AU(1, deId) @@ -1927,10 +1785,8 @@ module function MAPL_LatLonGridCreate (Name, vm, & if ( present(vm) ) then vm_ => vm else - allocate(vm_, stat=STATUS) - _VERIFY(STATUS) - call ESMF_VMGetCurrent(vm_, rc=STATUS) - _VERIFY(STATUS) + allocate(vm_, _STAT) + call ESMF_VMGetCurrent(vm_, _RC) end if ! Grid info via resources @@ -1940,17 +1796,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Either use supplied Config or load resource file ! ------------------------------------------------ if ( present(ConfigFile) ) then - allocate(Config_,stat=STATUS) - _VERIFY(STATUS) - Config_ = ESMF_ConfigCreate (rc=STATUS ) - _VERIFY(STATUS) - call ESMF_ConfigLoadFile (Config_, ConfigFile, rc=STATUS ) - _VERIFY(STATUS) + allocate(Config_,_STAT) + Config_ = ESMF_ConfigCreate (_RC ) + call ESMF_ConfigLoadFile (Config_, ConfigFile, _RC ) else if ( present(Config) ) then Config_ => Config else STATUS = 100 - _VERIFY(STATUS) end if ! Get relevant parameters from Config @@ -1984,7 +1836,6 @@ module function MAPL_LatLonGridCreate (Name, vm, & else STATUS = 300 - _VERIFY(STATUS) end if @@ -1992,7 +1843,6 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! ------------ if ( IM_World_ < 1 .OR. JM_World_ < 1 ) then STATUS = 400 - _VERIFY(STATUS) end if if ( DelLon_ < 0.0 ) then ! convention for global grids if ( IM_World_ == 1 ) then @@ -2011,8 +1861,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Give the IMs, JMs and LMs the MAPL default distribution ! ------------------------------------------------------- - allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), stat=STATUS) - _VERIFY(STATUS) + allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), _STAT) call MAPL_DecomposeDim ( IM_World_, IMs, Nx_ ) call MAPL_DecomposeDim ( JM_World_, JMs, Ny_ ) call MAPL_DecomposeDim ( LM_World_, LMs, Nz_ ) @@ -2037,8 +1886,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & coordDep3 = (/3/), & gridEdgeLWidth = (/0,0,0/), & gridEdgeUWidth = (/0,0,0/), & - rc=STATUS) - _VERIFY(STATUS) + _RC) #else Grid = ESMF_GridCreate( & name=Name, & @@ -2049,11 +1897,9 @@ module function MAPL_LatLonGridCreate (Name, vm, & gridEdgeUWidth = (/0,0/), & coordDep1 = (/1,2/), & coordDep2 = (/1,2/), & - rc=status) - _VERIFY(STATUS) + _RC) - call ESMF_AttributeSet(grid, name='GRID_LM', value=LM_World, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(grid, name='GRID_LM', value=LM_World, _RC) #endif @@ -2068,15 +1914,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & coordDep2 = (/1,2/), & gridEdgeLWidth = (/0,0/), & gridEdgeUWidth = (/0,0/), & - rc=STATUS) - _VERIFY(STATUS) + _RC) ! Other possibilities not implemented yet ! --------------------------------------- else STATUS = 300 - _VERIFY(STATUS) endif @@ -2088,8 +1932,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Allocate coords at default stagger location ! ------------------------------------------- - call ESMF_GridAddCoord(Grid, rc=status) - _VERIFY(STATUS) + call ESMF_GridAddCoord(Grid, _RC) ! Compute the coordinates (the corner/center is for backward compatibility) ! ------------------------------------------------------------------------- @@ -2098,8 +1941,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & minCoord(1) = MAPL_DEGREES_TO_RADIANS_R8 * BegLon_ - deltaX/2 minCoord(2) = MAPL_DEGREES_TO_RADIANS_R8 * BegLat_ - deltaY/2 - allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), stat=STATUS) - _VERIFY(STATUS) + allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), _STAT) cornerX(1) = minCoord(1) do i = 1,IM_World_ @@ -2115,13 +1957,11 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! ------------------------------------------- call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerX, rc=status) - _VERIFY(STATUS) + farrayPtr=centerX, _RC) call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerY, rc=status) - _VERIFY(STATUS) + farrayPtr=centerY, _RC) FirstOut(1)=BegLon_ FirstOut(2)=-90. @@ -2153,8 +1993,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Make sure we've got it right ! ---------------------------- - call ESMF_GridValidate(Grid,rc=status) - _VERIFY(STATUS) + call ESMF_GridValidate(Grid,_RC) ! Clean up ! -------- @@ -2174,7 +2013,6 @@ subroutine parseConfig_() ! Internal routine to parse the ESMF_Config. ! STATUS = 200 ! not implemented yet - _VERIFY(STATUS) end subroutine parseConfig_ @@ -2199,32 +2037,25 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) real(ESMF_KIND_R8), allocatable :: r8ptr(:),lons1d(:),lats1d(:) type(ESMF_CoordSys_Flag) :: coordSys - call MAPL_GridGet(grid,localCellCountPerDim=counts,rc=status) - _VERIFY(status) + call MAPL_GridGet(grid,localCellCountPerDim=counts,_RC) im=counts(1) jm=counts(2) ! check if we have corners call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - isPresent=hasLons, RC=STATUS) - _VERIFY(status) + isPresent=hasLons, _RC) call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - isPresent=hasLats, RC=STATUS) - _VERIFY(status) + isPresent=hasLats, _RC) if (hasLons .and. hasLats) then call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - itemcount=lsz, RC=STATUS) - _VERIFY(STATUS) + itemcount=lsz, _RC) _ASSERT(size(gridCornerLons,1)*size(gridCornerLons,2)==lsz,"stored corner sizes to not match grid") call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - itemcount=lsz, RC=STATUS) - _VERIFY(STATUS) + itemcount=lsz, _RC) _ASSERT(size(gridCornerLats,1)*size(gridCornerLats,2)==lsz,"stored corner sizes to not match grid") - allocate(r8ptr(lsz),stat=status) - _VERIFY(status) + allocate(r8ptr(lsz),_STAT) call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - VALUELIST=r8ptr, RC=STATUS) - _VERIFY(STATUS) + VALUELIST=r8ptr, _RC) idx = 0 do j = 1, size(gridCornerLons,2) @@ -2235,8 +2066,7 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) end do call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - VALUELIST=r8ptr, RC=STATUS) - _VERIFY(STATUS) + VALUELIST=r8ptr, _RC) idx = 0 do j = 1, size(gridCornerLons,2) @@ -2249,47 +2079,36 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) else call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner, rc=status) + farrayPtr=corner, _RC) imc=size(corner,1) jmc=size(corner,2) - allocate(ptr(0:imc+1,0:jmc+1),source=0.0d0,stat=status) - _VERIFY(status) - field = ESMF_FieldCreate(grid,ptr,staggerLoc=ESMF_STAGGERLOC_CORNER,totalLWidth=[1,1],totalUWidth=[1,1],rc=status) - _VERIFY(status) - call ESMF_FieldHaloStore(field,rh,rc=status) - _VERIFY(status) + allocate(ptr(0:imc+1,0:jmc+1),source=0.0d0,_STAT) + field = ESMF_FieldCreate(grid,ptr,staggerLoc=ESMF_STAGGERLOC_CORNER,totalLWidth=[1,1],totalUWidth=[1,1],_RC) + call ESMF_FieldHaloStore(field,rh,_RC) ptr(1:imc,1:jmc)=corner - call ESMF_FieldHalo(field,rh,rc=status) - _VERIFY(status) + call ESMF_FieldHalo(field,rh,_RC) gridCornerLons=ptr(1:im+1,1:jm+1) call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner, rc=status) - _VERIFY(status) + farrayPtr=corner, _RC) ptr(1:imc,1:jmc)=corner - call ESMF_FieldHalo(field,rh,rc=status) - _VERIFY(status) + call ESMF_FieldHalo(field,rh,_RC) gridCornerLats=ptr(1:im+1,1:jm+1) deallocate(ptr) - call ESMF_FieldDestroy(field,rc=status) - _VERIFY(status) - call ESMF_FieldHaloRelease(rh,rc=status) - _VERIFY(status) + call ESMF_FieldDestroy(field,_RC) + call ESMF_FieldHaloRelease(rh,_RC) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(status) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) if (coordSys==ESMF_COORDSYS_SPH_DEG) then gridCornerLons=gridCornerLons*MAPL_DEGREES_TO_RADIANS_R8 gridCornerLats=gridCornerLats*MAPL_DEGREES_TO_RADIANS_R8 else if (coordSys==ESMF_COORDSYS_CART) then _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') end if - allocate(lons1d(size(gridCornerLons,1)*size(gridCornerLons,2)),stat=status) - _VERIFY(status) - allocate(lats1d(size(gridCornerLons,1)*size(gridCornerLons,2)),stat=status) - _VERIFY(status) + allocate(lons1d(size(gridCornerLons,1)*size(gridCornerLons,2)),_STAT) + allocate(lats1d(size(gridCornerLons,1)*size(gridCornerLons,2)),_STAT) idx = 0 do j=1,size(gridCornerLons,2) do i=1,size(gridCornerLons,1) @@ -2299,11 +2118,9 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) enddo enddo call ESMF_AttributeSet(grid, name='GridCornerLons:', & - itemCount = idx, valueList=lons1d, rc=status) - _VERIFY(STATUS) + itemCount = idx, valueList=lons1d, _RC) call ESMF_AttributeSet(grid, name='GridCornerLats:', & - itemCount = idx, valueList=lats1d, rc=status) - _VERIFY(STATUS) + itemCount = idx, valueList=lats1d, _RC) deallocate(lons1d,lats1d) end if @@ -2334,17 +2151,18 @@ module subroutine MAPL_GridGetInterior(GRID,I1,IN,J1,JN) integer :: nDEs integer :: deId integer :: gridRank + integer :: rc - call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, rc=STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - call ESMF_DELayoutGet(layout, vm=vm, rc=status) - call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status) + call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, _RC) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, vm=vm, _RC) + call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, _RC) - allocate (AL(gridRank,0:nDEs-1), stat=status) - allocate (AU(gridRank,0:nDEs-1), stat=status) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPL_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) + minIndex=AL, maxIndex=AU, _RC) I1 = AL(1, deId) IN = AU(1, deId) @@ -2440,37 +2258,26 @@ recursive module subroutine MAPL_StateAttSetI4(STATE, NAME, VALUE, RC) integer :: ITEMCOUNT integer :: I - call ESMF_AttributeSet(STATE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(STATE, NAME, VALUE, _RC) - call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,_RC) IF (ITEMCOUNT>0) then - allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES(ITEMCOUNT),_STAT) + allocate(ITEMTYPES(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE, ITEMNAMELIST=ITEMNAMES, & - ITEMTYPELIST=ITEMTYPES, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES, _RC) do I = 1, ITEMCOUNT if(itemtypes(I)==ESMF_StateItem_State) then - call ESMF_StateGet(STATE, itemNames(I), nestedState, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(nestedState, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), nestedState, _RC) + call MAPL_AttributeSet(nestedState, NAME, VALUE, _RC) else if(itemtypes(I)==ESMF_StateItem_FieldBundle) then - call ESMF_StateGet(STATE, itemNames(I), BUNDLE, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(BUNDLE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), BUNDLE, _RC) + call MAPL_AttributeSet(BUNDLE, NAME, VALUE, _RC) else if(itemtypes(I)==ESMF_StateItem_Field) then - call ESMF_StateGet(STATE, itemNames(I), FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), FIELD, _RC) + call MAPL_AttributeSet(FIELD, NAME, VALUE, _RC) end if end do @@ -2495,17 +2302,13 @@ module subroutine MAPL_BundleAttSetI4(BUNDLE, NAME, VALUE, RC) integer :: FIELDCOUNT integer :: I - call ESMF_AttributeSet(BUNDLE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(BUNDLE, NAME, VALUE, _RC) - call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, _RC) do I = 1, FIELDCOUNT - call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, I, FIELD, _RC) + call ESMF_AttributeSet(FIELD, NAME, VALUE, _RC) end do _RETURN(ESMF_SUCCESS) @@ -2525,17 +2328,13 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) type(ESMF_FieldStatus_Flag) :: fieldStatus - call ESMF_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME, VALUE, _RC) - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if(fieldStatus == ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_FieldGet(field, Array=array, rc=status) - _VERIFY(STATUS) - call ESMF_AttributeSet(array, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, Array=array, _RC) + call ESMF_AttributeSet(array, NAME, VALUE, _RC) end if _RETURN(ESMF_SUCCESS) @@ -2555,17 +2354,13 @@ module subroutine MAPL_FieldBundleDestroy(Bundle,RC) integer :: STATUS - isCreated = ESMF_FieldBundleIsCreated(bundle,rc=status) - _VERIFY(STATUS) + isCreated = ESMF_FieldBundleIsCreated(bundle,_RC) if(isCreated) then - call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, _RC) do I = 1, FIELDCOUNT - call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_FieldDestroy(FIELD, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, I, FIELD, _RC) + call MAPL_FieldDestroy(FIELD, _RC) end do end if @@ -2593,49 +2388,40 @@ module subroutine MAPL_StateAddField(State, Field, RC) logical :: haveAttr fields(1) = field - call ESMF_StateAdd(state, fields, RC=status) - _VERIFY(STATUS) + call ESMF_StateAdd(state, fields, _RC) !================= !!!ALT Example to add one field at the time (not used anymore) !!! call ESMF_StateAdd(STATE, FIELD, proxyflag=.false., & -!!! addflag=.true., replaceflag=.false., RC=STATUS ) +!!! addflag=.true., replaceflag=.false., _RC ) !================= ! check for attribute - call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(state, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(state, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldGet(field, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2664,44 +2450,35 @@ module subroutine MAPL_StateAddBundle(State, Bundle, RC) logical :: haveAttr bundles(1) = bundle - call ESMF_StateAdd(state, Bundles, RC=status) - _VERIFY(STATUS) + call ESMF_StateAdd(state, Bundles, _RC) ! check for attribute - call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(state, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(state, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldBundleGet(bundle, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(bundle, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2731,44 +2508,35 @@ module subroutine MAPL_FieldBundleAddField(Bundle, Field, multiflag, RC) fields(1) = field - call ESMF_FieldBundleAdd(Bundle, fields, multiflag=multiflag, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleAdd(Bundle, fields, multiflag=multiflag, _RC) ! check for attribute - call ESMF_AttributeGet(Bundle, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(bundle, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(bundle, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldGet(field, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(bundle, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(bundle, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2795,18 +2563,14 @@ module subroutine MAPL_FieldBundleGetByIndex(Bundle, fieldIndex, Field, RC) ! check for attribute - call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, _RC) + allocate(currList(natt), _STAT) ! get the current list - call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, _RC) name = currList(fieldIndex) - call ESMF_FieldBundleGet(Bundle, fieldName = name, field=field, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(Bundle, fieldName = name, field=field, _RC) deallocate(currList) @@ -2858,8 +2622,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) ! pass in the the dimensions of the grid and we must compute them ! and assume search on the global domain if (present(Grid)) then - call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,rc=status) - _VERIFY(STATUS) + call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,_RC) IM_World = dims(1) JM_World = dims(2) IM = counts(1) @@ -2883,13 +2646,10 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) call ESMF_AttributeGet(grid, name='GridType', value=grid_type, _RC) if(trim(grid_type) == "Cubed-Sphere") then call ESMF_GridGetCoord(grid,coordDim=1, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, rc=status) - _VERIFY(STATUS) + staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, _RC) call ESMF_GridGetCoord(grid,coordDim=2, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, rc=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(STATUS) + staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, _RC) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) allocate(corner_lons(im+1,jm+1)) allocate(corner_lats(im+1,jm+1)) allocate(center_lons(im,jm),center_lats(im,jm)) @@ -2903,11 +2663,10 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else if (coordSys==ESMF_COORDSYS_CART) then _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') end if - call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,rc=status) + call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,_RC) ii=-1 jj=-1 - call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,rc=status) - _VERIFY(status) + call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,_RC) deallocate(corner_lons,corner_lats, center_lons,center_lats) else if (localSearch) then @@ -2918,12 +2677,9 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else _FAIL('if not isCubed, localSearch must be .true.') end if - allocate(elons(im+1),stat=status) - _VERIFY(STATUS) - allocate(elats(jm+1),stat=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(STATUS) + allocate(elons(im+1),_STAT) + allocate(elats(jm+1),_STAT) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) elons = lons(:,1) elats = lats(1,:) if (coordSys==ESMF_COORDSYS_SPH_DEG) then @@ -3038,8 +2794,7 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, if ( .not. present(grid)) then _ASSERT(.false., "need a cubed-sphere grid") endif - call MAPL_GridGet(grid, globalCellCountPerDim=dims,rc=status) - _VERIFY(STATUS) + call MAPL_GridGet(grid, globalCellCountPerDim=dims,_RC) IM_World = dims(1) JM_World = dims(2) _ASSERT( IM_WORLD*6 == JM_WORLD, "It only works for cubed-sphere grid") @@ -3362,16 +3117,14 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un integer :: gridRank type(ESMF_Field) :: field - allocate(localIs2D(size(fieldNames)),stat=status) - _VERIFY(STATUS) + allocate(localIs2D(size(fieldNames)),_STAT) if (present(is2D)) then _ASSERT(size(fieldNames) == size(is2D),'inconsistent size of is2D array') localIs2D = is2D else localIs2D = .false. end if - allocate(localIsEdge(size(fieldNames)),stat=status) - _VERIFY(STATUS) + allocate(localIsEdge(size(fieldNames)),_STAT) if (present(isEdge)) then _ASSERT(size(fieldNames) == size(isEdge), 'inconsistent size of isEdge array') localIsEdge = isEdge @@ -3385,23 +3138,17 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un _ASSERT(size(fieldNames) == size(units), 'inconsistent size of units array') end if - B = ESMF_FieldBundleCreate ( name=name, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_FieldBundleSet ( B, grid=GRID, rc=STATUS ) - _VERIFY(STATUS) + B = ESMF_FieldBundleCreate ( name=name, _RC ) + call ESMF_FieldBundleSet ( B, grid=GRID, _RC ) call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, & - localCellCountPerDim=DIMS, RC=STATUS) - _VERIFY(STATUS) + localCellCountPerDim=DIMS, _RC) do i=1,size(fieldnames) if (localIs2D(i)) then - allocate(PTR2(DIMS(1),DIMS(2)),stat=STATUS) - _VERIFY(STATUS) + allocate(PTR2(DIMS(1),DIMS(2)),_STAT) PTR2 = 0.0 - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) if(gridRank == 2) then gridToFieldMap(1) = 1 gridToFieldMap(2) = 2 @@ -3415,53 +3162,40 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un FIELD = ESMF_FieldCreate(grid=GRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & farrayPtr=PTR2, gridToFieldMap=gridToFieldMap, & - name=fieldNames(i), RC=STATUS) - _VERIFY(STATUS) + name=fieldNames(i), _RC) deallocate(gridToFieldMap) - call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzOnly, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationNone, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzOnly, _RC) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationNone, _RC) else if (localIsEdge(i)) then - allocate(PTR3(Dims(1),Dims(2),0:counts(3)),stat=status) - _VERIFY(STATUS) + allocate(PTR3(Dims(1),Dims(2),0:counts(3)),_STAT) else - allocate(PTR3(Dims(1),Dims(2),counts(3)),stat=status) - _VERIFY(STATUS) + allocate(PTR3(Dims(1),Dims(2),counts(3)),_STAT) end if PTR3 = 0.0 FIELD = ESMF_FieldCreate(grid=GRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - farrayPtr=PTR3, name=fieldNames(i), RC=STATUS) - call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzVert, RC=STATUS) - _VERIFY(STATUS) + farrayPtr=PTR3, name=fieldNames(i), _RC) + call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzVert, _RC) if (localIsEdge(i)) then - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationEdge, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationEdge, _RC) else - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationCenter, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationCenter, _RC) end if end if if (present(long_names)) then - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=long_names(i), RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=long_names(i), _RC) else - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", _RC) end if if (present(units)) then - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=units(i), RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=units(i), _RC) else - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", _RC) end if - call MAPL_FieldBundleAdd(B, FIELD, RC=STATUS) - _VERIFY(STATUS) + call MAPL_FieldBundleAdd(B, FIELD, _RC) enddo deallocate(localIs2D) @@ -3481,11 +3215,9 @@ module function MAPL_TrimString(istring,rc) result(ostring) strlen = len_trim(istring) if (istring(strlen:strlen)==char(0)) then - allocate(ostring,source=istring(1:strlen-1),stat=status) - _VERIFY(status) + allocate(ostring,source=istring(1:strlen-1),_STAT) else - allocate(ostring,source=istring(1:strlen),stat=status) - _VERIFY(status) + allocate(ostring,source=istring(1:strlen),_STAT) end if _RETURN(_SUCCESS) end function MAPL_TrimString @@ -3528,7 +3260,6 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) allocate(fields(n), _STAT) call genAlias(name, n, splitNameArray, aliasName=aliasName,_RC) - _VERIFY(STATUS) n = 0 do k=k1,k2 @@ -3545,19 +3276,14 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) ! adjust ungridded dims attribute (if any) call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, _RC) + allocate(ungrd(UNGRD_CNT), _STAT) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, _RC) + call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', _RC) if (ungrd_cnt > 1) then ungrd_cnt = ungrd_cnt - 1 call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) + valueList=UNGRD(1:ungrd_cnt), _RC) else has_ungrd = .false. end if @@ -3628,8 +3354,7 @@ subroutine genAlias(name, n, splitNameArray, aliasName, rc) aliasName_ = name end if - allocate(splitNameArray(n), stat=status) - _VERIFY(status) + allocate(splitNameArray(n), _STAT) ! parse the aliasName ! count the separators (";") in aliasName @@ -3679,8 +3404,7 @@ module function MAPL_GetCorrectedPhase(gc,rc) result(phase) integer :: status - call ESMF_GridCompGet(gc,currentPhase=phase,rc=status) - _VERIFY(status) + call ESMF_GridCompGet(gc,currentPhase=phase,_RC) if (phase>10) phase=phase-10 _RETURN(_SUCCESS) end function MAPL_GetCorrectedPhase From 9f77fe06814b848bfc9b5fc97b820935db157680 Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Tue, 28 Nov 2023 19:26:19 -0500 Subject: [PATCH 08/86] Update CHANGELOG to reflect the _RC chaneg just made to Base_Base_implementation.F90 --- CHANGELOG.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 416799c7bf43..5d4817574da5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,7 +7,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] -### Changed - 2023-11-28 +### Changed +Replaced RC=STATUS plus _VERIFY(RC) in Base_Base_implementation.F90 with just _RC in line with our new convention. + +### Changed Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. ### Added From 631f2a48c5e84323991dac89185871c1f0575d06 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 29 Nov 2023 09:21:14 -0500 Subject: [PATCH 09/86] Move CI to use 7.16.0 --- .circleci/config.yml | 4 ++-- .github/workflows/workflow.yml | 4 ++-- CMakeLists.txt | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index c8f8f3ee4be6..b3b7d325e9ec 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -16,8 +16,8 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 -baselibs_version: &baselibs_version v7.14.0 -bcs_version: &bcs_version v11.2.0 +baselibs_version: &baselibs_version v7.16.0 +bcs_version: &bcs_version v11.3.0 tag_build_arg_name: &tag_build_arg_name maplversion orbs: diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 467e64ea8ce6..2bcc31eb6d41 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.14.0-openmpi_4.1.4-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.16.0-openmpi_4.1.4-gcc_12.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -77,7 +77,7 @@ jobs: name: Build and Test MAPL Intel runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env:v7.14.0-intelmpi_2021.6.0-intel_2022.1.0 + image: gmao/ubuntu20-geos-env:v7.16.0-intelmpi_2021.6.0-intel_2022.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/CMakeLists.txt b/CMakeLists.txt index 30af81f71bef..58919671b5ae 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -148,7 +148,7 @@ if (NOT Baselibs_FOUND) endif() if (NOT TARGET esmf) - find_package(ESMF 8.5.0 MODULE REQUIRED) + find_package(ESMF 8.6.0 MODULE REQUIRED) # ESMF as used in MAPL requires MPI # NOTE: This looks odd because some versions of FindESMF.cmake out in the @@ -167,8 +167,8 @@ else () # This is an ESMF version test when using Baselibs which doesn't use the # same find_package internally in ESMA_cmake as used above (with a version # number) so this lets us at least trap use of old Baselibs here. - if (ESMF_VERSION VERSION_LESS 8.5.0) - message(FATAL_ERROR "ESMF must be at least 8.5.0") + if (ESMF_VERSION VERSION_LESS 8.6.0) + message(FATAL_ERROR "ESMF must be at least 8.6.0") endif () endif () From 267cf228b447368d289e3183cd1b99fc3de17354 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 29 Nov 2023 09:22:52 -0500 Subject: [PATCH 10/86] Update changelog --- CHANGELOG.md | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5d4817574da5..6d76e593284a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,11 +7,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] -### Changed -Replaced RC=STATUS plus _VERIFY(RC) in Base_Base_implementation.F90 with just _RC in line with our new convention. - -### Changed -Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. ### Added - New directory (`docs/tutorial/grid_comps/automatic_code_generator`) containing an example showing how to automatically generate the source code using the `MAPL_GridCompSpecs_ACG.py` tool. @@ -19,6 +14,9 @@ Made changes to allocate fields to use farray instead of farrayPtr. This allows ### Changed - Change the verification of the grid in MAPL_GetGlobalHorzIJIndex to avoid collective call +- Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. +- Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. +- Updated CI to use ESMF 8.6.0 Baselibs; updated ESMF required version to 8.6.0 ### Fixed From 2f47f40287acf07c5c8ee499b8c3f24b6645782b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 29 Nov 2023 11:23:30 -0500 Subject: [PATCH 11/86] Trivial commit to retrigger CI --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6d76e593284a..beaedb2337aa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Change the verification of the grid in MAPL_GetGlobalHorzIJIndex to avoid collective call - Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. -- Updated CI to use ESMF 8.6.0 Baselibs; updated ESMF required version to 8.6.0 +- Updated CI to use ESMF 8.6.0 Baselibs and updated ESMF required version to 8.6.0 ### Fixed From 5f13ae6bd3b1de4f2c7e0c00e6af17137a51ea8e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 29 Nov 2023 12:33:36 -0500 Subject: [PATCH 12/86] Another trivial commit to trigger CI --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index beaedb2337aa..b11ee504f262 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Change the verification of the grid in MAPL_GetGlobalHorzIJIndex to avoid collective call - Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. -- Updated CI to use ESMF 8.6.0 Baselibs and updated ESMF required version to 8.6.0 +- Updated CI to use ESMF 8.6.0 (Baselibs 7.16.0) and updated ESMF required version to 8.6.0 ### Fixed From b578fcc3d4d31bda304a25785d0b95e87269e4d9 Mon Sep 17 00:00:00 2001 From: Amidu Oloso Date: Wed, 29 Nov 2023 17:49:33 -0500 Subject: [PATCH 13/86] Completed gridded fields with allocation that uses 'pinflag' option to assess the SIngle System Image capability of ESMF that is needed or the 'mixed' hybrid approach for GEOS GCM where only the dyncore is hybrid MPI/OpenMP and everything else stays only MPI, both sides using the same number of total PEs --- base/Base/Base_Base_implementation.F90 | 1164 ++++++++---------------- 1 file changed, 366 insertions(+), 798 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index bc02d722b479..839c8674eda1 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -54,56 +54,41 @@ module subroutine MAPL_AllocateCoupling(field, rc) logical :: defaultProvided real :: default_value - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if (fieldStatus /= ESMF_FIELDSTATUS_COMPLETE) then !ALT: if the attributeGet calls fail, this would very likely indicate ! that the field was NOT created by MAPL (or something terrible happened) ! For now we just abort - call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=LOCATION, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='HALOWIDTH', VALUE=HW, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='PRECISION', VALUE=KND, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='DEFAULT_PROVIDED', value=defaultProvided, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, _RC) + call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=LOCATION, _RC) + call ESMF_AttributeGet(FIELD, NAME='HALOWIDTH', VALUE=HW, _RC) + call ESMF_AttributeGet(FIELD, NAME='PRECISION', VALUE=KND, _RC) + call ESMF_AttributeGet(FIELD, NAME='DEFAULT_PROVIDED', value=defaultProvided, _RC) if(defaultProvided) then - call ESMF_AttributeGet(FIELD, NAME='DEFAULT_VALUE', value=default_value, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='DEFAULT_VALUE', value=default_value, _RC) end if - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) if (has_ungrd) then - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, _RC) + allocate(ungrd(UNGRD_CNT), _STAT) + call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', valueList=UNGRD, _RC) if (defaultProvided) then call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, ungrid=ungrd, default_value=default_value, rc=status) - _VERIFY(STATUS) + hw=hw, ungrid=ungrd, default_value=default_value, _RC) else call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, ungrid=ungrd, rc=status) - _VERIFY(STATUS) + hw=hw, ungrid=ungrd, _RC) end if else if (defaultProvided) then call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, default_value=default_value, rc=status) - _VERIFY(STATUS) + hw=hw, default_value=default_value, _RC) else call MAPL_FieldAllocCommit(field, dims=dims, location=location, typekind=knd, & - hw=hw, rc=status) - _VERIFY(STATUS) + hw=hw, _RC) end if end if @@ -119,13 +104,13 @@ end subroutine MAPL_AllocateCoupling module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & hw, ungrid, default_value, rc) type(ESMF_Field), intent(INOUT) :: field - integer, intent(IN ) :: dims - integer, intent(IN ) :: location + integer, intent(IN ) :: dims + integer, intent(IN ) :: location integer, intent(IN ) :: typekind integer, intent(IN ) :: hw !halowidth integer, optional, intent(IN ) :: ungrid(:) real, optional, intent(IN ) :: default_value - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status @@ -153,23 +138,18 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & logical :: ssiSharedMemoryEnabled ! SSI - call ESMF_FieldGet(field, grid=GRID, name=name, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) _ASSERT(gridRank <= 3,' MAPL restriction - only 2 and 3d are supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) gridToFieldMap = 0 do I = 1, gridRank gridToFieldMap(I) = I end do ! ALT: the next allocation should have been griddedDims, ! but this compilcates the code unnecessery - allocate(haloWidth(gridRank), stat=status) - _VERIFY(STATUS) + allocate(haloWidth(gridRank), _STAT) haloWidth = (/HW,HW,0/) if(present(default_value)) then @@ -184,12 +164,9 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end if ! SSI - call ESMF_VMGetCurrent(vm, rc=status) - _VERIFY(status) + call ESMF_VMGetCurrent(vm, _RC) - call ESMF_VMGet(vm, ssiSharedMemoryEnabledFlag=ssiSharedMemoryEnabled, & - rc=status) - _VERIFY(status) + call ESMF_VMGet(vm, ssiSharedMemoryEnabledFlag=ssiSharedMemoryEnabled, _RC) _ASSERT(ssiSharedMemoryEnabled, 'SSI shared memory is NOT supported') pinflag=ESMF_PIN_DE_TO_SSI_CONTIG ! requires support for SSI shared memory @@ -204,17 +181,19 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & rank = szungrd !ALT: This is special case - array does not map any gridded dims - gridToFieldMap= 0 + gridToFieldMap= 0 if (typekind == ESMF_KIND_R4) then select case (rank) case (1) - allocate(VAR_1D(UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(UNGRID(1)), _STAT) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & + _RC) case default _FAIL( 'unsupported rank > 1') end select @@ -222,19 +201,20 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (1) - allocate(VR8_1D(UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(UNGRID(1)), _STAT) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) + ungriddedLBound=[1],& + ungriddedUBound=[ungrid(1)], & + _RC) case default _FAIL( 'unsupported rank > 1') end select endif - _VERIFY(STATUS) ! Vertical only ! ------------- @@ -257,23 +237,27 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end select if (typekind == ESMF_KIND_R4) then - allocate(VAR_1D(lb1:ub1), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(lb1:ub1), _STAT) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=var_1d, & + call ESMF_FieldEmptyComplete(FIELD, farray=var_1d, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - RC=status) - _VERIFY(STATUS) + ungriddedLBound=[lb1],& + ungriddedUBound=[ub1], & + _RC) else - allocate(VR8_1D(lb1:ub1), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(lb1:ub1), _STAT) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=vr8_1d, & + call ESMF_FieldEmptyComplete(FIELD, farray=vr8_1d, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - RC=status) - _VERIFY(STATUS) + ungriddedLBound=[lb1],& + ungriddedUBound=[ub1], & + _RC) end if ! Horizontal only @@ -293,39 +277,30 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then RankCase2d: select case (rank) case (2) - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VAR_2D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_2D, _RC) VAR_2D = INIT_VALUE case (3) - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/1/), ungriddedUBound=(/UNGRID(1)/), & - pinflag=pinflag,rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag,_RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, _RC) VAR_3D = INIT_VALUE case (4) - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/1,1/), ungriddedUBound=(/UNGRID(1),UNGRID(2)/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, _RC) VAR_4D = INIT_VALUE case default _ASSERT(.false., 'only up to 4D are supported') @@ -333,45 +308,35 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (2) - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VR8_2D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_2D, _RC) VR8_2D = INIT_VALUE case (3) - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/1/), ungriddedUBound=(/UNGRID(1)/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, _RC) VR8_3D = INIT_VALUE case (4) - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/1,1/), ungriddedUBound=(/UNGRID(1),UNGRID(2)/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, _RC) VR8_4D = INIT_VALUE case default _ASSERT(.false., 'only up to 4D are supported') end select end if - _VERIFY(STATUS) ! Horz + Vert ! ----------- @@ -400,56 +365,43 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & RankCase3d: select case(rank) case (3) if (typekind == ESMF_KIND_R4) then - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/lb3/), ungriddedUBound=(/ub3/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_3D, _RC) VAR_3D = INIT_VALUE else - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/lb3/), ungriddedUBound=(/ub3/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_3D, _RC) VR8_3D = INIT_VALUE endif - _VERIFY(STATUS) case (4) if (typekind == ESMF_KIND_R4) then - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/lb3,1/), ungriddedUBound=(/ub3,ungrid(1)/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, _RC) VAR_4D = INIT_VALUE else - !if(MAPL_AM_I_ROOT()) print *, __FILE__, __LINE__, trim(name) call ESMF_FieldEmptyComplete(FIELD, typekind=ESMF_TYPEKIND_R8, & gridToFieldMap=gridToFieldMap, & totalLWidth=haloWidth(1:griddedDims), & totalUWidth=haloWidth(1:griddedDims), & ungriddedLBound=(/lb3,1/), ungriddedUBound=(/ub3,ungrid(1)/), & - pinflag=pinflag, rc = status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, rc = status) - _VERIFY(STATUS) + pinflag=pinflag, _RC) + call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, _RC) VR8_4D = INIT_VALUE endif @@ -458,7 +410,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end select RankCase3d ! Tiles - ! ----- + ! ----- case(MAPL_DimsTileOnly) rank = 1 + szungrd _ASSERT(gridRank == 1, 'gridRank /= 1') @@ -466,29 +418,28 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (typekind == ESMF_KIND_R4) then select case (rank) case (1) - allocate(VAR_1D(COUNTS(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_1D(COUNTS(1)), _STAT) VAR_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_1D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_1D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (2) - allocate(VAR_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(COUNTS(1),UNGRID(1)), _STAT) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (3) - allocate(VAR_3D(COUNTS(1), UNGRID(1), UNGRID(2)), & - STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_3D(COUNTS(1), UNGRID(1), UNGRID(2)), _STAT) VAR_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_3D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select @@ -496,74 +447,69 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & else select case (rank) case (1) - allocate(VR8_1D(COUNTS(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_1D(COUNTS(1)), _STAT) VR8_1D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_1D, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_1D, & + indexflag=ESMF_INDEX_DELOCAL, & + datacopyFlag = ESMF_DATACOPY_REFERENCE, & + _RC) case (2) - allocate(VR8_2D(COUNTS(1),UNGRID(1)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(COUNTS(1),UNGRID(1)), _STAT) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case (3) - allocate(VR8_3D(COUNTS(1), UNGRID(1), UNGRID(2)), & - STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_3D(COUNTS(1), UNGRID(1), UNGRID(2)), _STAT) VR8_3D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_3D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_3D, & + indexflag=ESMF_INDEX_DELOCAL, & gridToFieldMap=gridToFieldMap, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - rc = status) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select endif - _VERIFY(STATUS) case(MAPL_DimsTileTile) rank=2 _ASSERT(gridRank == 1, 'gridRank /= 1') if (typekind == ESMF_KIND_R4) then - allocate(VAR_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VAR_2D(COUNTS(1), COUNTS(2)), _STAT) VAR_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VAR_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VAR_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & - rc = status) + _RC) else - allocate(VR8_2D(COUNTS(1), COUNTS(2)), STAT=STATUS) - _VERIFY(STATUS) + allocate(VR8_2D(COUNTS(1), COUNTS(2)), _STAT) VR8_2D = INIT_VALUE - call ESMF_FieldEmptyComplete(FIELD, farrayPtr=VR8_2D, & + call ESMF_FieldEmptyComplete(FIELD, farray=VR8_2D, & + indexflag=ESMF_INDEX_DELOCAL, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & ! ungriddedLBound = (/1/), & ! ungriddedUBound = (/counts(2)/), & - rc = status) + _RC) endif - _VERIFY(STATUS) ! Invalid dimensionality ! ---------------------- - case default + case default _RETURN(ESMF_FAILURE) end select Dimensionality - _VERIFY(STATUS) if (present(default_value)) then call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & - VALUE=MAPL_InitialDefault, RC=STATUS) - _VERIFY(STATUS) + VALUE=MAPL_InitialDefault, _RC) end if ! Clean up @@ -589,26 +535,20 @@ module subroutine MAPL_FieldF90Deallocate(field, rc) integer :: rank type(ESMF_TypeKind_Flag) :: tk - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if (fieldStatus == ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_FieldGet(field, Array=array, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, Array=array, _RC) - call ESMF_ArrayGet(array, localDeCount=localDeCount, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localDeCount=localDeCount, _RC) _ASSERT(localDeCount == 1, 'currently MAPL supports only 1 local array') - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias call ESMF_LocalArrayGet(larray, rank=rank, typekind=tk, & - rc=status) - _VERIFY(STATUS) + _RC) - call ESMF_LocalArrayF90Deallocate(larray, typekind=tk, rank=rank, rc=status) - _VERIFY(STATUS) + call ESMF_LocalArrayF90Deallocate(larray, typekind=tk, rank=rank, _RC) end if _RETURN(ESMF_SUCCESS) @@ -641,32 +581,24 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) loc = index(name,';;') if(loc/=0) then - call ESMF_StateGet(state, name(:loc-1), Bundle, rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(state, name(loc+2:), Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name(:loc-1), Bundle, _RC) + call ESMF_StateGet(state, name(loc+2:), Field, _RC) else - call ESMF_StateGet(state, name, Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name, Field, _RC) end if - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) _ASSERT(fieldStatus /= ESMF_FIELDSTATUS_COMPLETE, 'fieldStatus == ESMF_FIELDSTATUS_COMPLETE') - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) _ASSERT(size(ptr,1) == COUNTS(1), 'shape mismatch dim=1') _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) do I = 1, gridRank gridToFieldMap(I) = I end do @@ -677,8 +609,7 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) call ESMF_FieldEmptyComplete(FIELD, farrayPtr=ptr, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) + _RC) ! Clean up deallocate(gridToFieldMap) @@ -714,32 +645,24 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) loc = index(name,';;') if(loc/=0) then - call ESMF_StateGet(state, name(:loc-1), Bundle, rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(state, name(loc+2:), Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name(:loc-1), Bundle, _RC) + call ESMF_StateGet(state, name(loc+2:), Field, _RC) else - call ESMF_StateGet(state, name, Field, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state, name, Field, _RC) end if - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) _ASSERT(fieldStatus /= ESMF_FIELDSTATUS_COMPLETE, 'fieldStatus == ESMF_FIELDSTATUS_COMPLETE') - call ESMF_FieldGet(field, grid=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=GRID, _RC) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) _ASSERT(size(ptr,1) == COUNTS(1), 'shape mismatch dim=1') _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) do I = 1, gridRank gridToFieldMap(I) = I end do @@ -747,8 +670,7 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) call ESMF_FieldEmptyComplete(FIELD, farrayPtr=ptr, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & gridToFieldMap=gridToFieldMap, & - rc = status) - _VERIFY(STATUS) + _RC) ! Clean up deallocate(gridToFieldMap) @@ -885,10 +807,8 @@ module subroutine MAPL_MakeDecomposition(nx, ny, unusable, reduceFactor, rc) _UNUSED_DUMMY(unusable) - call ESMF_VMGetCurrent(vm, rc=status) - _VERIFY(status) - call ESMF_VMGet(vm, petCount=pet_count, rc=status) - _VERIFY(status) + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet(vm, petCount=pet_count, _RC) if (present(reduceFactor)) pet_count=pet_count/reduceFactor ! count down from sqrt(n) @@ -972,32 +892,24 @@ module subroutine MAPL_ClimInterpFac (CLOCK,I1,I2,FAC, RC) type (ESMF_TimeInterval) :: oneMonth type (ESMF_Calendar) :: cal - call ESMF_ClockGet ( CLOCK, CurrTime=CurrTime, calendar=cal, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeGet ( CurrTime, midMonth=midMonth, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeIntervalSet( oneMonth, MM = 1, calendar=cal, rc=status ) - _VERIFY(STATUS) + call ESMF_ClockGet ( CLOCK, CurrTime=CurrTime, calendar=cal, _RC ) + call ESMF_TimeGet ( CurrTime, midMonth=midMonth, _RC ) + call ESMF_TimeIntervalSet( oneMonth, MM = 1, calendar=cal, _RC ) if( CURRTIME < midMonth ) then AFTER = midMonth midMonth = midMonth - oneMonth - call ESMF_TimeGet (midMonth, midMonth=BEFORE, rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (midMonth, midMonth=BEFORE, _RC ) else BEFORE = midMonth midMonth = midMonth + oneMonth - call ESMF_TimeGet (midMonth, midMonth=AFTER , rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (midMonth, midMonth=AFTER , _RC ) endif - call MAPL_Interp_Fac( CURRTIME, BEFORE, AFTER, FAC, RC=STATUS) - _VERIFY(STATUS) + call MAPL_Interp_Fac( CURRTIME, BEFORE, AFTER, FAC, _RC) - call ESMF_TimeGet (BEFORE, MM=I1, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_TimeGet (AFTER , MM=I2, rc=STATUS ) - _VERIFY(STATUS) + call ESMF_TimeGet (BEFORE, MM=I1, _RC ) + call ESMF_TimeGet (AFTER , MM=I2, _RC ) _RETURN(ESMF_SUCCESS) @@ -1213,21 +1125,17 @@ module subroutine MAPL_GetFieldTimeFromField ( FIELD, TIME, RC ) character(len=ESMF_MAXSTR) :: TIMESTAMP logical :: isPresent - call ESMF_AttributeGet(FIELD, NAME="TimeStamp", isPresent=isPresent, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME="TimeStamp", isPresent=isPresent, _RC) if(.not. isPresent) then - call ESMF_TimeSet (TIME, YY=0, RC=STATUS) + call ESMF_TimeSet (TIME, YY=0, _RC) else - call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, _RC) call MAPL_TimeStringGet (TIMESTAMP, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND ) - _VERIFY(STATUS) call ESMF_TimeSet (TIME, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND, & - RC=STATUS) - _VERIFY(STATUS) + _RC) end if _RETURN(ESMF_SUCCESS) @@ -1245,10 +1153,8 @@ module subroutine MAPL_SetFieldTimeFromField (FIELD, TIME, RC ) character(len=ESMF_MAXSTR) :: TIMESTAMP - call ESMF_TimeGet (TIME, timeString=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) - _VERIFY(STATUS) + call ESMF_TimeGet (TIME, timeString=TIMESTAMP, _RC) + call ESMF_AttributeSet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromField @@ -1265,10 +1171,8 @@ module subroutine MAPL_GetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) type(ESMF_FIELD) :: FIELD - call ESMF_StateGet (STATE, FIELDNAME, FIELD, RC=STATUS ) - _VERIFY(STATUS) - call MAPL_FieldGetTime (FIELD, TIME, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet (STATE, FIELDNAME, FIELD, _RC ) + call MAPL_FieldGetTime (FIELD, TIME, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GetFieldTimeFromState @@ -1286,14 +1190,13 @@ module subroutine MAPL_SetFieldTimeFromState ( STATE, Fieldname, TIME, RC ) type(ESMF_FIELD) :: FIELD - call ESMF_StateGet (STATE, FIELDNAME, FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_FieldSetTime (FIELD, TIME, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet (STATE, FIELDNAME, FIELD, _RC) + call MAPL_FieldSetTime (FIELD, TIME, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_SetFieldTimeFromState + module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) type (ESMF_Field), intent(INOUT) :: FIELD !ALT: IN character(len=*), intent(IN ) :: NAME @@ -1301,143 +1204,30 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) integer, optional, intent( OUT) :: RC type (ESMF_Field) :: F - ! we are creating new field so that we can change the name of the field; - ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) - ! are the SAME as the one in the original Field, if DoCopy flag is present - ! and set to true we create a new array and copy the data, not just reference it + ! we are creating new field so that we can change the name of the field; + ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) + ! are the SAME as the one in the original Field, if DoCopy flag is present + ! and set to true we create a new array and copy the data, not just reference it - type(ESMF_Grid) :: grid - character(len=ESMF_MAXSTR) :: fieldName - integer, allocatable :: gridToFieldMap(:) - integer :: gridRank - integer :: fieldRank integer :: status - integer :: unGridDims character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_FieldCreateRename' - logical :: hasUngridDims - integer :: notGridded logical :: DoCopy_ type(ESMF_DataCopy_Flag):: datacopy - type(ESMF_Array) :: array - real, pointer :: var_1d(:), var_2d(:,:) - real(kind=REAL64), pointer :: vr8_1d(:), vr8_2d(:,:) - type(ESMF_TypeKind_Flag) :: tk - -! SSI - integer, allocatable :: ulb(:), uub(:) -! SSI DoCopy_ = .false. if (present(DoCopy) ) then DoCopy_ = DoCopy end if - call ESMF_FieldGet(FIELD, grid=GRID, array=array, dimCount=fieldRank, & - name=fieldName, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, typekind=tk, RC=STATUS) - _VERIFY(STATUS) - - hasUngridDims = .false. - notGridded = count(gridToFieldMap==0) - unGridDims = fieldRank - gridRank + notGridded - !if(MAPL_AM_I_ROOT()) print '(a,i6,6i3,a)', __FILE__, __LINE__, fieldRank, gridRank, notGridded, unGridDims, gridToFieldMap, " "//trim(fieldName) - - if (unGridDims > 0) then - !hasUngridDims = .true. - allocate(ulb(unGridDims), stat=status) - _VERIFY(STATUS) - allocate(uub(unGridDims), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, ungriddedLBound=ulb, ungriddedUBound=uub, & - RC=STATUS) - _VERIFY(STATUS) - endif - - - if (doCopy_) then + if (doCopy_) then datacopy = ESMF_DATACOPY_VALUE else datacopy = ESMF_DATACOPY_REFERENCE end if - select case (fieldRank) - case (1) - f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, rc=status) - _VERIFY(STATUS) - if (tk == ESMF_TypeKind_R4) then - call ESMF_FieldGet(field, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=var_1d, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - else if (tk == ESMF_TypeKind_R8) then - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_1D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) - else - _ASSERT(.false., 'unsupported typekind') - endif - case (2) - if (unGridDims == 0) then - !if(MAPL_AM_I_ROOT()) print '(a,i6,6i3,a)', __FILE__, __LINE__, fieldRank, gridRank, notGridded, unGridDims, gridToFieldMap, " "//trim(fieldName) - F = ESMF_FieldCreate(grid, array, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - name=NAME, rc = status) - _VERIFY(STATUS) - else ! To handle some tile arrays - f = MAPL_FieldCreateEmpty(name=NAME, grid=grid, _RC) - if (tk == ESMF_TypeKind_R4) then - call ESMF_FieldGet(field, farrayPtr=var_2d, _RC) - call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, _RC) - else if (tk == ESMF_TypeKind_R8) then - call ESMF_FieldGet(field, farrayPtr=vr8_2d, _RC) - call ESMF_FieldEmptyComplete(F, farrayPtr=VR8_2D, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, _RC) - endif - endif - case (3) ! Third dimension is assumed ungridded - F = ESMF_FieldCreate(grid, array, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - ungriddedLBound=(/ulb(1)/), & - ungriddedUBound=(/uub(1)/), & - name=NAME, rc = status) - _VERIFY(STATUS) - case (4) ! Third and fourth dimensions are assumed ungridded - F = ESMF_FieldCreate(grid, array, & - gridToFieldMap=gridToFieldMap, & - datacopyFlag = datacopy, & - ungriddedLBound=(/ulb(1), ulb(2)/), & - ungriddedUBound=(/uub(1), uub(2)/), & - name=NAME, rc = status) - _VERIFY(STATUS) - case default - _ASSERT(.false., 'only upto 4D are supported') - end select - - if (unGridDims > 0) then - deallocate(ulb) - deallocate(uub) - endif - deallocate(gridToFieldMap) + f = ESMF_FieldCreate(field, datacopyflag=datacopy, name=NAME, _RC) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateRename @@ -1480,43 +1270,32 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) character(len=ESMF_MAXSTR) :: newName_ character(len=ESMF_MAXSTR), parameter :: Iam='MAPL_FieldCreateNewgrid' - call ESMF_FieldGet(FIELD, grid=fgrid, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(FIELD, grid=fgrid, _RC) - call ESMF_GridGet(fGRID, dimCount=fgridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(fgridRank), stat=status) - _VERIFY(STATUS) + call ESMF_GridGet(fGRID, dimCount=fgridRank, _RC) + allocate(gridToFieldMap(fgridRank), _STAT) call ESMF_FieldGet(FIELD, Array=Array, name=name, & - gridToFieldMap=gridToFieldMap, RC=STATUS) - _VERIFY(STATUS) + gridToFieldMap=gridToFieldMap, _RC) griddedDims = fgridRank - count(gridToFieldMap == 0) - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) - call ESMF_ArrayGet(array, rank=rank, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, rank=rank, _RC) ungriddedDims = rank - griddedDims - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, _RC) - call ESMF_ArrayGet(array, localDeCount=localDeCount, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localDeCount=localDeCount, _RC) _ASSERT(localDeCount == 1, 'MAPL supports only 1 local array') - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias - call ESMF_LocalArrayGet(larray, totalLBound=lbnds, totalUBound=ubnds, rc=status) - _VERIFY(STATUS) + call ESMF_LocalArrayGet(larray, totalLBound=lbnds, totalUBound=ubnds, _RC) newRank = rank if (griddedDims == 1 .and. gridRank > 1) then deallocate(gridToFieldMap) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + allocate(gridToFieldMap(gridRank), _STAT) gridToFieldMap = 0 do I = 1, 2 gridToFieldMap(I) = I @@ -1533,8 +1312,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) if (newRank == 2) then F = ESMF_FieldCreate(GRID, typekind=ESMF_TYPEKIND_R4, & indexflag=ESMF_INDEX_DELOCAL, & - name=newName_, gridToFieldMap=gridToFieldMap, RC=STATUS ) - _VERIFY(STATUS) + name=newName_, gridToFieldMap=gridToFieldMap, _RC ) DIMS = MAPL_DimsHorzOnly else if (newRank == 3) then @@ -1548,7 +1326,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) F = ESMF_FieldCreate(GRID, typekind=ESMF_TYPEKIND_R4, & indexflag=ESMF_INDEX_DELOCAL, & name=newName_, gridToFieldMap=gridToFieldMap, & - ungriddedLBound=[lb],ungriddedUBound=[ub],RC=STATUS ) + ungriddedLBound=[lb],ungriddedUBound=[ub],_RC ) if (ungriddedDims > 0) then DIMS = MAPL_DimsHorzOnly else @@ -1559,7 +1337,7 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) indexflag=ESMF_INDEX_DELOCAL, & name=newName_, gridToFieldMap=gridToFieldMap, & ungriddedLBound=[lbnds(griddedDims+1),lbnds(griddedDims+2)], & - ungriddedUBound=[ubnds(griddedDims+1),ubnds(griddedDims+2)],RC=STATUS ) + ungriddedUBound=[ubnds(griddedDims+1),ubnds(griddedDims+2)],_RC ) if (ungriddedDims > 0) then DIMS = MAPL_DimsHorzOnly else @@ -1571,12 +1349,10 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) deallocate(gridToFieldMap) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) ! we are saving DIMS attribute in case the FIELD did not contain one ! otherwise we will overwrite it - call ESMF_AttributeSet(F, NAME='DIMS', VALUE=DIMS, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(F, NAME='DIMS', VALUE=DIMS, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateNewgrid @@ -1608,71 +1384,54 @@ module function MAPL_FieldCreateR4(FIELD, RC) RESULT(F) type(ESMF_TypeKind_Flag) :: tk call ESMF_FieldGet(FIELD, grid=GRID, dimCount=fieldRank, & - name=fieldName, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + name=fieldName, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R8, 'tk /= ESMF_TypeKind_R8') - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) - call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, RC=STATUS) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) + call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, _RC) datacopy = ESMF_DATACOPY_REFERENCE select case (fieldRank) case (1) - call ESMF_FieldGet(field, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - allocate(var_1d(lbound(vr8_1d,1):ubound(vr8_1d,1)), stat=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_1d, _RC) + allocate(var_1d(lbound(vr8_1d,1):ubound(vr8_1d,1)), _STAT) var_1d=vr8_1d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_1D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case (2) - call ESMF_FieldGet(field, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_2d, _RC) allocate(var_2d(lbound(vr8_2d,1):ubound(vr8_2d,1), & lbound(vr8_2d,2):ubound(vr8_2d,2)), & - stat=status) - _VERIFY(STATUS) + _STAT) var_2d=vr8_2d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_2D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case (3) - call ESMF_FieldGet(field, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayPtr=vr8_3d, _RC) allocate(var_3d(lbound(vr8_3d,1):ubound(vr8_3d,1), & lbound(vr8_3d,2):ubound(vr8_3d,2), & lbound(vr8_3d,3):ubound(vr8_3d,3)), & - stat=status) - _VERIFY(STATUS) + _STAT) var_3d=vr8_3d - f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, rc=status) - _VERIFY(STATUS) + f = MAPL_FieldCreateEmpty(name=fieldNAME, grid=grid, _RC) call ESMF_FieldEmptyComplete(F, farrayPtr=VAR_3D, & gridToFieldMap=gridToFieldMap, & datacopyFlag = datacopy, & - rc = status) - _VERIFY(STATUS) + _RC) case default _FAIL( 'only 2D and 3D are supported') end select deallocate(gridToFieldMap) - call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, RC=status) - _VERIFY(STATUS) + call MAPL_FieldCopyAttributes(FIELD_IN=field, FIELD_OUT=f, _RC) _RETURN(ESMF_SUCCESS) end function MAPL_FieldCreateR4 @@ -1686,14 +1445,12 @@ module function MAPL_FieldCreateEmpty(NAME, GRID, RC) RESULT(FIELD) character(len=ESMF_MAXSTR),parameter :: IAm=" MAPL_FieldCreateEmpty" integer :: STATUS - FIELD = ESMF_FieldEmptyCreate(name=name, rc=status) - _VERIFY(STATUS) + FIELD = ESMF_FieldEmptyCreate(name=name, _RC) call ESMF_FieldEmptySet(FIELD, & grid=GRID, & staggerloc = ESMF_STAGGERLOC_CENTER, & - rc = status) - _VERIFY(STATUS) + _RC) _RETURN(ESMF_SUCCESS) @@ -1705,8 +1462,7 @@ module subroutine MAPL_FieldCopyAttributes(FIELD_IN, FIELD_OUT, RC) integer, optional, intent( OUT) :: RC integer :: status - call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, rc=status) - _VERIFY(status) + call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_FieldCopyAttributes @@ -1732,40 +1488,30 @@ module subroutine MAPL_FieldCopy(from, to, RC) type(ESMF_TypeKind_Flag) :: tk call ESMF_FieldGet(from, dimCount=fieldRank, & - typekind=tk, RC=STATUS) - _VERIFY(STATUS) + typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R8, 'inconsistent typekind (should be ESMF_TypeKind_R8)') select case (fieldRank) case (1) - call ESMF_FieldGet(from, farrayPtr=vr8_1d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_1d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==1, 'inconsistent fieldrank (should be 1)') - call ESMF_FieldGet(to, farrayPtr=var_1d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_1d, _RC) var_1d = vr8_1d case (2) - call ESMF_FieldGet(from, farrayPtr=vr8_2d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_2d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==2, 'inconsistent fieldRank (should be 2)') - call ESMF_FieldGet(to, farrayPtr=var_2d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_2d, _RC) var_2d = vr8_2d case (3) - call ESMF_FieldGet(from, farrayPtr=vr8_3d, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldGet(from, farrayPtr=vr8_3d, _RC) + call ESMF_FieldGet(to, dimCount=fieldRank, typekind=tk, _RC) _ASSERT(tk == ESMF_TypeKind_R4, 'inconsistent typekind (should be ESMF_TypeKind_R4)') _ASSERT(fieldRank==3,'inconsistent fieldRank (should be 3)') - call ESMF_FieldGet(to, farrayPtr=var_3d, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(to, farrayPtr=var_3d, _RC) var_3d = vr8_3d case default _FAIL( 'unsupported fieldRank (> 3)') @@ -1809,24 +1555,25 @@ module subroutine MAPL_GRID_INTERIOR(GRID,I1,IN,J1,JN) integer :: deId integer :: gridRank integer, allocatable :: localDeToDeMap(:) + integer :: rc i1=-1 j1=-1 in=-1 jn=-1 - call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, rc=STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - call ESMF_DELayoutGet(layout, deCount = nDEs, localDeCount=localDeCount,rc=status) + call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, _RC) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, deCount = nDEs, localDeCount=localDeCount,_RC) if (localDeCount > 0) then - allocate(localDeToDeMap(localDeCount),stat=status) - call ESMF_DELayoutGet(layout, localDEtoDeMap=localDeToDeMap,rc=status) + allocate(localDeToDeMap(localDeCount),_STAT) + call ESMF_DELayoutGet(layout, localDEtoDeMap=localDeToDeMap,_RC) deId=localDeToDeMap(1) - allocate (AL(gridRank,0:nDEs-1), stat=status) - allocate (AU(gridRank,0:nDEs-1), stat=status) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPl_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) + minIndex=AL, maxIndex=AU, _RC) I1 = AL(1, deId) IN = AU(1, deId) @@ -2022,10 +1769,8 @@ module function MAPL_LatLonGridCreate (Name, vm, & if ( present(vm) ) then vm_ => vm else - allocate(vm_, stat=STATUS) - _VERIFY(STATUS) - call ESMF_VMGetCurrent(vm_, rc=STATUS) - _VERIFY(STATUS) + allocate(vm_, _STAT) + call ESMF_VMGetCurrent(vm_, _RC) end if ! Grid info via resources @@ -2035,17 +1780,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Either use supplied Config or load resource file ! ------------------------------------------------ if ( present(ConfigFile) ) then - allocate(Config_,stat=STATUS) - _VERIFY(STATUS) - Config_ = ESMF_ConfigCreate (rc=STATUS ) - _VERIFY(STATUS) - call ESMF_ConfigLoadFile (Config_, ConfigFile, rc=STATUS ) - _VERIFY(STATUS) + allocate(Config_,_STAT) + Config_ = ESMF_ConfigCreate (_RC ) + call ESMF_ConfigLoadFile (Config_, ConfigFile, _RC ) else if ( present(Config) ) then Config_ => Config else STATUS = 100 - _VERIFY(STATUS) end if ! Get relevant parameters from Config @@ -2079,7 +1820,6 @@ module function MAPL_LatLonGridCreate (Name, vm, & else STATUS = 300 - _VERIFY(STATUS) end if @@ -2087,7 +1827,6 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! ------------ if ( IM_World_ < 1 .OR. JM_World_ < 1 ) then STATUS = 400 - _VERIFY(STATUS) end if if ( DelLon_ < 0.0 ) then ! convention for global grids if ( IM_World_ == 1 ) then @@ -2106,8 +1845,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Give the IMs, JMs and LMs the MAPL default distribution ! ------------------------------------------------------- - allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), stat=STATUS) - _VERIFY(STATUS) + allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), _STAT) call MAPL_DecomposeDim ( IM_World_, IMs, Nx_ ) call MAPL_DecomposeDim ( JM_World_, JMs, Ny_ ) call MAPL_DecomposeDim ( LM_World_, LMs, Nz_ ) @@ -2132,8 +1870,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & coordDep3 = (/3/), & gridEdgeLWidth = (/0,0,0/), & gridEdgeUWidth = (/0,0,0/), & - rc=STATUS) - _VERIFY(STATUS) + _RC) #else Grid = ESMF_GridCreate( & name=Name, & @@ -2144,11 +1881,9 @@ module function MAPL_LatLonGridCreate (Name, vm, & gridEdgeUWidth = (/0,0/), & coordDep1 = (/1,2/), & coordDep2 = (/1,2/), & - rc=status) - _VERIFY(STATUS) + _RC) - call ESMF_AttributeSet(grid, name='GRID_LM', value=LM_World, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(grid, name='GRID_LM', value=LM_World, _RC) #endif @@ -2163,15 +1898,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & coordDep2 = (/1,2/), & gridEdgeLWidth = (/0,0/), & gridEdgeUWidth = (/0,0/), & - rc=STATUS) - _VERIFY(STATUS) + _RC) ! Other possibilities not implemented yet ! --------------------------------------- else STATUS = 300 - _VERIFY(STATUS) endif @@ -2183,8 +1916,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Allocate coords at default stagger location ! ------------------------------------------- - call ESMF_GridAddCoord(Grid, rc=status) - _VERIFY(STATUS) + call ESMF_GridAddCoord(Grid, _RC) ! Compute the coordinates (the corner/center is for backward compatibility) ! ------------------------------------------------------------------------- @@ -2193,8 +1925,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & minCoord(1) = MAPL_DEGREES_TO_RADIANS_R8 * BegLon_ - deltaX/2 minCoord(2) = MAPL_DEGREES_TO_RADIANS_R8 * BegLat_ - deltaY/2 - allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), stat=STATUS) - _VERIFY(STATUS) + allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), _STAT) cornerX(1) = minCoord(1) do i = 1,IM_World_ @@ -2210,13 +1941,11 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! ------------------------------------------- call ESMF_GridGetCoord (Grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerX, rc=status) - _VERIFY(STATUS) + farrayPtr=centerX, _RC) call ESMF_GridGetCoord (Grid, coordDim=2, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=centerY, rc=status) - _VERIFY(STATUS) + farrayPtr=centerY, _RC) FirstOut(1)=BegLon_ FirstOut(2)=-90. @@ -2248,8 +1977,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Make sure we've got it right ! ---------------------------- - call ESMF_GridValidate(Grid,rc=status) - _VERIFY(STATUS) + call ESMF_GridValidate(Grid,_RC) ! Clean up ! -------- @@ -2269,7 +1997,6 @@ subroutine parseConfig_() ! Internal routine to parse the ESMF_Config. ! STATUS = 200 ! not implemented yet - _VERIFY(STATUS) end subroutine parseConfig_ @@ -2294,32 +2021,25 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) real(ESMF_KIND_R8), allocatable :: r8ptr(:),lons1d(:),lats1d(:) type(ESMF_CoordSys_Flag) :: coordSys - call MAPL_GridGet(grid,localCellCountPerDim=counts,rc=status) - _VERIFY(status) + call MAPL_GridGet(grid,localCellCountPerDim=counts,_RC) im=counts(1) jm=counts(2) ! check if we have corners call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - isPresent=hasLons, RC=STATUS) - _VERIFY(status) + isPresent=hasLons, _RC) call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - isPresent=hasLats, RC=STATUS) - _VERIFY(status) + isPresent=hasLats, _RC) if (hasLons .and. hasLats) then call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - itemcount=lsz, RC=STATUS) - _VERIFY(STATUS) + itemcount=lsz, _RC) _ASSERT(size(gridCornerLons,1)*size(gridCornerLons,2)==lsz,"stored corner sizes to not match grid") call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - itemcount=lsz, RC=STATUS) - _VERIFY(STATUS) + itemcount=lsz, _RC) _ASSERT(size(gridCornerLats,1)*size(gridCornerLats,2)==lsz,"stored corner sizes to not match grid") - allocate(r8ptr(lsz),stat=status) - _VERIFY(status) + allocate(r8ptr(lsz),_STAT) call ESMF_AttributeGet(grid, NAME='GridCornerLons:', & - VALUELIST=r8ptr, RC=STATUS) - _VERIFY(STATUS) + VALUELIST=r8ptr, _RC) idx = 0 do j = 1, size(gridCornerLons,2) @@ -2330,8 +2050,7 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) end do call ESMF_AttributeGet(grid, NAME='GridCornerLats:', & - VALUELIST=r8ptr, RC=STATUS) - _VERIFY(STATUS) + VALUELIST=r8ptr, _RC) idx = 0 do j = 1, size(gridCornerLons,2) @@ -2344,47 +2063,36 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) else call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner, rc=status) + farrayPtr=corner, _RC) imc=size(corner,1) jmc=size(corner,2) - allocate(ptr(0:imc+1,0:jmc+1),source=0.0d0,stat=status) - _VERIFY(status) - field = ESMF_FieldCreate(grid,ptr,staggerLoc=ESMF_STAGGERLOC_CORNER,totalLWidth=[1,1],totalUWidth=[1,1],rc=status) - _VERIFY(status) - call ESMF_FieldHaloStore(field,rh,rc=status) - _VERIFY(status) + allocate(ptr(0:imc+1,0:jmc+1),source=0.0d0,_STAT) + field = ESMF_FieldCreate(grid,ptr,staggerLoc=ESMF_STAGGERLOC_CORNER,totalLWidth=[1,1],totalUWidth=[1,1],_RC) + call ESMF_FieldHaloStore(field,rh,_RC) ptr(1:imc,1:jmc)=corner - call ESMF_FieldHalo(field,rh,rc=status) - _VERIFY(status) + call ESMF_FieldHalo(field,rh,_RC) gridCornerLons=ptr(1:im+1,1:jm+1) call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner, rc=status) - _VERIFY(status) + farrayPtr=corner, _RC) ptr(1:imc,1:jmc)=corner - call ESMF_FieldHalo(field,rh,rc=status) - _VERIFY(status) + call ESMF_FieldHalo(field,rh,_RC) gridCornerLats=ptr(1:im+1,1:jm+1) deallocate(ptr) - call ESMF_FieldDestroy(field,rc=status) - _VERIFY(status) - call ESMF_FieldHaloRelease(rh,rc=status) - _VERIFY(status) + call ESMF_FieldDestroy(field,_RC) + call ESMF_FieldHaloRelease(rh,_RC) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(status) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) if (coordSys==ESMF_COORDSYS_SPH_DEG) then gridCornerLons=gridCornerLons*MAPL_DEGREES_TO_RADIANS_R8 gridCornerLats=gridCornerLats*MAPL_DEGREES_TO_RADIANS_R8 else if (coordSys==ESMF_COORDSYS_CART) then _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') end if - allocate(lons1d(size(gridCornerLons,1)*size(gridCornerLons,2)),stat=status) - _VERIFY(status) - allocate(lats1d(size(gridCornerLons,1)*size(gridCornerLons,2)),stat=status) - _VERIFY(status) + allocate(lons1d(size(gridCornerLons,1)*size(gridCornerLons,2)),_STAT) + allocate(lats1d(size(gridCornerLons,1)*size(gridCornerLons,2)),_STAT) idx = 0 do j=1,size(gridCornerLons,2) do i=1,size(gridCornerLons,1) @@ -2394,11 +2102,9 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) enddo enddo call ESMF_AttributeSet(grid, name='GridCornerLons:', & - itemCount = idx, valueList=lons1d, rc=status) - _VERIFY(STATUS) + itemCount = idx, valueList=lons1d, _RC) call ESMF_AttributeSet(grid, name='GridCornerLats:', & - itemCount = idx, valueList=lats1d, rc=status) - _VERIFY(STATUS) + itemCount = idx, valueList=lats1d, _RC) deallocate(lons1d,lats1d) end if @@ -2429,17 +2135,18 @@ module subroutine MAPL_GridGetInterior(GRID,I1,IN,J1,JN) integer :: nDEs integer :: deId integer :: gridRank + integer :: rc - call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, rc=STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - call ESMF_DELayoutGet(layout, vm=vm, rc=status) - call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status) + call ESMF_GridGet (GRID, dimCount=gridRank, distGrid=distGrid, _RC) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, vm=vm, _RC) + call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, _RC) - allocate (AL(gridRank,0:nDEs-1), stat=status) - allocate (AU(gridRank,0:nDEs-1), stat=status) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPL_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) + minIndex=AL, maxIndex=AU, _RC) I1 = AL(1, deId) IN = AU(1, deId) @@ -2535,37 +2242,26 @@ recursive module subroutine MAPL_StateAttSetI4(STATE, NAME, VALUE, RC) integer :: ITEMCOUNT integer :: I - call ESMF_AttributeSet(STATE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(STATE, NAME, VALUE, _RC) - call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,_RC) IF (ITEMCOUNT>0) then - allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES(ITEMCOUNT),_STAT) + allocate(ITEMTYPES(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE, ITEMNAMELIST=ITEMNAMES, & - ITEMTYPELIST=ITEMTYPES, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES, _RC) do I = 1, ITEMCOUNT if(itemtypes(I)==ESMF_StateItem_State) then - call ESMF_StateGet(STATE, itemNames(I), nestedState, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(nestedState, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), nestedState, _RC) + call MAPL_AttributeSet(nestedState, NAME, VALUE, _RC) else if(itemtypes(I)==ESMF_StateItem_FieldBundle) then - call ESMF_StateGet(STATE, itemNames(I), BUNDLE, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(BUNDLE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), BUNDLE, _RC) + call MAPL_AttributeSet(BUNDLE, NAME, VALUE, _RC) else if(itemtypes(I)==ESMF_StateItem_Field) then - call ESMF_StateGet(STATE, itemNames(I), FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE, itemNames(I), FIELD, _RC) + call MAPL_AttributeSet(FIELD, NAME, VALUE, _RC) end if end do @@ -2590,17 +2286,13 @@ module subroutine MAPL_BundleAttSetI4(BUNDLE, NAME, VALUE, RC) integer :: FIELDCOUNT integer :: I - call ESMF_AttributeSet(BUNDLE, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(BUNDLE, NAME, VALUE, _RC) - call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, _RC) do I = 1, FIELDCOUNT - call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, I, FIELD, _RC) + call ESMF_AttributeSet(FIELD, NAME, VALUE, _RC) end do _RETURN(ESMF_SUCCESS) @@ -2620,17 +2312,13 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) type(ESMF_FieldStatus_Flag) :: fieldStatus - call ESMF_AttributeSet(FIELD, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME, VALUE, _RC) - call ESMF_FieldGet(field, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, status=fieldStatus, _RC) if(fieldStatus == ESMF_FIELDSTATUS_COMPLETE) then - call ESMF_FieldGet(field, Array=array, rc=status) - _VERIFY(STATUS) - call ESMF_AttributeSet(array, NAME, VALUE, RC=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, Array=array, _RC) + call ESMF_AttributeSet(array, NAME, VALUE, _RC) end if _RETURN(ESMF_SUCCESS) @@ -2650,17 +2338,13 @@ module subroutine MAPL_FieldBundleDestroy(Bundle,RC) integer :: STATUS - isCreated = ESMF_FieldBundleIsCreated(bundle,rc=status) - _VERIFY(STATUS) + isCreated = ESMF_FieldBundleIsCreated(bundle,_RC) if(isCreated) then - call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, _RC) do I = 1, FIELDCOUNT - call ESMF_FieldBundleGet(BUNDLE, I, FIELD, RC=STATUS) - _VERIFY(STATUS) - call MAPL_FieldDestroy(FIELD, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, I, FIELD, _RC) + call MAPL_FieldDestroy(FIELD, _RC) end do end if @@ -2688,49 +2372,40 @@ module subroutine MAPL_StateAddField(State, Field, RC) logical :: haveAttr fields(1) = field - call ESMF_StateAdd(state, fields, RC=status) - _VERIFY(STATUS) + call ESMF_StateAdd(state, fields, _RC) !================= !!!ALT Example to add one field at the time (not used anymore) !!! call ESMF_StateAdd(STATE, FIELD, proxyflag=.false., & -!!! addflag=.true., replaceflag=.false., RC=STATUS ) +!!! addflag=.true., replaceflag=.false., _RC ) !================= ! check for attribute - call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(state, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(state, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldGet(field, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2759,44 +2434,35 @@ module subroutine MAPL_StateAddBundle(State, Bundle, RC) logical :: haveAttr bundles(1) = bundle - call ESMF_StateAdd(state, Bundles, RC=status) - _VERIFY(STATUS) + call ESMF_StateAdd(state, Bundles, _RC) ! check for attribute - call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(state, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(state, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldBundleGet(bundle, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(bundle, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(state, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2826,44 +2492,35 @@ module subroutine MAPL_FieldBundleAddField(Bundle, Field, multiflag, RC) fields(1) = field - call ESMF_FieldBundleAdd(Bundle, fields, multiflag=multiflag, RC=status) - _VERIFY(STATUS) + call ESMF_FieldBundleAdd(Bundle, fields, multiflag=multiflag, _RC) ! check for attribute - call ESMF_AttributeGet(Bundle, NAME=attrName, isPresent=haveAttr, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, isPresent=haveAttr, _RC) if (haveAttr) then - call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, _RC) else natt = 0 end if - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + allocate(currList(natt), _STAT) if (natt > 0) then ! get the current list - call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, _RC) !ALT delete/destroy this attribute to prevent memory leaks - call ESMF_AttributeRemove(bundle, NAME=attrName, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeRemove(bundle, NAME=attrName, _RC) end if na = natt+1 - allocate(thisList(na), stat=status) - _VERIFY(STATUS) + allocate(thisList(na), _STAT) thisList(1:natt) = currList - call ESMF_FieldGet(field, name=name, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, name=name, _RC) thisList(na) = name - call ESMF_AttributeSet(bundle, NAME=attrName, itemcount=na, VALUELIST=thisList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeSet(bundle, NAME=attrName, itemcount=na, VALUELIST=thisList, _RC) deallocate(thisList) deallocate(currList) @@ -2890,18 +2547,14 @@ module subroutine MAPL_FieldBundleGetByIndex(Bundle, fieldIndex, Field, RC) ! check for attribute - call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, RC=STATUS) - _VERIFY(STATUS) - allocate(currList(natt), stat=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, itemcount=natt, _RC) + allocate(currList(natt), _STAT) ! get the current list - call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(Bundle, NAME=attrName, VALUELIST=currList, _RC) name = currList(fieldIndex) - call ESMF_FieldBundleGet(Bundle, fieldName = name, field=field, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(Bundle, fieldName = name, field=field, _RC) deallocate(currList) @@ -2953,8 +2606,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) ! pass in the the dimensions of the grid and we must compute them ! and assume search on the global domain if (present(Grid)) then - call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,rc=status) - _VERIFY(STATUS) + call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,_RC) IM_World = dims(1) JM_World = dims(2) IM = counts(1) @@ -2978,13 +2630,10 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) call ESMF_AttributeGet(grid, name='GridType', value=grid_type, _RC) if(trim(grid_type) == "Cubed-Sphere") then call ESMF_GridGetCoord(grid,coordDim=1, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, rc=status) - _VERIFY(STATUS) + staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, _RC) call ESMF_GridGetCoord(grid,coordDim=2, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, rc=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(STATUS) + staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, _RC) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) allocate(corner_lons(im+1,jm+1)) allocate(corner_lats(im+1,jm+1)) allocate(center_lons(im,jm),center_lats(im,jm)) @@ -2998,11 +2647,10 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else if (coordSys==ESMF_COORDSYS_CART) then _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') end if - call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,rc=status) + call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,_RC) ii=-1 jj=-1 - call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,rc=status) - _VERIFY(status) + call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,_RC) deallocate(corner_lons,corner_lats, center_lons,center_lats) else if (localSearch) then @@ -3013,12 +2661,9 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else _FAIL('if not isCubed, localSearch must be .true.') end if - allocate(elons(im+1),stat=status) - _VERIFY(STATUS) - allocate(elats(jm+1),stat=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid,coordSys=coordSys,rc=status) - _VERIFY(STATUS) + allocate(elons(im+1),_STAT) + allocate(elats(jm+1),_STAT) + call ESMF_GridGet(grid,coordSys=coordSys,_RC) elons = lons(:,1) elats = lats(1,:) if (coordSys==ESMF_COORDSYS_SPH_DEG) then @@ -3133,8 +2778,7 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, if ( .not. present(grid)) then _ASSERT(.false., "need a cubed-sphere grid") endif - call MAPL_GridGet(grid, globalCellCountPerDim=dims,rc=status) - _VERIFY(STATUS) + call MAPL_GridGet(grid, globalCellCountPerDim=dims,_RC) IM_World = dims(1) JM_World = dims(2) _ASSERT( IM_WORLD*6 == JM_WORLD, "It only works for cubed-sphere grid") @@ -3237,7 +2881,7 @@ function grid_is_ok(grid) result(OK) type(ESMF_Grid), intent(inout) :: grid logical :: OK integer :: I1, I2, J1, J2, j - real(ESMF_KIND_R8), pointer :: corner_lons(:,:), corner_lats(:,:) + real(ESMF_KIND_R8), allocatable :: corner_lons(:,:), corner_lats(:,:) real(ESMF_KIND_R8) :: accurate_lat, accurate_lon real :: tolerance @@ -3245,11 +2889,9 @@ function grid_is_ok(grid) result(OK) call MAPL_GridGetInterior(grid,I1,I2,J1,J2) OK = .true. ! check the edge of face 1 along longitude - call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner_lons, rc=status) - call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=corner_lats, rc=status) - + allocate(corner_lons(I2-I1+2, J2-J1+2)) + allocate(corner_lats(I2-I1+2, J2-J1+2)) + call MAPL_GridGetCorners(Grid,corner_lons,corner_lats) if ( I1 ==1 .and. J2<=IM_WORLD ) then if (J1 == 1) then accurate_lon = 1.750d0*MAPL_PI_R8 - shift @@ -3262,7 +2904,7 @@ function grid_is_ok(grid) result(OK) endif endif - do j = J1+1, J2 + do j = J1, J2+1 accurate_lat = -alpha + (j-1)*dalpha if ( abs(accurate_lat - corner_lats(1,j-J1+1)) > 5.0*tolerance) then print*, "accurate_lat: ", accurate_lat @@ -3459,16 +3101,14 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un integer :: gridRank type(ESMF_Field) :: field - allocate(localIs2D(size(fieldNames)),stat=status) - _VERIFY(STATUS) + allocate(localIs2D(size(fieldNames)),_STAT) if (present(is2D)) then _ASSERT(size(fieldNames) == size(is2D),'inconsistent size of is2D array') localIs2D = is2D else localIs2D = .false. end if - allocate(localIsEdge(size(fieldNames)),stat=status) - _VERIFY(STATUS) + allocate(localIsEdge(size(fieldNames)),_STAT) if (present(isEdge)) then _ASSERT(size(fieldNames) == size(isEdge), 'inconsistent size of isEdge array') localIsEdge = isEdge @@ -3482,23 +3122,17 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un _ASSERT(size(fieldNames) == size(units), 'inconsistent size of units array') end if - B = ESMF_FieldBundleCreate ( name=name, rc=STATUS ) - _VERIFY(STATUS) - call ESMF_FieldBundleSet ( B, grid=GRID, rc=STATUS ) - _VERIFY(STATUS) + B = ESMF_FieldBundleCreate ( name=name, _RC ) + call ESMF_FieldBundleSet ( B, grid=GRID, _RC ) call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, & - localCellCountPerDim=DIMS, RC=STATUS) - _VERIFY(STATUS) + localCellCountPerDim=DIMS, _RC) do i=1,size(fieldnames) if (localIs2D(i)) then - allocate(PTR2(DIMS(1),DIMS(2)),stat=STATUS) - _VERIFY(STATUS) + allocate(PTR2(DIMS(1),DIMS(2)),_STAT) PTR2 = 0.0 - call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) - _VERIFY(STATUS) - allocate(gridToFieldMap(gridRank), stat=status) - _VERIFY(STATUS) + call ESMF_GridGet(GRID, dimCount=gridRank, _RC) + allocate(gridToFieldMap(gridRank), _STAT) if(gridRank == 2) then gridToFieldMap(1) = 1 gridToFieldMap(2) = 2 @@ -3512,53 +3146,40 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un FIELD = ESMF_FieldCreate(grid=GRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & farrayPtr=PTR2, gridToFieldMap=gridToFieldMap, & - name=fieldNames(i), RC=STATUS) - _VERIFY(STATUS) + name=fieldNames(i), _RC) deallocate(gridToFieldMap) - call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzOnly, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationNone, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzOnly, _RC) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationNone, _RC) else if (localIsEdge(i)) then - allocate(PTR3(Dims(1),Dims(2),0:counts(3)),stat=status) - _VERIFY(STATUS) + allocate(PTR3(Dims(1),Dims(2),0:counts(3)),_STAT) else - allocate(PTR3(Dims(1),Dims(2),counts(3)),stat=status) - _VERIFY(STATUS) + allocate(PTR3(Dims(1),Dims(2),counts(3)),_STAT) end if PTR3 = 0.0 FIELD = ESMF_FieldCreate(grid=GRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - farrayPtr=PTR3, name=fieldNames(i), RC=STATUS) - call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzVert, RC=STATUS) - _VERIFY(STATUS) + farrayPtr=PTR3, name=fieldNames(i), _RC) + call ESMF_AttributeSet(FIELD, NAME='DIMS', VALUE=MAPL_DimsHorzVert, _RC) if (localIsEdge(i)) then - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationEdge, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationEdge, _RC) else - call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationCenter, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='VLOCATION', VALUE=MAPL_VLocationCenter, _RC) end if end if if (present(long_names)) then - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=long_names(i), RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=long_names(i), _RC) else - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", _RC) end if if (present(units)) then - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=units(i), RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE=units(i), _RC) else - call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeSet(FIELD, NAME='LONG_NAME', VALUE="UNKNOWN", _RC) end if - call MAPL_FieldBundleAdd(B, FIELD, RC=STATUS) - _VERIFY(STATUS) + call MAPL_FieldBundleAdd(B, FIELD, _RC) enddo deallocate(localIs2D) @@ -3578,11 +3199,9 @@ module function MAPL_TrimString(istring,rc) result(ostring) strlen = len_trim(istring) if (istring(strlen:strlen)==char(0)) then - allocate(ostring,source=istring(1:strlen-1),stat=status) - _VERIFY(status) + allocate(ostring,source=istring(1:strlen-1),_STAT) else - allocate(ostring,source=istring(1:strlen),stat=status) - _VERIFY(status) + allocate(ostring,source=istring(1:strlen),_STAT) end if _RETURN(_SUCCESS) end function MAPL_TrimString @@ -3597,57 +3216,23 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) integer :: status integer :: k, n integer :: k1,k2,kk - integer :: gridRank - logical :: has_ungrd integer :: ungrd_cnt integer :: fieldRank - integer, allocatable :: gridToFieldMap(:) integer, allocatable :: ungrd(:) integer, allocatable :: localMinIndex(:), localMaxIndex(:) - real, pointer :: ptr4d(:,:,:,:) => null() - real, pointer :: ptr3d(:,:,:) => null() - real, pointer :: ptr2d(:,:) => null() type(ESMF_Field) :: f, fld - type(ESMF_Grid) :: grid - type(ESMF_Array) :: array, arraySlice - type(ESMF_TypeKind_Flag) :: tk - integer, pointer :: ungl(:), ungu(:) character(len=ESMF_MAXSTR) :: name character(len=ESMF_MAXSTR) :: splitName character(len=ESMF_MAXSTR), allocatable :: splitNameArray(:) character(len=ESMF_MAXSTR) :: longName - type(ESMF_Index_Flag) :: arrayIndexFlag, gridIndexFlag - - call ESMF_FieldGet(field, name=name, grid=grid, typekind=tk, _RC) - - call ESMF_GridGet(GRID, dimCount=gridRank, _RC) - allocate(gridToFieldMap(gridRank), _STAT) - call ESMF_FieldGet(field, gridToFieldMap=gridToFieldMap, _RC) + call ESMF_FieldGet(field, name=name, _RC) call ESMF_FieldGet(FIELD, dimCount=fieldRank, _RC) - if (tk == ESMF_TYPEKIND_R4) then - if (fieldRank == 4) then - !ALT: get the pointer on the first PET - call ESMF_FieldGet(Field,0,ptr4D,_RC) - allocate(ungl(1), ungu(1), _STAT) - ungl(1)=lbound(ptr4d,3) - ungu(1)=ubound(ptr4d,3) - else if (fieldRank == 3) then - ungl => NULL() ! to emulate 'not present' argument - ungu => NULL() - call ESMF_FieldGet(Field,0,ptr3D,_RC) - else - _ASSERT(.false., 'unsupported rank') - end if - else - _ASSERT(.false., 'unsupported typekind') - end if - allocate(localMinIndex(fieldRank),localMaxIndex(fieldRank), _STAT) - call ESMF_FieldGet(Field, array=array,& + call ESMF_FieldGet(Field, & localMinIndex=localMinIndex, localMaxIndex=localMaxIndex, _RC) k1 = localMinIndex(fieldRank) @@ -3659,21 +3244,14 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) allocate(fields(n), _STAT) call genAlias(name, n, splitNameArray, aliasName=aliasName,_RC) - _VERIFY(STATUS) n = 0 do k=k1,k2 n = n+1 splitName = splitNameArray(n) - arraySlice = ESMF_ArrayCreate(array, & - datacopyFlag=ESMF_DATACOPY_REFERENCE, & - trailingUndistSlice=[k], _RC) - ! create a new field - f = ESMF_FieldCreate(name=splitName, grid=grid, & - array=arraySlice, & - datacopyFlag = ESMF_DATACOPY_REFERENCE, & - gridToFieldMap=gridToFieldMap, & - ungriddedLBound=ungl, ungriddedUBound=ungu, _RC) + f = ESMF_FieldCreate(field, & + datacopyflag=ESMF_DATACOPY_REFERENCE, & + trailingUngridSlice=[k], name=splitName, _RC) ! copy attributes and adjust as necessary fld = field ! shallow copy to get around intent(in/out) @@ -3682,19 +3260,14 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) ! adjust ungridded dims attribute (if any) call ESMF_AttributeGet(FIELD, NAME='UNGRIDDED_DIMS', isPresent=has_ungrd, _RC) if (has_ungrd) then - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, RC=STATUS) - _VERIFY(STATUS) - allocate(ungrd(UNGRD_CNT), stat=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', itemcount=UNGRD_CNT, _RC) + allocate(ungrd(UNGRD_CNT), _STAT) + call ESMF_AttributeGet(F, NAME='UNGRIDDED_DIMS', valueList=UNGRD, _RC) + call ESMF_AttributeRemove(F, NAME='UNGRIDDED_DIMS', _RC) if (ungrd_cnt > 1) then ungrd_cnt = ungrd_cnt - 1 call ESMF_AttributeSet(F, NAME='UNGRIDDED_DIMS', & - valueList=UNGRD(1:ungrd_cnt), RC=STATUS) - _VERIFY(STATUS) + valueList=UNGRD(1:ungrd_cnt), _RC) else has_ungrd = .false. end if @@ -3703,10 +3276,7 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) fields(n) = f end do - if (associated(ungl)) deallocate(ungl) - if (associated(ungu)) deallocate(ungu) - deallocate(gridToFieldMap) deallocate(splitNameArray) ! fields SHOULD be deallocated by the caller!!! @@ -3768,8 +3338,7 @@ subroutine genAlias(name, n, splitNameArray, aliasName, rc) aliasName_ = name end if - allocate(splitNameArray(n), stat=status) - _VERIFY(status) + allocate(splitNameArray(n), _STAT) ! parse the aliasName ! count the separators (";") in aliasName @@ -3819,8 +3388,7 @@ module function MAPL_GetCorrectedPhase(gc,rc) result(phase) integer :: status - call ESMF_GridCompGet(gc,currentPhase=phase,rc=status) - _VERIFY(status) + call ESMF_GridCompGet(gc,currentPhase=phase,_RC) if (phase>10) phase=phase-10 _RETURN(_SUCCESS) end function MAPL_GetCorrectedPhase From be5e050681c556c0a3c7c8ce90c45484ba407037 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 5 Dec 2023 11:14:26 -0500 Subject: [PATCH 14/86] Update gridcomps/Cap/MAPL_Cap.F90 --- gridcomps/Cap/MAPL_Cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index b75e13d952f4..3b23c8a5c92d 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -447,7 +447,7 @@ subroutine initialize_mpi(this, unusable, rc) if (.not. this%mpi_already_initialized) then call MPI_Init_thread(MPI_THREAD_MULTIPLE, provided, ierror) - _ASSERT(provided == MPI_THREAD_MULTIPLE, 'MPI_THREAD_MULTIPLE not supporte by this MPI.') + _ASSERT(provided == MPI_THREAD_MULTIPLE, 'MPI_THREAD_MULTIPLE not supported by this MPI.') ! call MPI_Init_thread(MPI_THREAD_SINGLE, provided, ierror) ! _VERIFY(ierror) ! _ASSERT(provided == MPI_THREAD_SINGLE, "MPI_THREAD_SINGLE not supported by this MPI.") From 607b66b33928d77d54631ba808323d6d7769d423 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 21 Dec 2023 10:12:16 -0500 Subject: [PATCH 15/86] Add generic memory utility for memory profiling --- CHANGELOG.md | 1 + base/MAPL_MemUtils.F90 | 29 +++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index c8e980c155d3..e66e743329ae 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -21,6 +21,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added memory utility, MAPL_MemReport that can be used in any code linking MAPL - Station sampler: add support to Global Historical Climatology Network Daily (GHCN-D) - Add to trajectory sampler DEFINE_OBS_PLATFORM for reading multiple IODA files. To do this, we add union_platform function for observation. - New directory (`docs/tutorial/grid_comps/automatic_code_generator`) containing an example showing how to automatically generate the source code using the `MAPL_GridCompSpecs_ACG.py` tool. diff --git a/base/MAPL_MemUtils.F90 b/base/MAPL_MemUtils.F90 index fa779616fbc1..2c056a76f55b 100755 --- a/base/MAPL_MemUtils.F90 +++ b/base/MAPL_MemUtils.F90 @@ -59,6 +59,7 @@ module MAPL_MemUtilsMod public MAPL_MemUtilsFree public MAPL_MemCommited public MAPL_MemUsed + public MAPL_MemReport #ifdef _CRAY public :: hplen @@ -767,4 +768,32 @@ subroutine get_unit ( iunit ) return end subroutine get_unit +subroutine MAPL_MemReport(comm,file_name,line,decorator,rc) + integer, intent(in) :: comm + character(len=*), intent(in) :: file_name + integer, intent(in) :: line + character(len=*), intent(in), optional :: decorator + integer, intent(out), optional :: rc + + real :: mem_total,mem_used,percent_used + real :: committed_total,committed,percent_committed + integer :: rank,status + character(len=:), allocatable :: extra_message + +#ifdef sysDarwin + RETURN_(ESMF_SUCCESS) +#endif + call MPI_Barrier(comm,status) + if (present(decorator)) then + extra_message = decorator + else + extra_message = "" + end if + call MAPL_MemUsed(mem_total,mem_used,percent_used) + call MAPL_MemCommited(committed_total,committed,percent_committed) + call MPI_Comm_Rank(comm,rank,status) + if (rank == 0) write(*,'("Mem report ",A20," ",A30," ",i7," ",f5.1,"% : ",f5.1,"% Mem Comm:Used")')trim(extra_message),file_name,line,percent_committed,percent_used + +end subroutine + end module MAPL_MemUtilsMod From b755375f2dd70c0fffe3a5136b7f2c1773a0a0d4 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 21 Dec 2023 15:16:52 -0500 Subject: [PATCH 16/86] Test out fixed CircleCI Orb --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index c1d9deaf44b9..0c74eb56771b 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -21,7 +21,7 @@ bcs_version: &bcs_version v11.3.0 tag_build_arg_name: &tag_build_arg_name maplversion orbs: - ci: geos-esm/circleci-tools@2 + ci: geos-esm/circleci-tools@dev:404d775f9d010cc7e9b8a5ad74760363e5713297 workflows: build-and-test: From 2c592d61c19bba16c4f51f54a3694b67368a926e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 21 Dec 2023 15:56:18 -0500 Subject: [PATCH 17/86] Back to circleci-tools@2 --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 0c74eb56771b..c1d9deaf44b9 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -21,7 +21,7 @@ bcs_version: &bcs_version v11.3.0 tag_build_arg_name: &tag_build_arg_name maplversion orbs: - ci: geos-esm/circleci-tools@dev:404d775f9d010cc7e9b8a5ad74760363e5713297 + ci: geos-esm/circleci-tools@2 workflows: build-and-test: From 3a8deba67db1bc9094a28f855a848f1bd5f988a0 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 21 Dec 2023 20:01:11 -0500 Subject: [PATCH 18/86] Update CHANGELOG.md --- CHANGELOG.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b45bfbeefc13..e1c0e8df91df 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added memory utility, MAPL_MemReport that can be used in any code linking MAPL + ### Changed - Updated ESMF required version to 8.6.0 @@ -26,7 +28,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Added memory utility, MAPL_MemReport that can be used in any code linking MAPL - Station sampler: add support to Global Historical Climatology Network Daily (GHCN-D) - Add to trajectory sampler DEFINE_OBS_PLATFORM for reading multiple IODA files. To do this, we add union_platform function for observation. - New directory (`docs/tutorial/grid_comps/automatic_code_generator`) containing an example showing how to automatically generate the source code using the `MAPL_GridCompSpecs_ACG.py` tool. From 5f9e50887cd1ec8a7c667e16b9541b2080178a06 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 3 Jan 2024 15:16:33 -0500 Subject: [PATCH 19/86] Enable Ninja in CI --- .circleci/config.yml | 4 ++-- CHANGELOG.md | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index c1d9deaf44b9..3dfb8350c16a 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -35,7 +35,7 @@ workflows: matrix: parameters: compiler: [ifort] - cmake_generator: ['Unix Makefiles'] + cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL mepodevelop: false @@ -61,7 +61,7 @@ workflows: matrix: parameters: compiler: [gfortran] - cmake_generator: ['Unix Makefiles'] + cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL mepodevelop: false diff --git a/CHANGELOG.md b/CHANGELOG.md index e1c0e8df91df..d32bfa65b10c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Allocate gridded fields to use the pinflag option needed for the Single System Image (SSI) capability. - Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. +- Enable Ninja CI builds ### Fixed From f671106bb6de74573061da2ebfae942fd0347ffe Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 3 Jan 2024 12:18:00 -0800 Subject: [PATCH 20/86] Restore missing interfaces --- CHANGELOG.md | 2 ++ base/Base/Base_Base.F90 | 11 +++++++++++ base/Base/Base_Base_implementation.F90 | 10 +++++----- 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e1c0e8df91df..aae60a9621d9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Restore missing submodule interfaces + ### Removed ### Deprecated diff --git a/base/Base/Base_Base.F90 b/base/Base/Base_Base.F90 index b7d2eb5e19ac..088f1f0d36ac 100644 --- a/base/Base/Base_Base.F90 +++ b/base/Base/Base_Base.F90 @@ -43,6 +43,7 @@ module MAPL_Base public MAPL_LatLonGridCreate ! Creates regular Lat/Lon ESMF Grids public MAPL_Nhmsf public MAPL_NSECF + public MAPL_Nsecf2 public MAPL_PackTime public MAPL_PackDateTime public MAPL_RemapBounds @@ -291,6 +292,10 @@ integer module function MAPL_nsecf(nhms) integer, intent(in) :: nhms end function MAPL_nsecf + integer module function MAPL_nsecf2 (nhhmmss,nmmdd,nymd) + integer :: nhhmmss, nmmdd, nymd + end function MAPL_nsecf2 + module subroutine MAPL_tick (nymd,nhms,ndt) integer nymd,nhms,ndt end subroutine MAPL_tick @@ -636,6 +641,12 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) end subroutine MAPL_FieldAttSetI4 ! ======================================== + module subroutine MAPL_FieldDestroy(Field,RC) + type(ESMF_Field), intent(INOUT) :: Field + integer, optional, intent(OUT ) :: RC + end subroutine MAPL_FieldDestroy + ! ======================================== + module subroutine MAPL_FieldBundleDestroy(Bundle,RC) use ESMF, only: ESMF_FieldBundle type(ESMF_FieldBundle), intent(INOUT) :: Bundle diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 839c8674eda1..2aef8eb3ecc8 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -303,7 +303,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & call ESMF_FieldGet(FIELD, farrayPtr=VAR_4D, _RC) VAR_4D = INIT_VALUE case default - _ASSERT(.false., 'only up to 4D are supported') + _FAIL('only up to 4D are supported') end select RankCase2d else select case (rank) @@ -334,11 +334,11 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & call ESMF_FieldGet(FIELD, farrayPtr=VR8_4D, _RC) VR8_4D = INIT_VALUE case default - _ASSERT(.false., 'only up to 4D are supported') + _FAIL('only up to 4D are supported') end select end if - ! Horz + Vert + ! Horz + Vert ! ----------- case(MAPL_DimsHorzVert) lb1 = 1-HW @@ -2776,7 +2776,7 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, endif if ( .not. present(grid)) then - _ASSERT(.false., "need a cubed-sphere grid") + _FAIL("need a cubed-sphere grid") endif call MAPL_GridGet(grid, globalCellCountPerDim=dims,_RC) IM_World = dims(1) @@ -3237,7 +3237,7 @@ module subroutine MAPL_FieldSplit(field, fields, aliasName, rc) k1 = localMinIndex(fieldRank) k2 = localMaxIndex(fieldRank) - deallocate(localMinIndex,localMaxIndex) + deallocate(localMinIndex,localMaxIndex) n = k2 - k1 + 1 From 400596aa6a5c8ecd7f66dbeec06e2891043d99fa Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 4 Jan 2024 08:52:43 -0500 Subject: [PATCH 21/86] Remove unneeded interface in basebaseimpl --- base/Base/Base_Base.F90 | 6 ------ 1 file changed, 6 deletions(-) diff --git a/base/Base/Base_Base.F90 b/base/Base/Base_Base.F90 index 088f1f0d36ac..dcef19267c47 100644 --- a/base/Base/Base_Base.F90 +++ b/base/Base/Base_Base.F90 @@ -641,12 +641,6 @@ module subroutine MAPL_FieldAttSetI4(FIELD, NAME, VALUE, RC) end subroutine MAPL_FieldAttSetI4 ! ======================================== - module subroutine MAPL_FieldDestroy(Field,RC) - type(ESMF_Field), intent(INOUT) :: Field - integer, optional, intent(OUT ) :: RC - end subroutine MAPL_FieldDestroy - ! ======================================== - module subroutine MAPL_FieldBundleDestroy(Bundle,RC) use ESMF, only: ESMF_FieldBundle type(ESMF_FieldBundle), intent(INOUT) :: Bundle From 8610c1bddfdef9bba8bb535dfa17b99bfba888c1 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 4 Jan 2024 12:34:01 -0500 Subject: [PATCH 22/86] Update CI to use Open MPI 5.0.0 for GNU --- .circleci/config.yml | 2 +- .github/workflows/workflow.yml | 2 +- CHANGELOG.md | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index c1d9deaf44b9..95090a41566b 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -250,7 +250,7 @@ workflows: baselibs_version: *baselibs_version container_name: mapl mpi_name: openmpi - mpi_version: 4.1.4 + mpi_version: 5.0.0 compiler_name: gcc compiler_version: 12.1.0 image_name: geos-env-mkl diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 8d77a47ab3b9..e9b958ef566d 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.17.0-openmpi_4.1.4-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.17.0-openmpi_5.0.0-gcc_12.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/CHANGELOG.md b/CHANGELOG.md index e1c0e8df91df..eb1c30810473 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Allocate gridded fields to use the pinflag option needed for the Single System Image (SSI) capability. - Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. +- Updated CI to use Open MPI 5.0.0 for GNU ### Fixed From 42274301293e8912428250243d67ff9de81b4785 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 4 Jan 2024 12:51:12 -0500 Subject: [PATCH 23/86] Fix up changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d32bfa65b10c..1588e667b770 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,7 +17,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Allocate gridded fields to use the pinflag option needed for the Single System Image (SSI) capability. - Made changes to allocate fields to use farray instead of farrayPtr. This allows explicit specification of indexflag required by the new MAPL field split functionality. This functionality allows a clean way to create a new field from an exiting field where the new field is a 'slice' of the existing field with the slicing index being that of the trailing ungiridded dim of the existing field. - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. -- Enable Ninja CI builds +- Enable Ninja for CI builds of MAPL ### Fixed From 8a81c135db058f88b2d9df9426fb3a0033bd7b0e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 5 Jan 2024 15:17:00 -0500 Subject: [PATCH 24/86] Fix wrong type of RETURN --- base/MAPL_MemUtils.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_MemUtils.F90 b/base/MAPL_MemUtils.F90 index 2c056a76f55b..26a0c331fdee 100755 --- a/base/MAPL_MemUtils.F90 +++ b/base/MAPL_MemUtils.F90 @@ -781,7 +781,7 @@ subroutine MAPL_MemReport(comm,file_name,line,decorator,rc) character(len=:), allocatable :: extra_message #ifdef sysDarwin - RETURN_(ESMF_SUCCESS) + _RETURN(ESMF_SUCCESS) #endif call MPI_Barrier(comm,status) if (present(decorator)) then From 2f8d217b9a967f0da28e29072ffd2ad110f0ea25 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 9 Jan 2024 13:01:27 -0500 Subject: [PATCH 25/86] Remove ESMF_HAS_ACHAR_BUG CMake and cpp macro --- CHANGELOG.md | 2 ++ base/CMakeLists.txt | 5 ----- base/MAPL_Config.F90 | 28 ++++++++++++---------------- 3 files changed, 14 insertions(+), 21 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c50ea8f9ef5f..eb8d4044a80e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. - Updated CI to use Open MPI 5.0.0 for GNU - Enable Ninja for CI builds of MAPL +- Removed use of `ESMF_HAS_ACHAR_BUG` CMake option and code use in `MAPL_Config.F90`. Testing has shown that with ESMF 8.6 (which is + now required), NAG no longer needs this workaround. ### Fixed diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 268d7291f6f4..17db0ff4209a 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -77,11 +77,6 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -# Workaround for bizarre switch in ESMF -if (ESMF_HAS_ACHAR_BUG) - set_source_files_properties(MAPL_Config.F90 PROPERTIES COMPILE_DEFINITIONS ESMF_HAS_ACHAR_BUG) -endif() - if(DISABLE_GLOBAL_NAME_WARNING) target_compile_options (${this} PRIVATE $<$:${DISABLE_GLOBAL_NAME_WARNING}>) endif() diff --git a/base/MAPL_Config.F90 b/base/MAPL_Config.F90 index f31daf1cc93d..7c814348cf8f 100644 --- a/base/MAPL_Config.F90 +++ b/base/MAPL_Config.F90 @@ -48,13 +48,9 @@ module MAPL_ConfigMod character, parameter :: BLK = achar(32) ! blank (space) character, parameter :: TAB = achar(09) ! TAB -#if defined(ESMF_HAS_ACHAR_BUG) - character, parameter :: EOL = achar(12) ! end of line mark (cr) -#else - character, parameter :: EOL = achar(10) ! end of line mark (newline) -#endif - character, parameter :: EOB = achar(00) ! end of buffer mark (null) - character, parameter :: NUL = achar(00) ! what it says + character, parameter :: EOL = achar(10) ! end of line mark (newline) + character, parameter :: EOB = achar(00) ! end of buffer mark (null) + character, parameter :: NUL = achar(00) ! what it says contains @@ -97,7 +93,7 @@ end function MAPL_ConfigCreate ! subroutine MAPL_ConfigSetAttribute_real64( config, value, label, rc ) use, intrinsic :: iso_fortran_env, only: REAL64 -! +! type(ESMF_Config), intent(inout) :: config real(kind=REAL64), intent(in) :: value character(len=*), intent(in), optional :: label @@ -243,7 +239,7 @@ end subroutine MAPL_ConfigSetAttribute_real64 ! subroutine MAPL_ConfigSetAttribute_real32( config, value, label, rc ) use, intrinsic :: iso_fortran_env, only: REAL32 -! +! type(ESMF_Config), intent(inout) :: config real(kind=REAL32), intent(in) :: value character(len=*), intent(in), optional :: label @@ -376,17 +372,17 @@ subroutine MAPL_ConfigSetAttribute_real32( config, value, label, rc ) end subroutine MAPL_ConfigSetAttribute_real32 !------------------------------------------------------------------------------ -!> +!> ! Set a 4-byte integer _value_ in the _config_ object. -! +! ! The arguments are: !- **config**: Already created `ESMF_Config` object. !- **value**: Integer value to set. !- **label**: Identifying attribute label. !- **rc**: Return code; equals `ESMF_SUCCESS` if there are no errors. -! +! ! **Private name**: call using ESMF_ConfigSetAttribute()`. -! +! subroutine MAPL_ConfigSetAttribute_int32( config, value, label, rc ) use, intrinsic :: iso_fortran_env, only: INT32 ! @@ -600,15 +596,15 @@ subroutine MAPL_ConfigSetAttribute_reals32( config, value, label, rc ) end subroutine MAPL_ConfigSetAttribute_reals32 !------------------------------------------------------------------------------ -!> +!> ! Set a string _value_ in the _config_ object. -! +! ! The arguments are: !- **config**: Already created `ESMF_Config` object. !- **value**: String value to set. !- **label**: Identifying attribute label. !- **rc**: Return code; equals `ESMF_SUCCESS` if there are no errors. -! +! subroutine MAPL_ConfigSetAttribute_string(config, value, label, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: value From 7d0688c26d8da23d3e7db6b2d720b2bdab07d036 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 9 Jan 2024 13:49:31 -0500 Subject: [PATCH 26/86] Update to ESMA_cmake v3.37.0 --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index e0bbd84af99c..fd6df1677150 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.36.0 + tag: v3.37.0 develop: develop ecbuild: From 9251b86c0c7854e85ddb964a9f6edf89e983d477 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 11 Jan 2024 14:18:03 -0700 Subject: [PATCH 27/86] Revised swath and trajecotry sampler to handle multiple missing files along with model runs --- CHANGELOG.md | 7 + Tests/ExtDataDriverGridComp.F90 | 16 +- base/MAPL_ObsUtil.F90 | 240 ++++++--- base/MAPL_SwathGridFactory.F90 | 436 ++++++++++------ base/Plain_netCDF_Time.F90 | 32 +- gridcomps/History/MAPL_EpochSwathMod.F90 | 266 +++++----- gridcomps/History/MAPL_HistoryGridComp.F90 | 199 ++++--- .../History/MAPL_HistoryTrajectoryMod.F90 | 17 +- .../MAPL_HistoryTrajectoryMod_smod.F90 | 494 +++++++++++------- 9 files changed, 1092 insertions(+), 615 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c50ea8f9ef5f..7f512a9e0edf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,13 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Modify trajectory sampler for a collection with multiple platforms: P3B (air craft) + FIREX +- Modify swath sampler to handle two Epoch swath grids +- Handle regrid accumulate for time step (1 sec) during which no obs exists +- Use IntState%stampoffset(n) to adjust filenames for an epoch time +- parse "GOCART::CO2" from 'geovals_fields' entry in PLATFORM +- Add Shmem to ExtDataDriverGridComp.F90 +- Read swath data on root, pass to NodeRoot for Shmem, so to avoid race in reading nc files - Added memory utility, MAPL_MemReport that can be used in any code linking MAPL diff --git a/Tests/ExtDataDriverGridComp.F90 b/Tests/ExtDataDriverGridComp.F90 index 0873a68c4c11..c303f61be6e1 100644 --- a/Tests/ExtDataDriverGridComp.F90 +++ b/Tests/ExtDataDriverGridComp.F90 @@ -11,7 +11,7 @@ module ExtData_DriverGridCompMod use MAPL_HistoryGridCompMod, only : Hist_SetServices => SetServices use MAPL_Profiler, only : get_global_time_profiler, BaseProfiler use mpi - +! use MAPL_ShmemMod implicit none private @@ -145,6 +145,9 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) class(BaseProfiler), pointer :: t_p logical :: use_extdata2g + integer :: useShmem + + _UNUSED_DUMMY(import_state) _UNUSED_DUMMY(export_state) _UNUSED_DUMMY(clock) @@ -168,6 +171,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) cap%AmIRoot = AmIRoot_ + ! Open the CAP's configuration from CAP.rc !------------------------------------------ @@ -176,6 +180,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigLoadFile(cap%config, cap%configFile, rc = status) _VERIFY(status) + ! CAP's MAPL MetaComp !--------------------- @@ -185,6 +190,13 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call MAPL_Set(MAPLOBJ, name = cap%name, cf = cap%config, rc = status) _VERIFY(status) + call MAPL_GetResource(MAPLOBJ, useShmem, label = 'USE_SHMEM:', default = 0, rc = status) + if (useShmem /= 0) then + call MAPL_InitializeShmem (rc = status) + _VERIFY(status) + end if + + call ESMF_ConfigGetAttribute(cap%config,cap%run_fbf,label="RUN_FBF:",default=.false.) call ESMF_ConfigGetAttribute(cap%config,cap%run_hist,label="RUN_HISTORY:",default=.true.) call ESMF_ConfigGetAttribute(cap%config,cap%run_extdata,label="RUN_EXTDATA:",default=.true.) @@ -484,6 +496,8 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigDestroy(cap%config, rc = status) _VERIFY(status) + call MAPL_FinalizeSHMEM (rc = status) + _VERIFY(status) _RETURN(ESMF_SUCCESS) end subroutine finalize_gc diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index d4ed2f8de5ab..8901c159f6c7 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -33,10 +33,10 @@ module MAPL_ObsUtilMod type obs_platform character (len=ESMF_MAXSTR) :: name='' - character (len=ESMF_MAXSTR) :: nc_index='' - character (len=ESMF_MAXSTR) :: nc_lon='' - character (len=ESMF_MAXSTR) :: nc_lat='' - character (len=ESMF_MAXSTR) :: nc_time='' + character (len=ESMF_MAXSTR) :: index_name_x='' + character (len=ESMF_MAXSTR) :: var_name_lon='' + character (len=ESMF_MAXSTR) :: var_name_lat='' + character (len=ESMF_MAXSTR) :: var_name_time='' character (len=ESMF_MAXSTR) :: file_name_template='' integer :: ngeoval=0 integer :: nentry_name=0 @@ -62,7 +62,7 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & integer, intent(out) :: obsfile_Te_index integer, optional, intent(out) :: rc - type(ESMF_Time) :: T1, Tn + type(ESMF_Time) :: T1 type(ESMF_Time) :: cT1 type(ESMF_Time) :: Ts, Te type(ESMF_TimeInterval) :: dT1, dT2, dTs, dTe @@ -71,8 +71,14 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & integer :: n1, n2 integer :: status + ! + ! o---------o ------------- o -------------o + ! obsfile_interval + ! x---------------------x-- + ! Epoch + ! + T1 = obsfile_start_time - Tn = obsfile_end_time cT1 = currTime dT1 = currTime - T1 @@ -91,11 +97,13 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & Te = T1 + dTe obsfile_Ts_index = n1 - if ( dT2_s - n2*dT0_s < 1 ) then - obsfile_Te_index = n2 - 1 - else - obsfile_Te_index = n2 - end if + obsfile_Te_index = n2 + +! if ( dT2_s - n2*dT0_s < 1 ) then +! obsfile_Te_index = n2 - 1 +! else +! obsfile_Te_index = n2 +! end if _RETURN(ESMF_SUCCESS) @@ -177,7 +185,7 @@ end subroutine reset_times_to_current_day ! --//-------------------------------------//-> ! files ! o o o o o o o o o o T: filename - ! <--- off set + ! <--- off set ! o o o o o o o o o o T: file content start ! | | ! curr curr+Epoch @@ -210,6 +218,7 @@ subroutine Find_M_files_for_currTime (currTime, & integer :: n1, n2 integer :: i, j integer :: status + logical :: EX !__ s1. Arithmetic index list based on s,e,interval ! @@ -254,13 +263,13 @@ subroutine Find_M_files_for_currTime (currTime, & ! print*, '2nd n1, n2', n1, n2 !__ s2. further test file existence - ! + ! j=0 do i= n1, n2 test_file = get_filename_from_template_use_index & (obsfile_start_time, obsfile_interval, & - i, file_template, rc=rc) - if (test_file /= '') then + i, file_template, EX, rc=rc) + if (EX) then j=j+1 filenames(j) = test_file end if @@ -269,7 +278,6 @@ subroutine Find_M_files_for_currTime (currTime, & _ASSERT ( M < size(filenames) , 'code crash, number of files exceeds upper bound') _ASSERT (M/=0, 'M is zero, no files found for currTime') - _RETURN(_SUCCESS) @@ -278,8 +286,8 @@ end subroutine Find_M_files_for_currTime subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & index_name_lon, index_name_lat,& - var_name_lon, var_name_lat, var_name_time, & - lon, lat, time, rc ) + var_name_lon, var_name_lat, var_name_time, & + lon, lat, time, Tfilter, rc ) use pFlogger, only: logging, Logger character(len=ESMF_MAXSTR), intent(in) :: filenames(:) integer, intent(out) :: Xdim @@ -288,17 +296,18 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & character(len=ESMF_MAXSTR), intent(in) :: index_name_lat character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_lon character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_lat - character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_time + character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_time - real, optional, intent(inout) :: lon(:,:) - real, optional, intent(inout) :: lat(:,:) + real, allocatable, optional, intent(inout) :: lon(:,:) + real, allocatable, optional, intent(inout) :: lat(:,:) !! real(ESMF_KIND_R8), optional, intent(inout) :: time_R8(:,:) - real, optional, intent(inout) :: time(:,:) + real, allocatable, optional, intent(inout) :: time(:,:) + logical, optional, intent(in) :: Tfilter integer, optional, intent(out) :: rc integer :: M - integer :: i, j, jx, status + integer :: i, j, jx, j2, status integer :: nlon, nlat integer :: ncid, ncid2 character(len=ESMF_MAXSTR) :: grp1, grp2 @@ -316,7 +325,7 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & M = size(filenames) _ASSERT(M/=0, 'M is zero, no files found') lgr => logging%get_logger('MAPL.Sampler') - + allocate(nlons(M), nlats(M)) jx=0 do i = 1, M @@ -326,45 +335,139 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & nlons(i)=nlon nlats(i)=nlat jx=jx+nlat - + call lgr%debug('Input filename: %a', trim(filename)) call lgr%debug('Input file : nlon, nlat= %i6 %i6', nlon, nlat) end do + ! + ! __ output results wo filter + ! Xdim=nlon Ydim=jx - + j2=jx !__ s2. get fields - jx=0 - do i = 1, M - filename = filenames(i) - nlon = nlons(i) - nlat = nlats(i) - if (present(var_name_time).AND.present(time)) then + if ( present(Tfilter) .AND. Tfilter ) then + if ( .not. (present(time) .AND. present(lon) .AND. present(lat)) ) then + _FAIL('when Tfilter present, time/lon/lat must also present') + end if + + ! + ! -- determine jx + ! + jx=0 + do i = 1, M + filename = filenames(i) + nlon = nlons(i) + nlat = nlats(i) allocate (time_loc_R8(nlon, nlat)) call get_var_from_name_w_group (var_name_time, time_loc_R8, filename, _RC) - time(1:nlon,jx+1:jx+nlat) = time_loc_R8(1:nlon,1:nlat) +!! write(6,*) 'af ith, filename', i, trim(filename) + + do j=1, nlat + ! + ! -- filter, e.g., eliminate -9999 + ! + if ( time_loc_R8(1, j) > 0.0 ) then + jx = jx + 1 + end if + end do deallocate(time_loc_R8) + end do + Xdim=nlon + Ydim=jx + if (allocated (time)) then + deallocate(time) + allocate (time(Xdim, Ydim)) end if - - if (present(var_name_lon).AND.present(lon)) then + if (allocated (lon)) then + deallocate(lon) + allocate (lon(Xdim, Ydim)) + end if + if (allocated (lat)) then + deallocate(lat) + allocate (lat(Xdim, Ydim)) + end if + ! + !!write(6,'(2x,a,10i10)') 'true Xdim, Ydim:', Xdim, Ydim + !!write(6,'(2x,a,10i10)') 'false Xdim, Ydim:', nlon, j2 + ! + + + + ! + ! -- determine true time/lon/lat by filtering T < 0 + ! + jx=0 + do i = 1, M + filename = filenames(i) + nlon = nlons(i) + nlat = nlats(i) + !!write(6,'(2x,a,10i6)') 'M, i, nlon, nlat:', M, i, nlon, nlat + !!write(6,'(2x,a)') 'time_loc_r8' + ! + allocate (time_loc_R8(nlon, nlat)) + call get_var_from_name_w_group (var_name_time, time_loc_R8, filename, _RC) allocate (lon_loc(nlon, nlat)) call get_var_from_name_w_group (var_name_lon, lon_loc, filename, _RC) - lon(1:nlon,jx+1:jx+nlat) = lon_loc(1:nlon,1:nlat) - deallocate(lon_loc) - end if - - if (present(var_name_lat).AND.present(lat)) then allocate (lat_loc(nlon, nlat)) call get_var_from_name_w_group (var_name_lat, lat_loc, filename, _RC) - lat(1:nlon,jx+1:jx+nlat) = lat_loc(1:nlon,1:nlat) + ! + do j=1, nlat + ! + ! -- filter, e.g., eliminate -9999 + ! + if ( time_loc_R8(1, j) > 0.0 ) then + jx = jx + 1 + time(1:nlon,jx) = time_loc_R8(1:nlon,j) + lon (1:nlon,jx) = lon_loc (1:nlon,j) + lat (1:nlon,jx) = lat_loc (1:nlon,j) + end if + !!write(6,'(5f20.2)') time_loc_R8(1,j) + end do + + !!write(6,'(2x,a,10i10)') 'end of file id', i + !!write(6,*) + + deallocate(time_loc_R8) + deallocate(lon_loc) deallocate(lat_loc) - end if + end do - jx = jx + nlat + else - end do + jx=0 + do i = 1, M + filename = filenames(i) + nlon = nlons(i) + nlat = nlats(i) + + if (present(var_name_time).AND.present(time)) then + allocate (time_loc_R8(nlon, nlat)) + call get_var_from_name_w_group (var_name_time, time_loc_R8, filename, _RC) + time(1:nlon,jx+1:jx+nlat) = time_loc_R8(1:nlon,1:nlat) + deallocate(time_loc_R8) + end if + + if (present(var_name_lon).AND.present(lon)) then + allocate (lon_loc(nlon, nlat)) + call get_var_from_name_w_group (var_name_lon, lon_loc, filename, _RC) + lon(1:nlon,jx+1:jx+nlat) = lon_loc(1:nlon,1:nlat) + deallocate(lon_loc) + end if + + if (present(var_name_lat).AND.present(lat)) then + allocate (lat_loc(nlon, nlat)) + call get_var_from_name_w_group (var_name_lat, lat_loc, filename, _RC) + lat(1:nlon,jx+1:jx+nlat) = lat_loc(1:nlon,1:nlat) + deallocate(lat_loc) + end if + + jx = jx + nlat + end do + + end if _RETURN(_SUCCESS) end subroutine read_M_files_4_swath @@ -375,14 +478,15 @@ end subroutine read_M_files_4_swath ! because of (bash ls) command therein ! function get_filename_from_template_use_index (obsfile_start_time, obsfile_interval, & - f_index, file_template, rc) result(filename) + f_index, file_template, EX, rc) result(filename) use Plain_netCDF_Time, only : ESMF_time_to_two_integer - use MAPL_StringTemplate, only : fill_grads_template + use MAPL_StringTemplate, only : fill_grads_template character(len=ESMF_MAXSTR) :: filename type(ESMF_Time), intent(in) :: obsfile_start_time type(ESMF_TimeInterval), intent(in) :: obsfile_interval character(len=*), intent(in) :: file_template integer, intent(in) :: f_index + logical, intent(out) :: EX integer, optional, intent(out) :: rc integer :: itime(2) @@ -393,7 +497,6 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter type(ESMF_TimeInterval) :: dT type(ESMF_Time) :: time integer :: i, j, u - logical :: EX character(len=ESMF_MAXSTR) :: file_template_left character(len=ESMF_MAXSTR) :: file_template_right @@ -416,7 +519,6 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter call fill_grads_template ( filename, file_template, & experiment_id='', nymd=nymd, nhms=nhms, _RC ) inquire(file= trim(filename), EXIST = EX) - if(.not.EX) filename='' _RETURN(_SUCCESS) @@ -431,8 +533,8 @@ subroutine get_var_from_name_w_group (var_name, var2d, filename, rc) integer :: i, j character(len=ESMF_MAXSTR) :: grp1, grp2 - character(len=ESMF_MAXSTR) :: short_name - integer :: ncid, ncid2, varid + character(len=ESMF_MAXSTR) :: short_name + integer :: ncid, ncid1, ncid2, ncid_final, varid logical :: found_group integer :: status @@ -447,7 +549,7 @@ subroutine get_var_from_name_w_group (var_name, var2d, filename, rc) short_name=var_name(i+j+1:) else grp2='' - short_name=var_name(i+1:) + short_name=var_name(i+1:) endif i=i+j else @@ -457,20 +559,29 @@ subroutine get_var_from_name_w_group (var_name, var2d, filename, rc) short_name=var_name endif - call check_nc_status(nf90_open(filename, NF90_NOWRITE, ncid2), _RC) + + ! ncid + ! ncid1: grp1 + ! ncid2: grp2 + ! + call check_nc_status(nf90_open(filename, NF90_NOWRITE, ncid), _RC) + ncid_final = ncid if ( found_group ) then - call check_nc_status(nf90_inq_ncid(ncid2, grp1, ncid), _RC) + call check_nc_status(nf90_inq_ncid(ncid, grp1, ncid1), _RC) + ncid_final = ncid1 if (j>0) then - call check_nc_status(nf90_inq_ncid(ncid, grp2, ncid2), _RC) - ncid=ncid2 + call check_nc_status(nf90_inq_ncid(ncid1, grp2, ncid2), _RC) + ncid_final = ncid2 endif else - print*, 'no grp name' - ncid=ncid2 +!! print*, 'no grp name' endif - call check_nc_status(nf90_inq_varid(ncid, short_name, varid), _RC) - call check_nc_status(nf90_get_var(ncid, varid, var2d), _RC) -!! call check_nc_status(nf90_close(ncid), _RC) + + call check_nc_status(nf90_inq_varid(ncid_final, short_name, varid), _RC) +!! write(6,*) 'ncid, short_name, varid', ncid, trim(short_name), varid + call check_nc_status(nf90_get_var(ncid_final, varid, var2d), _RC) + + call check_nc_status(nf90_close(ncid), _RC) _RETURN(_SUCCESS) @@ -557,16 +668,15 @@ subroutine sort_four_arrays_by_time(U,V,T,ID,rc) end subroutine sort_four_arrays_by_time - function copy_platform_nckeys(a, rc) type(obs_platform) :: copy_platform_nckeys type(obs_platform), intent(in) :: a integer, optional, intent(out) :: rc - copy_platform_nckeys%nc_index = a%nc_index - copy_platform_nckeys%nc_lon = a%nc_lon - copy_platform_nckeys%nc_lat = a%nc_lat - copy_platform_nckeys%nc_time = a%nc_time + copy_platform_nckeys%index_name_x = a%index_name_x + copy_platform_nckeys%var_name_lon = a%var_name_lon + copy_platform_nckeys%var_name_lat = a%var_name_lat + copy_platform_nckeys%var_name_time = a%var_name_time copy_platform_nckeys%nentry_name = a%nentry_name _RETURN(_SUCCESS) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 591c9eb562cc..d92cd27fafb4 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -26,14 +26,14 @@ module MAPL_SwathGridFactoryMod private public :: SwathGridFactory - + type, extends(AbstractGridFactory) :: SwathGridFactory private character(len=:), allocatable :: grid_name - character(len=:), allocatable :: grid_file_name + character(len=:), allocatable :: grid_file_name character(len=ESMF_MAXSTR) :: filenames(mx_file) integer :: M_file - + integer :: cell_across_swath integer :: cell_along_swath integer :: im_world = MAPL_UNDEFINED_INTEGER @@ -47,7 +47,7 @@ module MAPL_SwathGridFactoryMod ! note: this var is not deallocated in swathfactory, use caution character(len=ESMF_MAXSTR) :: tunit character(len=ESMF_MAXSTR) :: index_name_lon - character(len=ESMF_MAXSTR) :: index_name_lat + character(len=ESMF_MAXSTR) :: index_name_lat character(len=ESMF_MAXSTR) :: var_name_lon character(len=ESMF_MAXSTR) :: var_name_lat character(len=ESMF_MAXSTR) :: var_name_time @@ -57,10 +57,10 @@ module MAPL_SwathGridFactoryMod type(ESMF_Time) :: obsfile_start_time ! user specify type(ESMF_Time) :: obsfile_end_time type(ESMF_TimeInterval) :: obsfile_interval - type(ESMF_TimeInterval) :: EPOCH_FREQUENCY + type(ESMF_TimeInterval) :: EPOCH_FREQUENCY integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index - logical :: is_valid + logical :: is_valid ! Domain decomposition: integer :: nx = MAPL_UNDEFINED_INTEGER @@ -130,7 +130,7 @@ function SwathGridFactory_from_parameters(unusable, grid_name, & integer, optional, intent(in) :: im_world integer, optional, intent(in) :: jm_world integer, optional, intent(in) :: lm - + ! decomposition: integer, optional, intent(in) :: nx integer, optional, intent(in) :: ny @@ -142,7 +142,7 @@ function SwathGridFactory_from_parameters(unusable, grid_name, & integer :: status _UNUSED_DUMMY(unusable) - + call set_with_default(factory%grid_name, grid_name, MAPL_GRID_NAME_DEFAULT) call set_with_default(factory%nx, nx, MAPL_UNDEFINED_INTEGER) call set_with_default(factory%ny, ny, MAPL_UNDEFINED_INTEGER) @@ -155,7 +155,7 @@ function SwathGridFactory_from_parameters(unusable, grid_name, & if (present(jms)) factory%jms = jms call factory%check_and_fill_consistency(_RC) - + _RETURN(_SUCCESS) end function SwathGridFactory_from_parameters @@ -168,8 +168,14 @@ function make_new_grid(this, unusable, rc) result(grid) integer :: status _UNUSED_DUMMY(unusable) + + if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: bf this%create_basic_grid' grid = this%create_basic_grid(_RC) + if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%create_basic_grid' + call this%add_horz_coordinates_from_file(grid,_RC) + if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%add_horz_coordinates_from_file' + _RETURN(_SUCCESS) end function make_new_grid @@ -202,7 +208,7 @@ function create_basic_grid(this, unusable, rc) result(grid) call ESMF_AttributeSet(grid, 'GridType', 'LatLon', _RC) call ESMF_AttributeSet(grid, 'Global', .false., _RC) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) end function create_basic_grid @@ -217,32 +223,52 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) real(kind=ESMF_KIND_R8), pointer :: fptr(:,:) real, pointer :: centers(:,:) - real, allocatable :: centers_full(:,:) - + real, allocatable :: lon_true(:,:) + real, allocatable :: lat_true(:,:) + real, allocatable :: time_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: X1d(:) + integer :: i, j, k integer :: Xdim, Ydim integer :: Xdim_full, Ydim_full integer :: nx, ny - + integer :: IM, JM integer :: IM_WORLD, JM_WORLD integer :: COUNTS(3), DIMS(3) integer :: i_1, i_n, j_1, j_n ! regional array bounds type(Logger), pointer :: lgr + ! debug + type(ESMF_VM) :: vm + integer :: mypet, petcount + + integer :: rank0 + integer :: src, dst + integer :: nsize, count + integer :: nshared_pet + real, allocatable :: arr(:,:), arr_lon(:,:), arr_lat(:,:) + + integer, allocatable:: array1(:), array2(:), array3(:) + _UNUSED_DUMMY(unusable) + call ESMF_VMGetGlobal(vm,_RC) + call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) Xdim=this%im_world Ydim=this%jm_world Xdim_full=this%cell_across_swath Ydim_full=this%cell_along_swath - - call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) + + call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) + call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) + call MAPL_AllocateShared(arr_lon,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[Xdim,Ydim],transroot=.true.,_RC) +!! mmapl_am_I_root() is element in set (rootscomm) ! if (mapl_am_I_root()) then ! write(6,'(2x,a,10i8)') & ! 'ck: Xdim, Ydim, Xdim_full, Ydim_full', Xdim, Ydim, Xdim_full, Ydim_full @@ -250,40 +276,124 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! 'ck: i_1, i_n, j_1, j_n', i_1, i_n, j_1, j_n ! end if + ! + ! array3(1:nshared_pet) is the pet for shared headnode excluding mapl_am_i_root() + ! s1. read NC from root/rank0 + ! s2. MPI send and recv true_lon / true_lat via X1d + ! s3. pass X1d to Shmem [centers] + ! + + nsize = petCount + allocate (array1(nsize)) + allocate (array2(nsize)) + + array1(:) = 0 + src = 0 + dst = 0 + + if (mapl_am_i_root()) then + rank0 = mypet + src = 1 + end if + + if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then + if (mypet/=rank0) then + array1(mypet+1) = mypet+1 ! raise index to [1, N] + dst = 1 + end if + end if - ! read longitudes - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - allocate( centers_full(Xdim_full, Ydim_full)) + call ESMF_VMAllReduce(vm, sendData=array1, recvData=array2, count=nsize, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + write(6, '(2x,a,2x,i5,2x,a,2x,10i10)') 'mypet, array2', mypet, ':', array2 + + j=0 + do i=1, nsize + if ( array2(i) > 0 ) then + j=j+1 + end if + end do + allocate (array3(j)) + nshared_pet = j + + j=0 + do i=1, nsize + if ( array2(i) > 0 ) then + j=j+1 + array3(j) = array2(i) - 1 ! downshift value to mypet + end if + end do + + if (src==1 .OR. dst==1) then + allocate( arr_lon(Xdim, Ydim) ) + allocate( arr_lat(Xdim, Ydim) ) + allocate( X1d( Xdim * Ydim ) ) + allocate( Y1d( Xdim * Ydim ) ) + end if + + if (mypet==rank0) then + allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & this%index_name_lon, this%index_name_lat, & - var_name_lon=this%var_name_lon, lon=centers_full, _RC) + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=time_true, & + Tfilter=.true., _RC) k=0 do j=this%epoch_index(3), this%epoch_index(4) k=k+1 - centers(1:Xdim, k) = centers_full(1:Xdim, j) + arr_lon(1:Xdim, k) = lon_true(1:Xdim, j) + arr_lat(1:Xdim, k) = lat_true(1:Xdim, j) enddo - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 - deallocate (centers_full) + arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 + arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 + k=0 + do j=1, Ydim + do i=1, Xdim + X1d(k) = arr_lon(i,j) + Y1d(k) = arr_lat(i,j) + end do + end do + deallocate( lon_true, time_true ) + ! + end if + + + + if (nshared_pet > 0) then + count = Xdim * Ydim + if (src==1) then + do j=1, nshared_pet + call ESMF_VMSend(vm, sendData=X1d, count=count, dstPet=array3(j), rc=rc) + call ESMF_VMSend(vm, sendData=Y1d, count=count, dstPet=array3(j), rc=rc) + end do + end if + if (dst==1) then + call ESMF_VMRecv(vm, recvData=arr_lon, count=count, srcPet=rank0, rc=rc) + call ESMF_VMRecv(vm, recvData=arr_lat, count=count, srcPet=rank0, rc=rc) + end if + end if + + + ! read longitudes + if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then + write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet + centers = arr_lon end if - call MAPL_SyncSharedMemory(_RC) + + +!! mpi_barrier for each core within node + call MAPL_SyncSharedMemory(_RC) + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) fptr=real(centers(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) - - ! read latitudes +!! _FAIL ('nail -1') + ! read latitudes if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - allocate( centers_full(Xdim_full, Ydim_full)) - call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, & - var_name_lat=this%var_name_lat, lat=centers_full, _RC) - k=0 - do j=this%epoch_index(3), this%epoch_index(4) - k=k+1 - centers(1:Xdim, k) = centers_full(1:Xdim, j) - enddo - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 - deallocate (centers_full) + centers = arr_lat end if call MAPL_SyncSharedMemory(_RC) call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & @@ -296,7 +406,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) else deallocate(centers) end if - + _RETURN(_SUCCESS) end subroutine add_horz_coordinates_from_file @@ -413,12 +523,13 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer :: nx, ny character(len=ESMF_MAXSTR) :: key_lon, key_lat, key_time character(len=ESMF_MAXSTR) :: tunit, grp1, grp2 - character(len=ESMF_MAXSTR) :: filename, STR1, tmp + character(len=ESMF_MAXSTR) :: filename, STR1, tmp character(len=ESMF_MAXSTR) :: symd, shms - ! real(ESMF_KIND_R8), allocatable :: scanTime(:,:) real, allocatable :: scanTime(:,:) + real, allocatable :: lon_true(:,:) + real, allocatable :: lat_true(:,:) integer :: yy, mm, dd, h, m, s, sec, second integer :: i, j, L integer :: ncid, ncid2, varid @@ -429,24 +540,23 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer (ESMF_KIND_I8) :: j0, j1, jt, jt1, jt2 real(ESMF_KIND_R8) :: jx0, jx1 real(ESMF_KIND_R8) :: x0, x1 - integer :: khi, klo, k, nstart, max_iter + integer :: khi, klo, k, nstart, nend, max_iter type(Logger), pointer :: lgr logical :: ispresent - type(ESMF_TimeInterval) :: Toff - + type(ESMF_TimeInterval) :: Toff, obs_time_span + _UNUSED_DUMMY(unusable) lgr => logging%get_logger('HISTORY.sampler') - + call ESMF_VmGetCurrent(VM, _RC) ! input : config ! output: this%epoch_index, nx, ny ! ! Read in specs, crop epoch_index based on scanTime - ! - + !__ s1. read in file spec. ! call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT) @@ -458,41 +568,63 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%epoch, label=prefix//'Epoch:', default=300, _RC) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'Epoch_init:', default='2006', _RC) + call lgr%debug(' %a %a', 'CurrTime =', trim(tmp)) + + if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then + call ESMF_TimeSet(currTime, timeString=tmp, _RC) + else + read(tmp,'(i4,5i2)') yy,mm,dd,h,m,s + call ESMF_Timeset(currTime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) + endif + second = hms_2_s(this%Epoch) + call ESMF_TimeIntervalSet(this%epoch_frequency, s=second, _RC) + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label= prefix// 'obs_file_begin:', _RC) - - if (trim(STR1)=='') then - _FAIL('obs_file_begin missing, code crash') - else - call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) + _ASSERT (trim(STR1)/='', 'obs_file_begin missing, critical for data with 5 min interval!') + call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) + !!disable using currTime as obsfile_start_time + !!if (trim(STR1)=='') then + !! this%obsfile_start_time = currTime + !! call ESMF_TimeGet(currTime, timestring=STR1, _RC) + !! if (mapl_am_I_root()) then + !! write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) + !! endif + !!else + !! call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) + !! if (mapl_am_I_root()) then + !! write(6,105) 'obs_file_begin provided: ', trim(STR1) + !! end if + !!end if + + + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin provided: ', trim(STR1) end if call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label=prefix // 'obs_file_end:', _RC) - if (trim(STR1)=='') then - _FAIL('obs_file_end missing, code crash') + call ESMF_TimeIntervalSet(obs_time_span, d=100, _RC) + this%obsfile_end_time = this%obsfile_start_time + obs_time_span + call ESMF_TimeGet(this%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end missing, default = begin+100D:', trim(STR1) + endif else call ESMF_TimeSet(this%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end provided:', trim(STR1) + end if end if call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label= prefix// 'obs_file_interval:', _RC) _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') + if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) + if (mapl_am_I_root()) write(6,106) 'Epoch (second) :', second - -! if (mapl_am_I_root()) then -! write(6,'(//2x, a)') 'SWATH initialize_from_config_with_prefix' -! print*, 'obs_file_begin: str1=', trim(STR1) -! write(6,105) 'obs_file_begin provided: ', trim(STR1) -! print*, 'obs_file_end: str1=', trim(STR1) -! write(6,105) 'obs_file_end provided:', trim(STR1) -! write(6,105) 'obs_file_interval:', trim(STR1) -! write(6,106) 'Epoch (hhmmss) :', this%epoch -! end if - - i= index( trim(STR1), ' ' ) if (i>0) then symd=STR1(1:i-1) @@ -501,29 +633,12 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc symd='' shms=trim(STR1) endif - call convert_twostring_2_esmfinterval (symd, shms, this%obsfile_interval, _RC) - - second = hms_2_s(this%Epoch) - call ESMF_TimeIntervalSet(this%epoch_frequency, s=second, _RC) - - if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then - call ESMF_TimeSet(currTime, timeString=tmp, _RC) - else - read(tmp,'(i4,5i2)') yy,mm,dd,h,m,s - call ESMF_Timeset(currTime, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, _RC) - endif - - call lgr%debug(' %a %a', 'input_template =', trim(this%input_template)) - !!write(6,'(2x,a,/,4i8,/,5(2x,a))') 'nx,ny,lm,epoch -- filename,tmp', & - !! this%nx,this%ny,this%lm,this%epoch,& - !! trim(filename),trim(tmp) - !!print*, 'ck: Epoch_init:', trim(tmp) - + call convert_twostring_2_esmfinterval (symd, shms, this%obsfile_interval, _RC) call ESMF_ConfigGetAttribute(config, value=this%index_name_lon, default="", & label=prefix // 'index_name_lon:', _RC) call ESMF_ConfigGetAttribute(config, value=this%index_name_lat, default="", & - label=prefix // 'index_name_lat:', _RC) + label=prefix // 'index_name_lat:', _RC) call ESMF_ConfigGetAttribute(config, this%var_name_lon, & label=prefix // 'var_name_lon:', default="", _RC) call ESMF_ConfigGetAttribute(config, this%var_name_lat, & @@ -531,15 +646,16 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%var_name_time, default="", & label=prefix//'var_name_time:', _RC) call ESMF_ConfigGetAttribute(config, this%tunit, default="", & - label=prefix//'tunit:', _RC) + label=prefix//'tunit:', _RC) + + call lgr%debug(' %a %a', 'input_template =', trim(this%input_template)) - !__ s2. find obsFile even if missing on disk and get array: this%t_alongtrack(:) ! call ESMF_VMGet(vm, mpiCommunicator=mpic, _RC) call MPI_COMM_RANK(mpic, irank, ierror) - + if (irank==0) & write(6,'(10(2x,a20,2x,a40,/))') & 'index_name_lon:', trim(this%index_name_lon), & @@ -547,42 +663,54 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc 'var_name_lon:', trim(this%var_name_lon), & 'var_name_lat:', trim(this%var_name_lat), & 'var_name_time:', trim(this%var_name_time), & - 'tunit:', trim(this%tunit) - - if (irank==0) then + 'tunit:', trim(this%tunit) + + if (irank==0) then call ESMF_TimeIntervalSet(Toff, h=0, m=0, s=0, _RC) call Find_M_files_for_currTime (currTime, & this%obsfile_start_time, this%obsfile_end_time, this%obsfile_interval, & this%epoch_frequency, this%input_template, M_file, this%filenames, & T_offset_in_file_content = Toff, _RC) this%M_file = M_file - write(6,'(10(2x,a20,2x,i40))') & + write(6,'(10(2x,a20,2x,i40))') & 'M_file:', M_file do i=1, M_file - write(6,'(10(2x,a20,2x,a))') & - 'filenames(i):', trim(this%filenames(i)) + write(6,'(10(2x,a14,i4,a2,2x,a))') & + 'filenames(', i, '):', trim(this%filenames(i)) end do + !------------------------------------------------------------ + ! QC for obs files: + ! + ! 1. redefine nstart to skip un-defined time value + ! 2. Scan_Start_Time = -9999, -9999, -9999, + ! :: eliminate this row of data + !------------------------------------------------------------ + + allocate(lon_true(0,0), lat_true(0,0), scanTime(0,0)) call read_M_files_4_swath (this%filenames(1:M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, _RC) + this%index_name_lon, this%index_name_lat, & + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=scanTime, & + Tfilter=.true., _RC) + nlon=nx nlat=ny - allocate(scanTime(nlon, nlat)) allocate(this%t_alongtrack(nlat)) + do j=1, nlat + this%t_alongtrack(j) = scanTime(1,j) + end do - call read_M_files_4_swath (this%filenames(1:M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, & - var_name_time=this%var_name_time, time=scanTime, _RC) + !!write(6,'(a)') 'this%t_alongtrack(::50)=' + !!write(6,'(5f20.2)') this%t_alongtrack(::50) - do j=1, nlat - this%t_alongtrack(j)= scanTime(1,j) - enddo nstart = 1 ! - ! redefine nstart to skip un-defined time value ! If the t_alongtrack contains undefined values, use this code - ! + ! x0 = this%t_alongtrack(1) x1 = 1.d16 if (x0 > x1) then @@ -590,7 +718,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc ! bisect backward finding the first index arr[n] < x1 klo=1 khi=nlat - max_iter = int( log( real(nlat) ) / log(2.d0) ) + 2 + max_iter = int( log( real(nlat) ) / log(2.d0) ) + 2 do i=1, max_iter k = (klo+khi)/2 if ( this%t_alongtrack(k) < x1 ) then @@ -607,7 +735,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%cell_across_swath = nlon this%cell_along_swath = nlat deallocate(scanTime) -!! write(6,*) 'this%t_alongtrack(j)=', this%t_alongtrack(::100) + ! P2. @@ -623,26 +751,32 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc j1= j0 + sec jx0= j0 jx1= j1 - call lgr%debug ('%a %i16 %i16', 'j0, j1 ', j0, j1) - this%epoch_index(1)= 1 this%epoch_index(2)= this%cell_across_swath - call bisect( this%t_alongtrack, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(this%cell_along_swath, ESMF_KIND_I8), rc=rc) - call bisect( this%t_alongtrack, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(this%cell_along_swath, ESMF_KIND_I8), rc=rc) + nend = this%cell_along_swath + call bisect( this%t_alongtrack, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call bisect( this%t_alongtrack, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) + call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) + call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & + this%t_alongtrack(1), this%t_alongtrack(nend)) + call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) if (jt1==jt2) then _FAIL('Epoch Time is too small, empty swath grid is generated, increase Epoch') endif + jt1 = jt1 + 1 ! (x1,x2] design this%epoch_index(3)= jt1 this%epoch_index(4)= jt2 + _ASSERT( jt1 < jt2, 'Swath grid fail : epoch_index(3) > epoch_index(4)') Xdim = this%cell_across_swath Ydim = this%epoch_index(4) - this%epoch_index(3) + 1 call lgr%debug ('%a %i4 %i4', 'bisect for j0: rc, jt', rc, jt1) - call lgr%debug ('%a %i4 %i4', 'bisect for j1: rc, jt', rc, jt2) + call lgr%debug ('%a %i4 %i4', 'bisect for j1: rc, jt', rc, jt2) call lgr%debug ('%a %i4 %i4', 'Xdim, Ydim', Xdim, Ydim) call lgr%debug ('%a %i4 %i4 %i4 %i4', 'this%epoch_index(4)', & this%epoch_index(1), this%epoch_index(2), & @@ -651,7 +785,8 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%im_world = Xdim this%jm_world = Ydim end if - + + call MPI_bcast(this%M_file, 1, MPI_INTEGER, 0, mpic, ierror) do i=1, this%M_file call MPI_bcast(this%filenames(i), ESMF_MAXSTR, MPI_CHARACTER, 0, mpic, ierror) @@ -660,9 +795,10 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call MPI_bcast(this%im_world, 1, MPI_INTEGER, 0, mpic, ierror) call MPI_bcast(this%jm_world, 1, MPI_INTEGER, 0, mpic, ierror) call MPI_bcast(this%cell_across_swath, 1, MPI_INTEGER, 0, mpic, ierror) - call MPI_bcast(this%cell_along_swath, 1, MPI_INTEGER, 0, mpic, ierror) + call MPI_bcast(this%cell_along_swath, 1, MPI_INTEGER, 0, mpic, ierror) ! donot need to bcast this%along_track (root only) - + + call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'IMS_FILE:', rc=status) if ( status == _SUCCESS ) then call get_ims_from_file(this%ims, trim(tmp),this%nx, _RC) @@ -678,9 +814,8 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc ! ims is set at here call this%check_and_fill_consistency(_RC) - _RETURN(_SUCCESS) - + 105 format (1x,a,2x,a) 106 format (1x,a,2x,10i8) @@ -698,11 +833,11 @@ subroutine get_multi_integer(values, label, rc) logical :: isPresent call ESMF_ConfigFindLabel(config, label=prefix//label, isPresent=isPresent, _RC) - + if (.not. isPresent) then _RETURN(_SUCCESS) end if - + ! First pass: count values n = 0 do @@ -721,9 +856,9 @@ subroutine get_multi_integer(values, label, rc) call ESMF_ConfigFindLabel(config, label=prefix//label,_RC) do i = 1, n call ESMF_ConfigGetAttribute(config, values(i), _RC) - write(6,*) 'values(i)=', values(i) + write(6,*) 'values(i)=', values(i) end do - + _RETURN(_SUCCESS) end subroutine get_multi_integer @@ -796,7 +931,7 @@ function to_string(this) result(string) end function to_string - + subroutine check_and_fill_consistency(this, unusable, rc) use MAPL_BaseMod, only: MAPL_DecomposeDim class (SwathGridFactory), intent(inout) :: this @@ -869,7 +1004,7 @@ end subroutine verify end subroutine check_and_fill_consistency - + elemental subroutine set_with_default_integer(to, from, default) integer, intent(out) :: to integer, optional, intent(in) :: from @@ -936,7 +1071,7 @@ elemental subroutine set_with_default_bounds(to, from, default) end subroutine set_with_default_bounds - + ! MAPL uses values in lon_array and lat_array only to determine the ! general positioning. Actual coordinates are then recomputed. ! This helps to avoid roundoff differences from slightly different @@ -967,7 +1102,7 @@ subroutine initialize_from_esmf_distGrid(this, dist_grid, lon_array, lat_array, real, parameter :: tiny = 1.e-4 _FAIL ('stop: not implemented: subroutine initialize_from_esmf_distGrid') - + _UNUSED_DUMMY(unusable) call ESMF_DistGridGet(dist_grid, dimCount=dim_count, tileCount=tile_count) @@ -1078,7 +1213,7 @@ function generate_grid_name(this) result(name) name = im_string // 'x' // jm_string end function generate_grid_name - + function check_decomposition(this,unusable,rc) result(can_decomp) class (SwathGridFactory), target, intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable @@ -1098,7 +1233,7 @@ function check_decomposition(this,unusable,rc) result(can_decomp) _RETURN(_SUCCESS) end function check_decomposition - + subroutine generate_newnxy(this,unusable,rc) use MAPL_BaseMod, only: MAPL_DecomposeDim class (SwathGridFactory), target, intent(inout) :: this @@ -1171,7 +1306,7 @@ subroutine append_metadata(this, metadata) character(len=ESMF_MAXSTR) :: key_lon character(len=ESMF_MAXSTR) :: key_lat - + ! Horizontal grid dimensions call metadata%add_dimension('lon', this%im_world) call metadata%add_dimension('lat', this%jm_world) @@ -1186,10 +1321,10 @@ subroutine append_metadata(this, metadata) call v%add_attribute('long_name', 'latitude') call v%add_attribute('units', 'degrees_north') call metadata%add_variable('lats', v) - + end subroutine append_metadata - + function get_grid_vars(this) result(vars) class (SwathGridFactory), intent(inout) :: this @@ -1197,7 +1332,7 @@ function get_grid_vars(this) result(vars) character(len=ESMF_MAXSTR) :: key_lon character(len=ESMF_MAXSTR) :: key_lat _UNUSED_DUMMY(this) - + !!key_lon=trim(this%var_name_lon) !!key_lat=trim(this%var_name_lat) vars = 'lon,lat' @@ -1300,7 +1435,7 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) integer:: irank, ierror integer :: status - type(ESMF_Time) :: T1, T2 + type(ESMF_Time) :: T1, T2 integer(ESMF_KIND_I8) :: i1, i2 real(ESMF_KIND_R8) :: iT1, iT2 integer(ESMF_KIND_I8) :: index1, index2 @@ -1315,7 +1450,7 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) ! xtrack xy_subset(1:2,1)=this%epoch_index(1:2) - ! atrack + ! atrack T1= interval(1) T2= interval(2) @@ -1337,24 +1472,24 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) call bisect( this%t_alongtrack, iT1, index1, n_LB=int(jlo, ESMF_KIND_I8), n_UB=int(jhi, ESMF_KIND_I8), rc=rc) call bisect( this%t_alongtrack, iT2, index2, n_LB=int(jlo, ESMF_KIND_I8), n_UB=int(jhi, ESMF_KIND_I8), rc=rc) - !! complex version + !! complex version !! ! (x1, x2] design in bisect !! if (index1==jlo-1) then !! je = index1 + 1 !! else !! je = index1 !! end if - !! xy_subset(1, 2) = je + !! xy_subset(1, 2) = je !! if (index2==jlo-1) then !! je = index2 + 1 !! else !! je = index2 - !! end if + !! end if !! xy_subset(2, 2) = je - ! simple version + ! simple version xy_subset(1, 2)=index1+1 ! atrack - xy_subset(2, 2)=index2 + xy_subset(2, 2)=index2 ! !- relative @@ -1364,18 +1499,18 @@ subroutine get_xy_subset(this, interval, xy_subset, rc) end if call MPI_bcast(xy_subset, 4, MPI_INTEGER, 0, mpic, ierror) - + _RETURN(_SUCCESS) end subroutine get_xy_subset - + subroutine destroy(this, rc) class(SwathGridFactory), intent(inout) :: this integer, optional, intent(out) :: rc - integer :: i + integer :: i return end subroutine destroy - + ! here grid == external_grid ! because this%grid is protected in AbstractGridFactory @@ -1392,8 +1527,10 @@ subroutine get_obs_time(this, grid, obs_time, rc) !! shared mem real(kind=ESMF_KIND_R8), pointer :: fptr(:,:) real, pointer :: centers(:,:) - real, allocatable :: centers_full(:,:) - + real, allocatable :: lon_true(:,:) + real, allocatable :: lat_true(:,:) + real, allocatable :: time_true(:,:) + integer :: i, j, k integer :: Xdim, Ydim integer :: Xdim_full, Ydim_full @@ -1413,19 +1550,22 @@ subroutine get_obs_time(this, grid, obs_time, rc) call MAPL_SyncSharedMemory(_RC) - ! read Time and set + ! read and set Time if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - allocate( centers_full(Xdim_full, Ydim_full)) + allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & this%index_name_lon, this%index_name_lat, & - var_name_time=this%var_name_time, time=centers_full, _RC) - !!call get_v2d_netcdf(this%grid_file_name, time_name, centers_full, Xdim_full, Ydim_full) + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=time_true, & + Tfilter=.true., _RC) k=0 do j=this%epoch_index(3), this%epoch_index(4) k=k+1 - centers(1:Xdim, k) = centers_full(1:Xdim, j) + centers(1:Xdim, k) = time_true(1:Xdim, j) enddo - deallocate (centers_full) + deallocate (lon_true, lat_true, time_true) end if call MAPL_SyncSharedMemory(_RC) diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index be20b3d76bb1..33035962936e 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -117,7 +117,11 @@ subroutine get_attribute_from_group(filename, group_name, var_name, attr_name, a character(len=100) :: str2 call check_nc_status(nf90_open(fileName, NF90_NOWRITE, ncid2), _RC) - call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + if (group_name/='') then + call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + else + ncid = ncid2 + end if call check_nc_status(nf90_inq_varid(ncid, var_name, varid), _RC) call check_nc_status(nf90_inquire_attribute(ncid, varid, attr_name, xtype, len=len), _RC) c_ncid= ncid @@ -241,7 +245,6 @@ subroutine check_nc_status(status, rc) integer, intent(out), optional :: rc _ASSERT(status == nf90_noerr, 'netCDF error: '//trim(nf90_strerror(status))) - _RETURN(_SUCCESS) end subroutine check_nc_status @@ -287,10 +290,20 @@ subroutine time_esmf_2_nc_int(time, tunit, n, rc) type(ESMF_Time) :: time0 type(ESMF_TimeInterval) :: dt + character(len=ESMF_MAXSTR) :: STR1 + + n=0 call parse_timeunit(tunit, n, time0, dt, _RC) dt = time - time0 +! ! test +! write(6, '(2x,a,2x,a)') 'tunit=', trim(tunit) +! call ESMF_TimeGet(time, timestring=STR1, _RC) +! write(6, '(2x,a,2x,a)') 'time=', trim(STR1) +! call ESMF_TimeGet(time0, timestring=STR1, _RC) +! write(6, '(2x,a,2x,a)') 'time0=', trim(STR1) + ! assume unit is second ! call ESMF_TimeIntervalGet(dt, s_i8=n, _RC) @@ -300,6 +313,10 @@ subroutine time_esmf_2_nc_int(time, tunit, n, rc) end subroutine time_esmf_2_nc_int + ! + ! n sec after tunit + ! t0 = since [ xxxx-xx-xx ] + ! dt = n sec subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) use ESMF implicit none @@ -329,7 +346,7 @@ subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) isec=n gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) - call ESMF_timeSet(t0, yy=y,mm=m,dd=m,h=hour,m=min,s=sec,& + call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,& calendar=gregorianCalendar, _RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s=isec, _RC) @@ -363,11 +380,14 @@ subroutine parse_timeunit_i8(tunit, n, t0, dt, rc) read(s1, '(i4,a1,i2,a1,i2)') y, c1, m, c1, d read(s2, '(i2,a1,i2,a1,i2)') hour, c1, min, c1, sec +! write(6,*) 'y, c1, m, c1, d', y, c1, m, c1, d +! write(6,*) 'hour, c1, min, c1, sec', hour, c1, min, c1, sec + _ASSERT(trim(s_unit) == 'seconds', "s_unit /= 'seconds' is not handled") isec=n gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) - call ESMF_timeSet(t0, yy=y,mm=m,dd=m,h=hour,m=min,s=sec,& + call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,& calendar=gregorianCalendar, _RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s_i8=isec, _RC) @@ -451,7 +471,7 @@ subroutine bisect_find_LB_R8_I8(xa, x, n, n_LB, n_UB, rc) if(present(n_LB)) LB=max(LB, n_LB) if(present(n_UB)) UB=min(UB, n_UB) klo=LB; khi=UB; dk=1 - + if ( xa(LB ) > xa(UB) ) then klo= UB khi= LB @@ -673,7 +693,7 @@ function matches( string, substring ) RETURN end function matches - + subroutine split_string_by_space (string_in, length_mx, & mxseg, nseg, str_piece, jstatus) integer, intent (in) :: length_mx diff --git a/gridcomps/History/MAPL_EpochSwathMod.F90 b/gridcomps/History/MAPL_EpochSwathMod.F90 index 62b94145df5f..82fdebcbd9b6 100644 --- a/gridcomps/History/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/MAPL_EpochSwathMod.F90 @@ -29,27 +29,35 @@ module MAPL_EpochSwathMod use MAPL_DownbitMod use Plain_netCDF_Time use, intrinsic :: ISO_C_BINDING - use, intrinsic :: iso_fortran_env, only: REAL64 - use ieee_arithmetic, only: isnan => ieee_is_nan + use MAPL_CommsMod, only : MAPL_Am_I_Root implicit none - private - type, public :: samplerHQ + integer, parameter :: ngrid_max = 10 + + type, private :: K_V_CF + character(len=ESMF_MAXSTR) :: key + type(ESMF_config) :: cf + end type K_V_CF + + type, public :: samplerHQ type(ESMF_Clock) :: clock type(ESMF_Alarm) :: alarm type(ESMF_Time) :: RingTime type(ESMF_TimeInterval) :: Frequency_epoch - type(ESMF_config) :: config_grid_save - type(ESMF_grid) :: ogrid + integer :: ngrid = 0 character(len=ESMF_MAXSTR) :: grid_type + character(len=ESMF_MAXSTR) :: tunit + type (K_V_CF) :: CF_loc(ngrid_max) real*8 :: arr(2) contains procedure :: create_grid procedure :: regrid_accumulate => regrid_accumulate_on_xysubset procedure :: destroy_rh_regen_ogrid - procedure :: fill_time_in_bundle + procedure :: fill_time_in_bundle + procedure :: find_config + procedure :: config_accumulate end type samplerHQ interface samplerHQ @@ -67,7 +75,7 @@ module MAPL_EpochSwathMod logical :: doVertRegrid = .false. type(ESMF_FieldBundle) :: output_bundle type(ESMF_FieldBundle) :: input_bundle - type(ESMF_FieldBundle) :: acc_bundle + type(ESMF_FieldBundle) :: acc_bundle type(ESMF_Time) :: startTime integer :: regrid_method = REGRID_METHOD_BILINEAR integer :: nbits_to_keep = MAPL_NBITS_NOT_SET @@ -86,7 +94,7 @@ module MAPL_EpochSwathMod logical :: have_initalized contains !! procedure :: CreateFileMetaData - procedure :: Create_bundle_RH + procedure :: Create_bundle_RH procedure :: CreateVariable procedure :: regridScalar procedure :: regridVector @@ -95,7 +103,7 @@ module MAPL_EpochSwathMod procedure :: check_chunking procedure :: alphabatize_variables procedure :: addVariable_to_acc_bundle - procedure :: addVariable_to_output_bundle + procedure :: addVariable_to_output_bundle procedure :: interp_accumulate_fields end type sampler @@ -105,36 +113,36 @@ module MAPL_EpochSwathMod contains - function new_samplerHQ(clock, config, key, rc) result(hq) + ! + ! in MAPL_HistoryGridComp.F90, Hsampler get its config and key + ! from the first SwathGrid entry in HISTORY.rc + ! thus + ! there is only one frequency_epoch for all the SwathGrid usage + ! + function new_samplerHQ(clock, key, config, rc) result(hq) implicit none type(samplerHQ) :: hq - type(ESMF_Clock), intent(in) :: clock + type(ESMF_Clock), intent(in) :: clock + character(len=*), intent(in) :: key type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: key - integer, optional, intent(out) :: rc + integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR) :: time_string integer :: status + integer :: second integer :: time_integer - type(ESMF_Time) :: RingTime_epoch - type(ESMF_Time) :: startTime - type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: timeStep + type(ESMF_Time) :: startTime + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep type(ESMF_TimeInterval) :: Frequency_epoch - integer :: sec, second - integer :: n1 - type(ESMF_Config) :: cf - hq%clock= clock - hq%config_grid_save= config - hq%arr(1:2) = -2.d0 call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) call ESMF_ClockGet ( clock, timestep=timestep, _RC ) call ESMF_ClockGet ( clock, startTime=startTime, _RC ) call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(key)//'.Epoch:', default=0, _RC) + call ESMF_ConfigGetAttribute(config, value=hq%tunit, label=trim(key)//'.tunit:', default="", _RC) _ASSERT(time_integer /= 0, 'Epoch value in config wrong') second = hms_2_s (time_integer) call ESMF_TimeIntervalSet(frequency_epoch, s=second, _RC) @@ -146,7 +154,44 @@ function new_samplerHQ(clock, config, key, rc) result(hq) _RETURN(_SUCCESS) end function new_samplerHQ - + + + function find_config (this, key, rc) result(cf) + class(samplerHQ) :: this + character(len=*) , intent(in) :: key + type(ESMF_Config) :: cf + integer, intent(out), optional :: rc + integer :: status + integer :: i, j + + j=0 + do i=1, this%ngrid + if ( trim(key) == trim(this%CF_loc(i)%key) ) then + cf = this%CF_loc(i)%cf + j=j+1 + exit + end if + end do + + _ASSERT( j>0 , trim(key)//' is not found in Hsampler CF_loc(:)') + + _RETURN(_SUCCESS) + end function find_config + + + subroutine config_accumulate (this, key, cf, rc) + class(samplerHQ) :: this + type(ESMF_Config), intent(in) :: cf + character(len=*) , intent(in) :: key + integer, intent(out), optional :: rc + integer :: status + + this%ngrid = this%ngrid + 1 + this%CF_loc(this%ngrid)%key = trim(key) + this%CF_loc(this%ngrid)%cf = cf + _RETURN(_SUCCESS) + end subroutine config_accumulate + !--------------------------------------------------! ! __ set @@ -161,24 +206,26 @@ function create_grid(this, key, currTime, grid_type, rc) result(ogrid) character(len=*), optional, intent(in) :: grid_type integer, intent(out), optional :: rc integer :: status - + type(ESMF_Config) :: config_grid character(len=ESMF_MAXSTR) :: time_string - logical :: ispresent if (present(grid_type)) this%grid_type = trim(grid_type) - config_grid = this%config_grid_save + config_grid = this%find_config(key) call ESMF_TimeGet(currTime, timeString=time_string, _RC) - ! + + ! ! -- the `ESMF_ConfigSetAttribute` shows a risk ! to overwrite the nextline in config ! call ESMF_ConfigSetAttribute( config_grid, trim(time_string), label=trim(key)//'.Epoch_init:', _RC) + ogrid = grid_manager%make_grid(config_grid, prefix=trim(key)//'.', _RC ) - this%ogrid = ogrid + !! call grid_validate (ogrid,) + _RETURN(_SUCCESS) - + end function create_grid @@ -187,76 +234,62 @@ subroutine regrid_accumulate_on_xysubset (this, sp, rc) class(sampler), intent(inout) :: sp integer, intent(out), optional :: rc integer :: status - - class(AbstractGridFactory), pointer :: factory - integer :: xy_subset(2,2) - type(ESMF_Time) :: timeset(2) - type(ESMF_Time) :: current_time - type(ESMF_TimeInterval) :: dur - character(len=ESMF_MAXSTR) :: time_string - integer, allocatable :: global_xy_mask(:,:) - integer, allocatable :: local_xy_mask(:,:) + class(AbstractGridFactory), pointer :: factory + type(ESMF_Time) :: timeset(2) + type(ESMF_Time) :: current_time + type(ESMF_TimeInterval) :: dur + integer :: xy_subset(2,2) - integer :: counts(5) - integer :: dims(3) - integer :: m1, m2 - ! __ s1. get xy_subset - factory => grid_manager%get_factory(this%ogrid,_RC) call ESMF_ClockGet(this%clock,currTime=current_time,_RC) call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) timeset(1) = current_time - dur timeset(2) = current_time + + factory => grid_manager%get_factory(sp%output_grid,_RC) call factory%get_xy_subset( timeset, xy_subset, _RC) - + ! __ s2. interpolate then save data using xy_mask call sp%interp_accumulate_fields (xy_subset, _RC) _RETURN(ESMF_SUCCESS) - - end subroutine regrid_accumulate_on_xysubset - + + end subroutine regrid_accumulate_on_xysubset + subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) implicit none - class(samplerHQ) :: this + class(samplerHQ), target :: this class(sampler) :: sp type (StringGridMap), target, intent(inout) :: output_grids character(len=*), intent(in) :: key_grid_label - integer, intent(out), optional :: rc + integer, intent(out), optional :: rc integer :: status - - class(AbstractGridFactory), pointer :: factory + type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: dur - character(len=ESMF_MAXSTR) :: time_string - type(ESMF_Grid), pointer :: pgrid type(ESMF_Grid) :: ogrid - type(ESMF_Grid) :: input_grid character(len=ESMF_MAXSTR) :: key_str type (StringGridMapIterator) :: iter character(len=:), pointer :: key - type (ESMF_Config) :: config_grid - + integer :: i, numVars character(len=ESMF_MAXSTR), allocatable :: names(:) type(ESMF_Field) :: field - + if ( .NOT. ESMF_AlarmIsRinging(this%alarm) ) then - write(6,*) 'ck: regen, not in alarming' - rc=0 - return + _RETURN(ESMF_SUCCESS) endif - !__ s1. destroy ogrid + regen ogrid + !__ s1. destroy ogrid + RH, regen ogrid + + key_str = trim(key_grid_label) + pgrid => output_grids%at(key_str) - key_str=trim(key_grid_label) - pgrid => output_grids%at(trim(key_grid_label)) call grid_manager%destroy(pgrid,_RC) call ESMF_ClockGet (this%clock, CurrTime=currTime, _RC ) @@ -266,19 +299,18 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) if (trim(key)==trim(key_str)) then ogrid = this%create_grid (key_str, currTime, _RC) call output_grids%set(key, ogrid) - this%ogrid = ogrid endif call iter%next() enddo !__ s2. destroy RH - call sp%regrid_handle%destroy(_RC) - + + !__ s3. destroy acc_bundle / output_bundle - + call ESMF_FieldBundleGet(sp%acc_bundle,fieldCount=numVars,_RC) allocate(names(numVars),stat=status) call ESMF_FieldBundleGet(sp%acc_bundle,fieldNameList=names,_RC) @@ -298,18 +330,19 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) _RETURN(ESMF_SUCCESS) - + end subroutine destroy_rh_regen_ogrid - subroutine fill_time_in_bundle (this, xname, bundle, rc) + subroutine fill_time_in_bundle (this, xname, bundle, ogrid, rc) implicit none class(samplerHQ) :: this character(len=*), intent(in) :: xname type(ESMF_FieldBundle), intent(inout) :: bundle integer, optional, intent(out) :: rc - integer :: status + integer :: status + type(ESMF_Grid), intent(in) :: ogrid class(AbstractGridFactory), pointer :: factory type(ESMF_Field) :: field real(kind=ESMF_KIND_R4), pointer :: ptr2d(:,:) @@ -317,16 +350,16 @@ subroutine fill_time_in_bundle (this, xname, bundle, rc) ! __ get field xname='time' call ESMF_FieldBundleGet (bundle, xname, field=field, _RC) call ESMF_FieldGet (field, farrayptr=ptr2d, _RC) - + ! __ obs_time from swath factory - factory => grid_manager%get_factory(this%ogrid,_RC) - call factory%get_obs_time (this%ogrid, ptr2d, _RC) - + factory => grid_manager%get_factory(ogrid,_RC) + call factory%get_obs_time (ogrid, ptr2d, _RC) + _RETURN(ESMF_SUCCESS) end subroutine fill_time_in_bundle - + function new_sampler(metadata,input_bundle,output_bundle,write_collection_id,read_collection_id, & metadata_collection_id,regrid_method,fraction,items,rc) result(GriddedIO) type(sampler) :: GriddedIO @@ -354,14 +387,14 @@ function new_sampler(metadata,input_bundle,output_bundle,write_collection_id,rea end function new_sampler - subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attributes,rc) + subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) class (sampler), intent(inout) :: this type(GriddedIOitemVector), target, intent(inout) :: items type(ESMF_FieldBundle), intent(inout) :: bundle + character(len=*), intent(in) :: tunit type(TimeData), optional, intent(inout) :: timeInfo type(VerticalData), intent(inout), optional :: vdata type (ESMF_Grid), intent(inout), pointer, optional :: ogrid - type(StringStringMap), target, intent(in), optional :: global_attributes integer, intent(out), optional :: rc type(ESMF_Grid) :: input_grid @@ -370,10 +403,6 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib type(ESMF_Field) :: new_field type(GriddedIOitemVectorIterator) :: iter type(GriddedIOitem), pointer :: item - type(stringVector) :: order - integer :: metadataVarsSize - type(StringStringMapIterator) :: s_iter - character(len=:), pointer :: attr_name, attr_val integer :: status this%items = items @@ -418,7 +447,7 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib this%vdata=VerticalData(rc=status) _VERIFY(status) end if - + call this%vdata%append_vertical_metadata(this%metadata,this%input_bundle,rc=status) _VERIFY(status) this%doVertRegrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) @@ -450,7 +479,7 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib item => iter%get() call this%addVariable_to_acc_bundle(item%xname,_RC) if (item%itemType == ItemTypeVector) then - call this%addVariable_to_acc_bundle(item%yname,_RC) + call this%addVariable_to_acc_bundle(item%yname,_RC) end if call iter%next() enddo @@ -460,13 +489,16 @@ subroutine Create_bundle_RH(this,items,bundle,timeInfo,vdata,ogrid,global_attrib ! new_field = ESMF_FieldCreate(this%output_grid ,name='time', & typekind=ESMF_TYPEKIND_R4,_RC) + ! + ! add attribute + ! + call ESMF_AttributeSet(new_field,'UNITS',trim(tunit),_RC) call MAPL_FieldBundleAdd( this%acc_bundle, new_field, _RC ) - _RETURN(_SUCCESS) end subroutine Create_Bundle_RH - + subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,nbits_to_keep,regrid_method,itemOrder,write_collection_id,rc) class (sampler), intent(inout) :: this integer, optional, intent(in) :: deflation @@ -577,9 +609,7 @@ subroutine CreateVariable(this,itemName,rc) integer :: fieldRank logical :: isPresent character(len=ESMF_MAXSTR) :: varName,longName,units - character(len=:), allocatable :: grid_dims - character(len=:), allocatable :: vdims - type(Variable) :: v + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) _VERIFY(status) @@ -641,7 +671,7 @@ subroutine RegridScalar(this,itemName,rc) type(ESMF_Grid) :: gridIn,gridOut logical :: hasDE_in, hasDE_out logical :: first_entry - + call ESMF_FieldBundleGet(this%output_bundle,itemName,field=outField,rc=status) _VERIFY(status) call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) @@ -714,8 +744,8 @@ subroutine RegridScalar(this,itemName,rc) !! print *, maxval(ptr2d) !! print *, minval(ptr2d) !! print *, maxval(outptr2d) -!! print *, minval(outptr2d) - +!! print *, minval(outptr2d) + else if (fieldRank==3) then if (.not.associated(ptr3d)) then if (hasDE_in) then @@ -914,7 +944,7 @@ subroutine RegridVector(this,xName,yName,rc) end subroutine RegridVector - + subroutine alphabatize_variables(this,nfixedVars,rc) class (sampler), intent(inout) :: this integer, intent(in) :: nFixedVars @@ -967,18 +997,14 @@ subroutine alphabatize_variables(this,nfixedVars,rc) end subroutine alphabatize_variables - + subroutine addVariable_to_acc_bundle(this,itemName,rc) class (sampler), intent(inout) :: this character(len=*), intent(in) :: itemName integer, optional, intent(out) :: rc type(ESMF_Field) :: field,newField - type(ESMF_Array) :: array1 - real(KIND=ESMF_KIND_R4), pointer :: pt2d(:,:) - class (AbstractGridFactory), pointer :: factory integer :: fieldRank - logical :: isPresent integer :: status call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) @@ -1001,9 +1027,7 @@ subroutine addVariable_to_output_bundle(this,itemName,rc) integer, optional, intent(out) :: rc type(ESMF_Field) :: field,newField - class (AbstractGridFactory), pointer :: factory integer :: fieldRank - logical :: isPresent integer :: status call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) @@ -1017,8 +1041,8 @@ subroutine addVariable_to_output_bundle(this,itemName,rc) _RETURN(_SUCCESS) end subroutine addVariable_to_output_bundle - - + + !! -- based on subroutine bundlepost(this,filename,oClients,rc) !! @@ -1033,23 +1057,20 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) type(ESMF_Field) :: outField type(ESMF_Field) :: new_outField type(ESMF_Grid) :: grid - integer :: tindex - type(ArrayReference) :: ref type(GriddedIOitemVectorIterator) :: iter type(GriddedIOitem), pointer :: item - logical :: have_time type(ESMF_Array) :: array1, array2 integer :: is,ie,js,je - integer :: rank, rank1, rank2 + integer :: rank real(KIND=ESMF_KIND_R4), pointer :: pt2d(:,:), pt2d_(:,:) real(KIND=ESMF_KIND_R4), pointer :: pt3d(:,:,:), pt3d_(:,:,:) integer :: localDe, localDECount integer, dimension(:), allocatable :: LB, UB, exclusiveCount - integer, dimension(:), allocatable :: compLB, compUB, compCount + integer, dimension(:), allocatable :: compLB, compUB, compCount integer :: dimCount integer :: y1, y2 integer :: j, jj @@ -1059,16 +1080,21 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) is=xy_subset(1,1); ie=xy_subset(2,1) js=xy_subset(1,2); je=xy_subset(2,2) + if (js > je) then + ! no valid points are found on swath grid for this time step + _RETURN(ESMF_SUCCESS) + end if + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then call this%vdata%setup_eta_to_pressure(regrid_handle=this%regrid_handle,output_grid=this%output_grid,rc=status) _VERIFY(status) end if - + call ESMF_FieldBundleGet(this%output_bundle, grid=grid, _RC) call ESMF_GridGet(grid, localDECount=localDECount, dimCount=dimCount, _RC) allocate ( LB(dimCount), UB(dimCount), exclusiveCount(dimCount) ) - allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) - + allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) + allocate ( j1(0:localDEcount-1) ) ! start allocate ( j2(0:localDEcount-1) ) ! end @@ -1079,7 +1105,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) LB(1)=ii1; LB(2)=jj1 UB(1)=iin; UB(2)=jjn - + do localDe=0, localDEcount-1 ! ! is/ie, js/je, [LB, UB] @@ -1114,7 +1140,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) !! write(6,*) 'j1(localDe)', j1(0:localDeCount-1) !! write(6,*) 'j2(localDe)', j2(0:localDeCount-1) - + iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1170,7 +1196,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) end subroutine interp_accumulate_fields - + subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) implicit none type(ESMF_Grid), intent(in) :: grid @@ -1180,12 +1206,10 @@ subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) integer :: status integer :: ii1, iin, jj1, jjn ! local box for localDE - integer :: is, ie, js, je ! global box for each time-interval - integer :: j1p, jnp ! local y-index for each time-interval + integer :: is,ie, js, je ! global box for each time-interval - integer :: dimCount integer :: y1, y2 - integer :: j, jj + integer :: jj integer :: j1, j2 is=xy_subset(1,1); ie=xy_subset(2,1) @@ -1230,5 +1254,5 @@ subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) end subroutine get_xy_mask - + end module MAPL_EpochSwathMod diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index a29439905bbd..a742d8654335 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -405,6 +405,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! variables for counting table integer :: nline, ncol + integer :: swath_count type(HistoryCollection) :: collection character(len=ESMF_MAXSTR) :: cFileOrder @@ -601,6 +602,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_ConfigNextLine ( config,tableEnd=tend,_RC ) enddo + swath_count = 0 iter = IntState%output_grids%begin() do while (iter /= IntState%output_grids%end()) key => iter%key() @@ -620,14 +622,25 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (trim(grid_type)/='Swath') then output_grid = grid_manager%make_grid(config, prefix=key//'.', _RC) else - Hsampler = samplerHQ(clock, config, key, _RC) + swath_count = swath_count + 1 + ! + ! Hsampler use the first config to setup epoch + ! + if (swath_count == 1) then + Hsampler = samplerHQ(clock, key, config, _RC) + end if + call Hsampler%config_accumulate(key, config, _RC) output_grid = Hsampler%create_grid(key, currTime, grid_type=grid_type, _RC) + if (mapl_am_i_root()) write(6,*) 'nail af Hsampler%create_grid' + + end if call IntState%output_grids%set(key, output_grid) call iter%next() end do end block OUTPUT_GRIDS end if + if (intstate%version >= 2) then call ESMF_ConfigFindLabel(config, 'FIELD_SETS:', _RC) table_end = .false. @@ -641,7 +654,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if call ESMF_ConfigNextLine ( config,tableEnd=table_end,_RC ) enddo - + field_set_iter = intState%field_sets%begin() do while (field_set_iter /= intState%field_sets%end()) key => field_set_iter%key() @@ -706,7 +719,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( MAPL_AM_I_ROOT(vm) ) then call regen_rcx_for_obs_platform (config, nlist, list, _RC) end if - + call ESMF_VMbarrier(vm, _RC) ! Initialize History Lists @@ -897,6 +910,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) endif endif + ! Handle "backwards" mode: this is hidden (i.e. not documented) feature ! Defaults to .false. call ESMF_ConfigGetAttribute ( cfg, reverse, default=0, & @@ -1635,6 +1649,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) else sec = MAPL_nsecf(list(n)%frequency) / 2 endif + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then + call ESMF_TimeIntervalGet(Hsampler%Frequency_epoch, s=sec, _RC) + end if call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, _RC ) end do @@ -2371,7 +2388,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) else list(n)%vdata = VerticalData(positive=list(n)%positive,_RC) end if - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then call list(n)%xsampler%set_param(deflation=list(n)%deflate,_RC) call list(n)%xsampler%set_param(quantize_algorithm=list(n)%quantize_algorithm,_RC) call list(n)%xsampler%set_param(quantize_level=list(n)%quantize_level,_RC) @@ -2400,14 +2417,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%timeseries_output) then list(n)%trajectory = HistoryTrajectory(cfg,string,clock,_RC) call list(n)%trajectory%initialize(items=list(n)%items,bundle=list(n)%bundle,timeinfo=list(n)%timeInfo,vdata=list(n)%vdata,_RC) + IntState%stampoffset(n) = list(n)%trajectory%epoch_frequency elseif (list(n)%sampler_spec == 'station') then list(n)%station_sampler = StationSampler (trim(list(n)%stationIdFile), nskip_line=list(n)%stationSkipLine, _RC) call list(n)%station_sampler%add_metadata_route_handle(list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,_RC) else global_attributes = list(n)%global_atts%define_collection_attributes(_RC) - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) - call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,ogrid=pgrid,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) + call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,Hsampler%tunit,ogrid=pgrid,vdata=list(n)%vdata,_RC) else if (trim(list(n)%output_grid_label)/='') then pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) @@ -3371,7 +3389,7 @@ subroutine Run ( gc, import, export, clock, rc ) Writing(n) = .false. else if (list(n)%timeseries_output) then Writing(n) = ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) - else if (trim(list(n)%output_grid_label)=='SwathGrid') then + else if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then Writing(n) = ESMF_AlarmIsRinging ( Hsampler%alarm ) else Writing(n) = ESMF_AlarmIsRinging ( list(n)%his_alarm ) @@ -3419,13 +3437,12 @@ subroutine Run ( gc, import, export, clock, rc ) ! swath only epoch_swath_grid_case: do n=1,nlist - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then call Hsampler%regrid_accumulate(list(n)%xsampler,_RC) if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then create_mode = PFIO_NOCLOBBER ! defaut no overwrite if (intState%allow_overwrite) create_mode = PFIO_CLOBBER - ! add time to items ! true metadata comes here from mGriddedIO%metadata ! the mGriddedIO below only touches metadata, collection_id etc., it is safe. @@ -3437,7 +3454,7 @@ subroutine Run ( gc, import, export, clock, rc ) item%itemType = ItemTypeScalar item%xname = 'time' call list(n)%items%push_back(item) - call Hsampler%fill_time_in_bundle ('time', list(n)%xsampler%acc_bundle, _RC) + call Hsampler%fill_time_in_bundle ('time', list(n)%xsampler%acc_bundle, list(n)%xsampler%output_grid, _RC) call list(n)%mGriddedIO%destroy(_RC) call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%xsampler%acc_bundle,timeinfo_uninit,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) call list(n)%items%pop_back() @@ -3526,7 +3543,7 @@ subroutine Run ( gc, import, export, clock, rc ) inquire (file=trim(filename(n)),exist=file_exists) _ASSERT(.not.file_exists,trim(filename(n))//" being created for History output already exists") end if - if (trim(list(n)%output_grid_label)/='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') == 0) then call list(n)%mGriddedIO%modifyTime(oClients=o_Clients,_RC) endif list(n)%currentFile = filename(n) @@ -3655,13 +3672,15 @@ subroutine Run ( gc, import, export, clock, rc ) ! destroy ogrid/RH/acc_bundle, regenerate them ! swath only epoch_swath_regen_grid: do n=1,nlist - if (trim(list(n)%output_grid_label)=='SwathGrid') then + if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then + key_grid_label = list(n)%output_grid_label call Hsampler%destroy_rh_regen_ogrid ( key_grid_label, IntState%output_grids, list(n)%xsampler, _RC ) + pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) - call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,ogrid=pgrid,& - vdata=list(n)%vdata,global_attributes=global_attributes,_RC) + call list(n)%xsampler%Create_bundle_RH(list(n)%items,list(n)%bundle,Hsampler%tunit, & + ogrid=pgrid,vdata=list(n)%vdata,_RC) if( MAPL_AM_I_ROOT() ) write(6,'(//)') endif end if @@ -5240,10 +5259,11 @@ function get_acc_offset(current_time,ref_time,rc) result(acc_offset) end if _RETURN(_SUCCESS) end function - - + + ! __ read data to object: obs_platform ! __ for each collection: find union fields, write to collection.rcx + ! __ note: this subroutine is called by MPI root only ! subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) use MAPL_scan_pattern_in_file @@ -5251,7 +5271,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) ! ! Plan: !- read and write schema - !- extract union of field lines, print out to rc + !- extract union of field lines, print out to rc + integer, parameter :: ESMF_MAXSTR2 = 2*ESMF_MAXSTR type(ESMF_Config), intent(inout) :: config integer, intent(in) :: nlist type(HistoryCollection), pointer :: list(:) @@ -5259,21 +5280,21 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) character(len=ESMF_MAXSTR) :: HIST_CF integer :: n, unitr, unitw - logical :: match, contLine, con3 + logical :: match, contLine, con integer :: status - character (len=ESMF_MAXSTR) :: fname character (len=ESMF_MAXSTR) :: marker - character (len=ESMF_MAXSTR) :: line, line2 character (len=ESMF_MAXSTR) :: string - character (len=ESMF_MAXSTR), allocatable :: str_piece(:) + character (len=ESMF_MAXSTR2) :: line, line2 + character (len=ESMF_MAXSTR2), allocatable :: str_piece(:) type(obs_platform), allocatable :: PLFS(:) type(obs_platform) :: p1 - integer :: k, i, j + integer :: k, i, j, m, i2 integer :: ios, ngeoval, count, nplf integer :: length_mx integer :: mxseg integer :: nseg + integer :: nseg_ub integer :: nfield, nplatform integer :: nentry_name logical :: obs_flag @@ -5283,12 +5304,11 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) lgr => logging%get_logger('HISTORY.sampler') ! - ! -- note: work on HEAD node ! call ESMF_ConfigGetAttribute(config, value=HIST_CF, & label="HIST_CF:", default="HIST.rc", _RC ) unitr = GETFILE(HIST_CF, FORM='formatted', _RC) - + call scan_count_match_bgn (unitr, 'PLATFORM.', count, .false.) rewind(unitr) call lgr%debug('%a %i8','count PLATFORM.', count) @@ -5299,8 +5319,12 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) nplf = count allocate (PLFS(nplf)) allocate (map(nplf)) - - ! __ s1. scan get platform name + nc_index/lat/lon/time + + ! __ global set for call split_string by space + length_mx = ESMF_MAXSTR2 + mxseg = 100 + + ! __ s1. scan get platform name + index_name_x var_name_lat/lon/time do k=1, count call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) @@ -5313,53 +5337,51 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) call lgr%debug('%a %a', 'marker=', trim(marker)) call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'index:', .false.) + call scan_contain(unitr, 'index_name_x:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_index = trim(line(i+1:)) + PLFS(k)%index_name_x = trim(line(i+1:)) call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'longitude:', .false.) + call scan_contain(unitr, 'var_name_lon:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_lon = trim(line(i+1:)) - - call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'latitude:', .false.) + PLFS(k)%var_name_lon = trim(line(i+1:)) + + call scan_contain(unitr, marker, .true.) + call scan_contain(unitr, 'var_name_lat:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_lat = trim(line(i+1:)) + PLFS(k)%var_name_lat = trim(line(i+1:)) - call scan_contain(unitr, marker, .true.) - call scan_contain(unitr, 'time:', .false.) + call scan_contain(unitr, marker, .true.) + call scan_contain(unitr, 'var_name_time:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%nc_time = trim(line(i+1:)) + PLFS(k)%var_name_time = trim(line(i+1:)) - call scan_contain(unitr, marker, .true.) + call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'file_name_template:', .false.) backspace(unitr) read(unitr, '(a)') line i=index(line, ':') - PLFS(k)%file_name_template = trim(line(i+1:)) + PLFS(k)%file_name_template = trim(line(i+1:)) call lgr%debug('%a %a %a %a %a', & trim( PLFS(k)%name ), & - trim( PLFS(k)%nc_lon ), & - trim( PLFS(k)%nc_lat ), & - trim( PLFS(k)%nc_time ), & + trim( PLFS(k)%var_name_lon ), & + trim( PLFS(k)%var_name_lat ), & + trim( PLFS(k)%var_name_time ), & trim( PLFS(k)%file_name_template ) ) end do ! __ s2.1 scan fields: get ngeoval / nentry_name = nword - length_mx = ESMF_MAXSTR - mxseg = 10 allocate (str_piece(mxseg)) rewind(unitr) do k=1, count @@ -5369,27 +5391,29 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) i=index(line, 'PLATFORM.') j=index(line, ':') marker=line(1:j) - call scan_begin(unitr, marker, .true.) + call scan_begin(unitr, marker, .true.) call scan_contain(unitr, 'geovals_fields:', .false.) ios=0 ngeoval=0 + nseg_ub=0 do while (ios == 0) read (unitr, '(A)' ) line - i=index(line, '::') - if (i==0) then + con = .not.(adjustl(trim(line))=='::') + if (con) then ngeoval = ngeoval + 1 call split_string_by_space (line, length_mx, mxseg, & nseg, str_piece, status) + nseg_ub = max(nseg_ub, nseg) else exit endif enddo PLFS(k)%ngeoval = ngeoval - PLFS(k)%nentry_name = nseg + PLFS(k)%nentry_name = nseg_ub !! call lgr%debug('%a %i','ngeoval=', ngeoval) - - allocate ( PLFS(k)%field_name (nseg, ngeoval) ) - nentry_name = nseg ! assume the same for each field_name + allocate ( PLFS(k)%field_name (nseg_ub, ngeoval) ) + PLFS(k)%field_name = '' +!! nentry_name = nseg_ub ! assume the same for each field_name end do @@ -5403,18 +5427,21 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) j=index(line, ':') marker=line(1:j) ! - call scan_begin(unitr, marker, .true.) + call scan_begin(unitr, marker, .true.) call scan_contain(unitr, 'geovals_fields:', .false.) ios=0 ngeoval=0 do while (ios == 0) - read (unitr, '(A)' ) line - i=index(line, '::') - if (i==0) then + read (unitr, '(A)', iostat = ios) line + !! write(6,*) 'k in count, line', k, trim(line) + con = .not.(adjustl(trim(line))=='::') + if (con) then ngeoval = ngeoval + 1 call split_string_by_space (line, length_mx, mxseg, & nseg, str_piece, status) - PLFS(k)%field_name (1:nseg, ngeoval) = str_piece(1:nseg) + do m=1, nseg + PLFS(k)%field_name (m, ngeoval) = trim(str_piece(m)) + end do else exit endif @@ -5422,10 +5449,10 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) end do deallocate(str_piece) rewind(unitr) - + !!do k=1, nplf !! do i=1, ngeoval - !! write(6,*) 'PLFS(k)%field_name (1:nseg, ngeoval)=', PLFS(k)%field_name (1:nseg,i) + !! write(6,*) 'PLFS(k)%field_name (1:nseg, ngeoval)=', PLFS(k)%field_name (1:nseg,1) !! enddo !!enddo !!write(6,*) 'nlist=', nlist @@ -5455,52 +5482,56 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) if (contLine) then if (adjustl(line) == '::') contLine = .false. end if - if ( index(line, trim(string)//'ObsPlatforms:') > 0 ) then + if ( index(adjustl(line), trim(string)//'ObsPlatforms:') == 1 ) then obs_flag =.true. line2 = line + write(6,*) 'first line for ObsPlatforms:=', trim(line) + endif end do 1236 continue if (obs_flag) then - ! __ write common nc_index,time,lon,lat - k=1 ! plat form # 1 - write(unitw, '(2(2x,a))') trim(string)//'nc_Index: ', trim(adjustl(PLFS(k)%nc_index)) - write(unitw, '(2(2x,a))') trim(string)//'nc_Time: ', trim(adjustl(PLFS(k)%nc_time)) - write(unitw, '(2(2x,a))') trim(string)//'nc_Longitude:', trim(adjustl(PLFS(k)%nc_lon)) - write(unitw, '(2(2x,a))') trim(string)//'nc_Latitude: ', trim(adjustl(PLFS(k)%nc_lat)) - write(unitw, '(/)') - - length_mx = ESMF_MAXSTR - mxseg = 100 allocate (str_piece(mxseg)) i = index(line2, ':') line = adjustl ( line2(i+1:) ) + write(6,*) 'line for obsplatforms=', trim(line) call split_string_by_space (line, length_mx, mxseg, & - nplatform, str_piece, status) -! write(6,*) 'nplatform=', nplatform -! write(6,*) 'str_piece=', str_piece(1:nplatform) -! do j=1, nplf -! write(6,*) 'PLFS(j)%name=', trim( PLFS(j)%name ) -! enddo + nplatform, str_piece, status) + + + write(6,*) 'split string, nplatform=', nplatform + write(6,*) 'nplf=', nplf + !!write(6,*) 'str_piece=', str_piece(1:nplatform) + !!do j=1, nplf + !! write(6,*) 'PLFS(j)%name=', trim( PLFS(j)%name ) + !!enddo + ! ! a) union the platform ! - ! ! find the index for each str_piece map(:) = -1 - do i=1, nplatform ! loc collection + do i=1, nplatform ! for loc collection do j=1, nplf ! tot if ( trim(str_piece(i)) == trim( PLFS(j)%name ) ) then map(i)=j + exit end if end do end do deallocate(str_piece) + !! write(6,*) 'collection n=',n, 'map(:)=', map(:) + + ! __ write common nc_index,time,lon,lat + k=map(1) ! plat form # 1 + write(unitw, '(2(2x,a))') trim(string)//'index_name_x: ', trim(adjustl(PLFS(k)%index_name_x)) + write(unitw, '(2(2x,a))') trim(string)//'var_name_time: ', trim(adjustl(PLFS(k)%var_name_time)) + write(unitw, '(2(2x,a))') trim(string)//'var_name_lon: ', trim(adjustl(PLFS(k)%var_name_lon)) + write(unitw, '(2(2x,a))') trim(string)//'var_name_lat: ', trim(adjustl(PLFS(k)%var_name_lat)) - !!write(6,*) 'map(:)=', map(:) do i=1, nplatform k=map(i) if (i==1) then @@ -5520,13 +5551,16 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) if (j==1) then write(unitw, '(10(2x,a))') trim(string)//'fields:', trim(line) else - write(unitw, '(12x,a)') trim(line) + write(unitw, '(12x,a)') trim(line) end if end do write(unitw,'(a,/)') '::' - write(unitw,'(a)') 'geovals.obs_files: # table start from next line' + write(unitw,'(a)') trim(string)//'obs_files: # table start from next line' + - do k=1, nplatform + write(6,*) 'nplatform', nplatform + do i2=1, nplatform + k=map(i2) write(unitw, '(a)') trim(adjustl(PLFS(k)%file_name_template)) do j=1, PLFS(k)%ngeoval line='' @@ -5543,7 +5577,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) end do call free_file(unitr, _RC) + _RETURN(ESMF_SUCCESS) end subroutine regen_rcx_for_obs_platform - + end module MAPL_HistoryGridCompMod diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 34aa412ef6c1..7e339282c866 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -40,16 +40,21 @@ module HistoryTrajectoryMod type(ESMF_Clock) :: clock type(ESMF_Alarm), public :: alarm type(ESMF_Time) :: RingTime - type(ESMF_TimeInterval) :: epoch_frequency + type(ESMF_TimeInterval), public :: epoch_frequency integer :: nobs_type - character(len=ESMF_MAXSTR) :: nc_index - character(len=ESMF_MAXSTR) :: nc_time - character(len=ESMF_MAXSTR) :: nc_latitude - character(len=ESMF_MAXSTR) :: nc_longitude +! character(len=ESMF_MAXSTR) :: nc_index +! character(len=ESMF_MAXSTR) :: nc_time +! character(len=ESMF_MAXSTR) :: nc_latitude +! character(len=ESMF_MAXSTR) :: nc_longitude + + character(len=ESMF_MAXSTR) :: index_name_x character(len=ESMF_MAXSTR) :: var_name_time character(len=ESMF_MAXSTR) :: var_name_lat character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_time_full + character(len=ESMF_MAXSTR) :: var_name_lat_full + character(len=ESMF_MAXSTR) :: var_name_lon_full character(len=ESMF_MAXSTR) :: datetime_units integer :: epoch ! unit: second integer(kind=ESMF_KIND_I8) :: epoch_index(2) @@ -61,7 +66,7 @@ module HistoryTrajectoryMod type(ESMF_TimeInterval) :: obsfile_interval integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index - logical :: is_valid + logical :: active contains procedure :: initialize procedure :: create_variable => create_metadata_variable diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index 1f13c1b6a3d0..c7126111330c 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -38,8 +38,8 @@ character(len=ESMF_MAXSTR) :: symd, shms integer :: nline, col integer, allocatable :: ncol(:) - character(len=ESMF_MAXSTR), allocatable :: word(:) - integer :: nobs, head, jvar + character(len=ESMF_MAXSTR), allocatable :: word(:) + integer :: nobs, head, jvar logical :: tend integer :: i, j, k, M integer :: count @@ -58,15 +58,14 @@ traj%alarm = ESMF_AlarmCreate( clock=clock, RingInterval=epoch_frequency, & RingTime=traj%RingTime, sticky=.false., _RC ) - call ESMF_ConfigGetAttribute(config, value=traj%nc_index, default="", & - label=trim(string) // 'nc_Index:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%nc_time, default="", & - label=trim(string) // 'nc_Time:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%nc_longitude, default="", & - label=trim(string) // 'nc_Longitude:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%nc_latitude, default="", & - label=trim(string) // 'nc_Latitude:', _RC) - + call ESMF_ConfigGetAttribute(config, value=traj%index_name_x, default="", & + label=trim(string) // 'index_name_x:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_lon_full, default="", & + label=trim(string) // 'var_name_lon:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_lat_full, default="", & + label=trim(string) // 'var_name_lat:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_time_full, default="", & + label=trim(string) // 'var_name_time:', _RC) call ESMF_ConfigGetAttribute(config, value=STR1, default="", & label=trim(string) // 'obs_file_begin:', _RC) @@ -114,7 +113,7 @@ shms=trim(STR1) endif call convert_twostring_2_esmfinterval (symd, shms, traj%obsfile_interval, _RC) - traj%is_valid = .true. + traj%active = .true. ! __ s1. overall print @@ -130,7 +129,7 @@ !!write(6,*) 'line', i, 'ncol(i)', ncol(i) enddo - + ! __ s2. find nobs && distinguish design with vs wo '------' nobs=0 call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) @@ -141,11 +140,12 @@ enddo ! __ s3. retrieve template and geoval, set metadata file_handle - lgr => logging%get_logger('HISTORY.sampler') + lgr => logging%get_logger('HISTORY.sampler') if ( nobs == 0 ) then ! ! treatment-1: ! + _FAIL('this setting in HISTORY.rc obs_files: is not supported, stop') traj%nobs_type = nline ! here .rc format cannot have empty spaces allocate (traj%obs(nline)) call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) @@ -160,13 +160,12 @@ ! treatment-2: ! traj%nobs_type = nobs - allocate (traj%obs(nobs)) + allocate (traj%obs(nobs)) ! nobs=0 ! reuse counter head=1 jvar=0 - ! ! count '------' in history.rc as special markers for ngeoval ! @@ -187,9 +186,9 @@ ! 1-item case: file template or one-var ! 2-item : var1 , 'root' case STR1=trim(word(1)) - else - ! 3-item : var1 , 'root', var1_alias case - STR1=trim(word(M)) + else + ! 3-item : var1 , 'root', var1_alias case + STR1=trim(word(M)) end if deallocate(word) if ( index(trim(STR1), '-----') == 0 ) then @@ -218,7 +217,7 @@ allocate (traj%obs(k)%file_handle) end if end do - + call lgr%debug('%a %i8', 'nobs_type=', traj%nobs_type) do i=1, traj%nobs_type call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & @@ -228,14 +227,14 @@ _ASSERT(j>0, '% is not found, template is wrong') traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) end do - + _RETURN(_SUCCESS) 105 format (1x,a,2x,a) 106 format (1x,a,2x,i8) end procedure HistoryTrajectory_from_config - + ! !-- integrate both initialize and reinitialize ! @@ -251,7 +250,7 @@ if (.not. present(reinitialize)) then if(present(bundle)) this%bundle=bundle if(present(items)) this%items=items - if(present(timeInfo)) this%time_info=timeInfo + if(present(timeInfo)) this%time_info=timeInfo if (present(vdata)) then this%vdata=vdata else @@ -267,7 +266,7 @@ end do end if end if - + do k=1, this%nobs_type call this%vdata%append_vertical_metadata(this%obs(k)%metadata,this%bundle,_RC) end do @@ -278,7 +277,7 @@ call get_obsfile_Tbracket_from_epoch(currTime, & this%obsfile_start_time, this%obsfile_end_time, & this%obsfile_interval, this%epoch_frequency, & - this%obsfile_Ts_index, this%obsfile_Te_index, _RC) + this%obsfile_Ts_index, this%obsfile_Te_index, _RC) if (this%obsfile_Te_index < 0) then if (mapl_am_I_root()) then write(6,*) "model start time is earlier than obsfile_start_time" @@ -295,22 +294,22 @@ do k=1, this%nobs_type - call this%obs(k)%metadata%add_dimension(this%nc_index, this%obs(k)%nobs_epoch) + call this%obs(k)%metadata%add_dimension(this%index_name_x, this%obs(k)%nobs_epoch) if (this%time_info%integer_time) then - v = Variable(type=PFIO_INT32,dimensions=this%nc_index) + v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) else - v = Variable(type=PFIO_REAL32,dimensions=this%nc_index) + v = Variable(type=PFIO_REAL32,dimensions=this%index_name_x) end if call v%add_attribute('units', this%datetime_units) call v%add_attribute('long_name', 'dateTime') call this%obs(k)%metadata%add_variable(this%var_name_time,v) - v = variable(type=PFIO_REAL64,dimensions=this%nc_index) + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) call v%add_attribute('units','degrees_east') call v%add_attribute('long_name','longitude') call this%obs(k)%metadata%add_variable(this%var_name_lon,v) - v = variable(type=PFIO_REAL64,dimensions=this%nc_index) + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) call v%add_attribute('units','degrees_north') call v%add_attribute('long_name','latitude') call this%obs(k)%metadata%add_variable(this%var_name_lat,v) @@ -358,9 +357,9 @@ units = 'unknown' endif if (field_rank==2) then - vdims = this%nc_index + vdims = this%index_name_x else if (field_rank==3) then - vdims = trim(this%nc_index)//",lev" + vdims = trim(this%index_name_x)//",lev" end if v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) call v%add_attribute('units',trim(units)) @@ -409,7 +408,7 @@ end if call MAPL_FieldBundleAdd(new_bundle,dst_field,_RC) else if (item%itemType == ItemTypeVector) then - _FAIL("ItemTypeVector not yet supported") +!! _FAIL("ItemTypeVector not yet supported") end if call iter%next() enddo @@ -419,24 +418,33 @@ module procedure create_file_handle + use pflogger, only : Logger, logging integer :: status integer :: k character(len=ESMF_MAXSTR) :: filename + type(Logger), pointer :: lgr - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + lgr => logging%get_logger('HISTORY.sampler') do k=1, this%nobs_type - call this%obs(k)%metadata%modify_dimension(this%nc_index, this%obs(k)%nobs_epoch) + call this%obs(k)%metadata%modify_dimension(this%index_name_x, this%obs(k)%nobs_epoch) enddo if (mapl_am_I_root()) then do k=1, this%nobs_type if (this%obs(k)%nobs_epoch > 0) then filename=trim(this%obs(k)%name)//trim(filename_suffix) + call lgr%debug('%a %a', & + "Sampling to new file : ",trim(filename)) call this%obs(k)%file_handle%create(trim(filename),_RC) call this%obs(k)%file_handle%write(this%obs(k)%metadata,_RC) - write(6,*) "Sampling to new file : ",trim(filename) end if enddo end if @@ -449,10 +457,15 @@ integer :: status integer :: k - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + if (mapl_am_I_root()) then do k=1, this%nobs_type if (this%obs(k)%nobs_epoch > 0) then @@ -475,6 +488,7 @@ character(len=ESMF_MAXSTR) :: grp_name character(len=ESMF_MAXSTR) :: timeunits_file + character :: new_char(ESMF_MAXSTR) real(kind=REAL64), allocatable :: lons_full(:), lats_full(:) real(kind=REAL64), allocatable :: times_R8_full(:) @@ -489,7 +503,7 @@ type(ESMF_VM) :: vm integer :: mypet, petcount - integer :: i, j, k, L + integer :: i, j, k, L, ii, jj integer :: fid_s, fid_e integer(kind=ESMF_KIND_I8) :: j0, j1 integer(kind=ESMF_KIND_I8) :: jt1, jt2 @@ -500,117 +514,182 @@ integer :: sec integer, allocatable :: ix(:) ! counter for each obs(k)%nobs_epoch integer :: nx2 + logical :: EX ! file + logical :: zero_obs - - this%datetime_units = "seconds since 1970-01-01 00:00:00" +!! this%datetime_units = "seconds since 1970-01-01 00:00:00" lgr => logging%get_logger('HISTORY.sampler') call ESMF_VMGetGlobal(vm,_RC) call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) - if (this%nc_index == '') then + if (this%index_name_x == '') then ! - !-- non IODA case + !-- non IODA case / non netCDF ! _FAIL('non-IODA format is not implemented here') + end if + + ! + !-- IODA case + ! + i=index(this%var_name_lon_full, '/') + if (i==0) then + grp_name = '' + call lgr%debug('%a', 'grp_name not found') else - ! - !-- IODA case - ! - i=index(this%nc_longitude, '/') - _ASSERT (i>0, 'group name not found') - grp_name = this%nc_longitude(1:i-1) - this%var_name_lon = this%nc_longitude(i+1:) - i=index(this%nc_latitude, '/') - this%var_name_lat = this%nc_latitude(i+1:) - i=index(this%nc_time, '/') - this%var_name_time= this%nc_time(i+1:) - - call lgr%debug('%a', 'grp_name,this%var_name_lat,this%var_name_lon,this%var_name_time') - call lgr%debug('%a %a %a %a', & - trim(grp_name),trim(this%var_name_lat),trim(this%var_name_lon),trim(this%var_name_time)) - - L=0 - fid_s=this%obsfile_Ts_index - fid_e=this%obsfile_Te_index - if(fid_e < L) then - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - this%epoch_index(1:2) = 0 - this%nobs_epoch = 0 - rc = 0 - return - end if + grp_name = this%var_name_lon_full(1:i-1) + end if + this%var_name_lon = this%var_name_lon_full(i+1:) + i=index(this%var_name_lat_full, '/') + this%var_name_lat = this%var_name_lat_full(i+1:) + i=index(this%var_name_time_full, '/') + this%var_name_time= this%var_name_time_full(i+1:) - if (mapl_am_I_root()) then - len = 0 - do k=1, this%nobs_type - j = max (fid_s, L) - do while (j<=fid_e) - filename = get_filename_from_template_use_index( & - this%obsfile_start_time, this%obsfile_interval, & - j, this%obs(k)%input_template, _RC) - if (filename /= '') then - call lgr%debug('%a %a', 'true filename: ', trim(filename)) - call get_ncfile_dimension(filename, tdim=num_times, key_time=this%nc_index, _RC) - len = len + num_times - end if - j=j+1 - enddo + call lgr%debug('%a', 'grp_name,this%index_name_x,this%var_name_lon,this%var_name_lat,this%var_name_time') + call lgr%debug('%a %a %a %a %a', & + trim(grp_name),trim(this%index_name_x),trim(this%var_name_lon),& + trim(this%var_name_lat),trim(this%var_name_time)) + + L=0 + fid_s=this%obsfile_Ts_index + fid_e=this%obsfile_Te_index + + call lgr%debug('%a %i10 %i10', & + 'fid_s, fid_e', fid_s, fid_e) + + arr(1)=0 ! len_full + if (mapl_am_I_root()) then + len = 0 + do k=1, this%nobs_type + j = max (fid_s, L) + do while (j<=fid_e) + filename = get_filename_from_template_use_index( & + this%obsfile_start_time, this%obsfile_interval, & + j, this%obs(k)%input_template, EX, _RC) + if (EX) then + call lgr%debug('%a %i10', 'exist: filename fid j :', j) + call lgr%debug('%a %a', 'exist: true filename :', trim(filename)) + call get_ncfile_dimension(filename, tdim=num_times, key_time=this%index_name_x, _RC) + len = len + num_times + else + call lgr%debug('%a %i10', 'non-exist: filename fid j :', j) + call lgr%debug('%a %a', 'non-exist: missing filename:', trim(filename)) + end if + j=j+1 enddo - len_full = len + enddo + arr(1)=len + + if (len>0) then allocate(lons_full(len),lats_full(len),_STAT) allocate(times_R8_full(len),_STAT) allocate(obstype_id_full(len),_STAT) - call lgr%debug('%a %i12', 'nobs from input file:', len_full) - + call lgr%debug('%a %i12', 'nobs from input file:', len) len = 0 + ii = 0 do k=1, this%nobs_type j = max (fid_s, L) do while (j<=fid_e) filename = get_filename_from_template_use_index( & this%obsfile_start_time, this%obsfile_interval, & - j, this%obs(k)%input_template, _RC) - if (filename /= '') then - call get_ncfile_dimension(trim(filename), tdim=num_times, key_time=this%nc_index, _RC) + j, this%obs(k)%input_template, EX, _RC) + if (EX) then + ii = ii + 1 + call get_ncfile_dimension(trim(filename), tdim=num_times, key_time=this%index_name_x, _RC) call get_v1d_netcdf_R8 (filename, this%var_name_lon, lons_full(len+1:), num_times, group_name=grp_name) call get_v1d_netcdf_R8 (filename, this%var_name_lat, lats_full(len+1:), num_times, group_name=grp_name) call get_v1d_netcdf_R8 (filename, this%var_name_time, times_R8_full(len+1:), num_times, group_name=grp_name) - call get_attribute_from_group (filename, grp_name, this%var_name_time, "units", timeunits_file) + if (ii == 1) then + this%datetime_units = trim(timeunits_file) + call lgr%debug('%a %a', 'datetime_units from 1st file:', trim(timeunits_file)) + end if obstype_id_full(len+1:len+num_times) = k - call lgr%debug('%a %f25.12, %f25.12', 'times_R8_full(1:200:100)', & - times_R8_full(1), times_R8_full(200)) - + !!write(6,'(f12.2)') times_R8_full(::50) len = len + num_times end if j=j+1 enddo enddo end if + end if + + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (nx_sum == 0) then + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + this%epoch_index(1:2) = 0 + this%nobs_epoch = 0 + this%nobs_epoch_sum = 0 + ! + ! empty shell to keep regridding and destroy_RH_LS to work + ! + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) + this%LS_rt = this%locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) + call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) + this%obsTime= -1.d0 + call lgr%debug('%a %i5', 'nobservation points=', nx_sum) + rc = 0 + return + end if + call MAPL_CommsBcast(vm, this%datetime_units, N=ESMF_MAXSTR, ROOT=MAPL_Root, _RC) - if (mapl_am_I_root()) then - call sort_multi_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) - call ESMF_ClockGet(this%clock,currTime=current_time,_RC) - timeset(1) = current_time - timeset(2) = current_time + this%epoch_frequency - call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) - sec = hms_2_s(this%Epoch) - j1 = j0 + int(sec, kind=ESMF_KIND_I8) - jx0 = real ( j0, kind=ESMF_KIND_R8) - jx1 = real ( j1, kind=ESMF_KIND_R8) - - nstart=1; nend=size(times_R8_full) - call bisect( times_R8_full, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) - call bisect( times_R8_full, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) - if (jt1==jt2) then - _FAIL('Epoch Time is too small, empty swath grid is generated, increase Epoch') - endif - call lgr%debug ('%a %f20.1 %f20.1', 'jx0, jx1', jx0, jx1) - call lgr%debug ('%a %i20 %i20', 'jt1, jt2', jt1, jt2) + if (mapl_am_I_root()) then + call sort_multi_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) + call ESMF_ClockGet(this%clock,currTime=current_time,_RC) + timeset(1) = current_time + timeset(2) = current_time + this%epoch_frequency + call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) + sec = hms_2_s(this%Epoch) + j1 = j0 + int(sec, kind=ESMF_KIND_I8) + jx0 = real ( j0, kind=ESMF_KIND_R8) + jx1 = real ( j1, kind=ESMF_KIND_R8) + + nstart=1; nend=size(times_R8_full) + call bisect( times_R8_full, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call bisect( times_R8_full, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) + call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) + call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & + times_R8_full(1), times_R8_full(nend)) + call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) + + +! if (jt1==jt2) then +! _FAIL('Epoch Time is too small, empty grid is generated, increase Epoch') +! endif + + !-- shift the zero item to index 1 + zero_obs = .false. + if (jt1/=jt2) then + zero_obs = .false. + if (jt1==0) jt1=1 + else + ! at most one obs point exist, set it .true. + zero_obs = .true. + !! if (jt1==0) jt1=1 + end if + + ! + !-- exclude the out-of-range case + ! + if ( zero_obs ) then + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + this%epoch_index(1:2)=0 + this%nobs_epoch = 0 + nx=0 + arr(1)=nx + else ! (x1, x2] design in bisect if (jt1==0) then this%epoch_index(1)= 1 @@ -626,6 +705,8 @@ nx= this%epoch_index(2) - this%epoch_index(1) + 1 this%nobs_epoch = nx + + allocate(this%lons(nx),this%lats(nx),_STAT) allocate(this%times_R8(nx),_STAT) allocate(this%obstype_id(nx),_STAT) @@ -679,47 +760,46 @@ call lgr%debug('%a %i4 %a %i12', & 'obs(', k, ')%nobs_epoch', this%obs(k)%nobs_epoch ) enddo + end if + else + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + this%epoch_index(1:2)=0 + this%nobs_epoch = 0 + nx=0 + arr(1)=nx + endif - else - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - this%epoch_index(1:2)=0 - this%nobs_epoch = 0 - nx=0 - arr(1)=nx - endif - - call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & - count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) - this%nobs_epoch_sum = nx_sum - if (mapl_am_I_root()) write(6,*) 'nobs in Epoch :', nx_sum + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + this%nobs_epoch_sum = nx_sum + if (mapl_am_I_root()) write(6,'(2x,a,2x,i15)') 'nobs in Epoch :', nx_sum - this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) - this%LS_rt = this%locstream_factory%create_locstream(_RC) - call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) + this%LS_rt = this%locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) - this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) - this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) + this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) + this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) - call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) - call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) - if (mypet == 0) then - ptAT(:) = this%times_R8(:) - end if - this%obsTime= -1.d0 + call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) + call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) + if (mypet == 0) then + ptAT(:) = this%times_R8(:) + end if + this%obsTime= -1.d0 - call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) - call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) + call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) + call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) - !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) + !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) - ! defer destroy fieldB at regen_grid step - ! - end if + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) + ! defer destroy fieldB at regen_grid step + ! _RETURN(_SUCCESS) @@ -746,7 +826,7 @@ integer :: j, k, ig integer, allocatable :: ix(:) - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif @@ -835,6 +915,9 @@ enddo endif enddo + do k=1, this%nobs_type + deallocate (this%obs(k)%p2d) + enddo end if else if (rank==2) then call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) @@ -878,7 +961,7 @@ nx = this%obs(k)%nobs_epoch if (nx>0) then do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then + if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) end if @@ -889,6 +972,10 @@ !!write(6,*) 'here in append_file: put_var 3d' !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + !! + do k=1, this%nobs_type + deallocate (this%obs(k)%p3d) + enddo end if endif else if (item%itemType == ItemTypeVector) then @@ -919,10 +1006,18 @@ real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - integer :: is, ie + type(ESMF_VM) :: vm + integer :: mypet, petcount + integer :: is, ie, nx_sum integer :: status + integer :: arr(1) + + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif - if (.NOT. this%is_valid) then + if (this%nobs_epoch_sum==0) then _RETURN(ESMF_SUCCESS) endif @@ -933,6 +1028,27 @@ call this%get_x_subset(timeset, x_subset, _RC) is=x_subset(1) ie=x_subset(2) + !! write(6,'(2x,a,4i10)') 'in regrid_accumulate is, ie=', is, ie + + + ! + ! __ I designed a method to return from regridding if no valid points exist + ! in reality for 29 jedi platforms and dt > 20 sec, we donot need this + ! + !!arr(1)=1 + !!if (.NOT. (is > 0 .AND. is <= ie )) arr(1)=0 + !!call ESMF_VMGetGlobal(vm,_RC) + !!call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) + !!call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + !! count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + !!if ( nx_sum == 0 ) then + !! write(6, '(2x,a,2x,3i10)') 'invalid points, mypet, is, ie =', mypet, is, ie + !! ! no valid points to regrid + !! _RETURN(ESMF_SUCCESS) + !!else + !! write(6, '(2x,a,2x,3i10)') ' valid points, mypet, is, ie =', mypet, is, ie + !!end if + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then call this%vdata%setup_eta_to_pressure(_RC) @@ -996,7 +1112,7 @@ type(ESMF_Field) :: field type(ESMF_Time) :: currTime - if (.NOT. this%is_valid) then + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif @@ -1016,9 +1132,15 @@ if (mapl_am_i_root()) then do k=1, this%nobs_type - deallocate (this%obs(k)%lons) - deallocate (this%obs(k)%lats) - deallocate (this%obs(k)%times_R8) + if (allocated (this%obs(k)%lons)) then + deallocate (this%obs(k)%lons) + end if + if (allocated (this%obs(k)%lats)) then + deallocate (this%obs(k)%lats) + end if + if (allocated (this%obs(k)%times_R8)) then + deallocate (this%obs(k)%times_R8) + end if if (allocated(this%obs(k)%p2d)) then deallocate (this%obs(k)%p2d) endif @@ -1049,7 +1171,7 @@ call ESMF_ClockGet ( this%clock, CurrTime=currTime, _RC ) if (currTime > this%obsfile_end_time) then - this%is_valid = .false. + this%active = .false. _RETURN(ESMF_SUCCESS) end if @@ -1067,7 +1189,7 @@ real (ESMF_KIND_R8) :: rT1, rT2 integer(ESMF_KIND_I8) :: i1, i2 - integer(ESMF_KIND_I8) :: jt1, jt2, lb, ub + integer(ESMF_KIND_I8) :: index1, index2, lb, ub integer :: jlo, jhi integer :: status @@ -1078,7 +1200,9 @@ rT1=real(i1, kind=ESMF_KIND_R8) rT2=real(i2, kind=ESMF_KIND_R8) jlo = 1 - jhi= size(this%obstime) + !! + !! I choose UB = N+1 not N, because my sub. bisect find n: Y(n)=ub) then - x_subset(1) = lb - x_subset(2) = ub - else - x_subset(1) = lb - x_subset(2) = jt2 - endif - elseif (jt1>=ub) then - x_subset(1) = 0 - x_subset(2) = 0 - else - x_subset(1) = jt1 - if (jt2>=ub) then - x_subset(2) = ub - else - x_subset(2) = jt2 - endif - endif - + call bisect( this%obstime, rT1, index1, n_LB=lb, n_UB=ub, rc=rc) + call bisect( this%obstime, rT2, index2, n_LB=lb, n_UB=ub, rc=rc) + + ! (x1, x2] design in bisect + ! simple version + + x_subset(1) = index1+1 + x_subset(2) = index2 + +! if (index1=ub) then +! x_subset(2) = ub +! else +! x_subset(2) = index2 +! endif +! elseif (index1>=ub) then +! x_subset(1) = 0 +! x_subset(2) = 0 +! else +! x_subset(2) = index2 +! endif +! +!! write(6,'(2x,a,2x,2i10)') 'mod vers. get_x_subset, LB,UB=', x_subset(1:2) _RETURN(_SUCCESS) end procedure get_x_subset From 91453cf617d7478dc6ea3105f84944d797585ddc Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 11 Jan 2024 23:06:37 -0700 Subject: [PATCH 28/86] Add procedure MAPL_BcastShared_2DR8 to MAPL_Comms.F90 --- base/MAPL_Comms.F90 | 34 ++++ base/MAPL_ObsUtil.F90 | 10 +- base/MAPL_SwathGridFactory.F90 | 319 +++++++++++++++------------------ 3 files changed, 179 insertions(+), 184 deletions(-) diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 078a0a8a2c1c..a0684d51f9bb 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -116,6 +116,7 @@ module MAPL_CommsMod interface MAPL_BcastShared module procedure MAPL_BcastShared_1DR4 module procedure MAPL_BcastShared_2DR4 + module procedure MAPL_BcastShared_2DR8 end interface interface MAPL_CommsScatterV @@ -1117,6 +1118,39 @@ subroutine MAPL_BcastShared_2DR4(VM, Data, N, Root, RootOnly, rc) end subroutine MAPL_BcastShared_2DR4 + + subroutine MAPL_BcastShared_2DR8(VM, Data, N, Root, RootOnly, rc) + type(ESMF_VM) :: VM + real(kind=REAL64), pointer, intent(INOUT) :: Data(:,:) + integer, intent(IN ) :: N + integer, optional, intent(IN ) :: Root + logical, intent(IN ) :: RootOnly + integer, optional, intent( OUT) :: rc + + + integer :: status + + + + if(.not.MAPL_ShmInitialized) then + if (RootOnly) then + _RETURN(ESMF_SUCCESS) + end if + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, RC=status) + _RETURN(STATUS) + else + call MAPL_SyncSharedMemory(RC=STATUS) + _VERIFY(STATUS) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, rc=status) + _VERIFY(STATUS) + call MAPL_SyncSharedMemory(RC=STATUS) + _VERIFY(STATUS) + endif + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_BcastShared_2DR8 + ! Rank 0 !--------------------------- #define RANK_ 0 diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 8901c159f6c7..ba81b21584c1 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -297,13 +297,10 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_lon character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_lat character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_time - - real, allocatable, optional, intent(inout) :: lon(:,:) - real, allocatable, optional, intent(inout) :: lat(:,:) - !! real(ESMF_KIND_R8), optional, intent(inout) :: time_R8(:,:) - real, allocatable, optional, intent(inout) :: time(:,:) + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: lon(:,:) + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: lat(:,:) + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: time(:,:) logical, optional, intent(in) :: Tfilter - integer, optional, intent(out) :: rc integer :: M @@ -395,7 +392,6 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & ! - ! ! -- determine true time/lon/lat by filtering T < 0 ! diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index d92cd27fafb4..2c4ff94af8d6 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -222,11 +222,11 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) integer :: status real(kind=ESMF_KIND_R8), pointer :: fptr(:,:) - real, pointer :: centers(:,:) - real, allocatable :: lon_true(:,:) - real, allocatable :: lat_true(:,:) - real, allocatable :: time_true(:,:) - real(kind=ESMF_KIND_R8), allocatable :: X1d(:) + real(kind=ESMF_KIND_R8), allocatable :: lon_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: lat_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: time_true(:,:) + real(kind=ESMF_KIND_R8), pointer :: arr_lon(:,:) + real(kind=ESMF_KIND_R8), pointer :: arr_lat(:,:) integer :: i, j, k integer :: Xdim, Ydim @@ -242,33 +242,78 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! debug type(ESMF_VM) :: vm integer :: mypet, petcount - - integer :: rank0 - integer :: src, dst integer :: nsize, count - integer :: nshared_pet - real, allocatable :: arr(:,:), arr_lon(:,:), arr_lat(:,:) - - integer, allocatable:: array1(:), array2(:), array3(:) + integer :: mpic _UNUSED_DUMMY(unusable) - call ESMF_VMGetGlobal(vm,_RC) - call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) - + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) + Xdim=this%im_world Ydim=this%jm_world - Xdim_full=this%cell_across_swath - Ydim_full=this%cell_along_swath - + count = Xdim * Ydim + call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) - call MAPL_SyncSharedMemory(_RC) - call MAPL_AllocateShared(arr_lon,[Xdim,Ydim],transroot=.true.,_RC) call MAPL_AllocateShared(arr_lat,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_SyncSharedMemory(_RC) + + if (mapl_am_i_root()) then + allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) + call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & + this%index_name_lon, this%index_name_lat, & + var_name_lon=this%var_name_lon, & + var_name_lat=this%var_name_lat, & + var_name_time=this%var_name_time, & + lon=lon_true, lat=lat_true, time=time_true, & + Tfilter=.true., _RC) + k=0 + do j=this%epoch_index(3), this%epoch_index(4) + k=k+1 + arr_lon(1:Xdim, k) = lon_true(1:Xdim, j) + arr_lat(1:Xdim, k) = lat_true(1:Xdim, j) + enddo + arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 + arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 + deallocate( lon_true, lat_true, time_true ) + + write(6,*) 'in root' + write(6,'(11x,100f10.1)') arr_lon(::5,189) + end if + call MPI_Barrier(mpic, status) + call MAPL_SyncSharedMemory(_RC) + + call MAPL_BcastShared (VM, data=arr_lon, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (VM, data=arr_lat, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + +! call MAPL_BroadcastToNodes (arr_lon, count, MAPL_ROOT, _RC) +! call MAPL_SyncSharedMemory(_RC) +! call MAPL_BroadcastToNodes (arr_lat, count, MAPL_ROOT, _RC) +! call MAPL_SyncSharedMemory(_RC) + + write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) + call MPI_Barrier(mpic, status) + + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) + fptr=real(arr_lon(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) + call MAPL_SyncSharedMemory(_RC) + + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=fptr, rc=status) + fptr=real(arr_lat(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) + + if(MAPL_ShmInitialized) then + call MAPL_DeAllocNodeArray(arr_lon,_RC) + call MAPL_DeAllocNodeArray(arr_lat,_RC) + else + deallocate(arr_lon) + deallocate(arr_lat) + end if -!! mmapl_am_I_root() is element in set (rootscomm) ! if (mapl_am_I_root()) then ! write(6,'(2x,a,10i8)') & ! 'ck: Xdim, Ydim, Xdim_full, Ydim_full', Xdim, Ydim, Xdim_full, Ydim_full @@ -276,138 +321,13 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! 'ck: i_1, i_n, j_1, j_n', i_1, i_n, j_1, j_n ! end if - ! - ! array3(1:nshared_pet) is the pet for shared headnode excluding mapl_am_i_root() - ! s1. read NC from root/rank0 - ! s2. MPI send and recv true_lon / true_lat via X1d - ! s3. pass X1d to Shmem [centers] - ! - - nsize = petCount - allocate (array1(nsize)) - allocate (array2(nsize)) - - array1(:) = 0 - src = 0 - dst = 0 - - if (mapl_am_i_root()) then - rank0 = mypet - src = 1 - end if - + write(6,*) 'MAPL_AmNodeRoot, MAPL_ShmInitialized=', MAPL_AmNodeRoot, MAPL_ShmInitialized if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - if (mypet/=rank0) then - array1(mypet+1) = mypet+1 ! raise index to [1, N] - dst = 1 - end if - end if - - call ESMF_VMAllReduce(vm, sendData=array1, recvData=array2, count=nsize, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - write(6, '(2x,a,2x,i5,2x,a,2x,10i10)') 'mypet, array2', mypet, ':', array2 - - j=0 - do i=1, nsize - if ( array2(i) > 0 ) then - j=j+1 - end if - end do - allocate (array3(j)) - nshared_pet = j - - j=0 - do i=1, nsize - if ( array2(i) > 0 ) then - j=j+1 - array3(j) = array2(i) - 1 ! downshift value to mypet - end if - end do - - if (src==1 .OR. dst==1) then - allocate( arr_lon(Xdim, Ydim) ) - allocate( arr_lat(Xdim, Ydim) ) - allocate( X1d( Xdim * Ydim ) ) - allocate( Y1d( Xdim * Ydim ) ) + write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet end if - - if (mypet==rank0) then - allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) - call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & - this%index_name_lon, this%index_name_lat, & - var_name_lon=this%var_name_lon, & - var_name_lat=this%var_name_lat, & - var_name_time=this%var_name_time, & - lon=lon_true, lat=lat_true, time=time_true, & - Tfilter=.true., _RC) - k=0 - do j=this%epoch_index(3), this%epoch_index(4) - k=k+1 - arr_lon(1:Xdim, k) = lon_true(1:Xdim, j) - arr_lat(1:Xdim, k) = lat_true(1:Xdim, j) - enddo - arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 - arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 - k=0 - do j=1, Ydim - do i=1, Xdim - X1d(k) = arr_lon(i,j) - Y1d(k) = arr_lat(i,j) - end do - end do - deallocate( lon_true, time_true ) - ! - end if - - - - if (nshared_pet > 0) then - count = Xdim * Ydim - if (src==1) then - do j=1, nshared_pet - call ESMF_VMSend(vm, sendData=X1d, count=count, dstPet=array3(j), rc=rc) - call ESMF_VMSend(vm, sendData=Y1d, count=count, dstPet=array3(j), rc=rc) - end do - end if - if (dst==1) then - call ESMF_VMRecv(vm, recvData=arr_lon, count=count, srcPet=rank0, rc=rc) - call ESMF_VMRecv(vm, recvData=arr_lat, count=count, srcPet=rank0, rc=rc) - end if - end if - - ! read longitudes - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet - centers = arr_lon - end if - - -!! mpi_barrier for each core within node - call MAPL_SyncSharedMemory(_RC) - - call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) - fptr=real(centers(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) - -!! _FAIL ('nail -1') - ! read latitudes - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - centers = arr_lat - end if - call MAPL_SyncSharedMemory(_RC) - call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, rc=status) - fptr=real(centers(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) - - if(MAPL_ShmInitialized) then - call MAPL_DeAllocNodeArray(centers,_RC) - else - deallocate(centers) - end if - _RETURN(_SUCCESS) + end subroutine add_horz_coordinates_from_file @@ -526,10 +446,9 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc character(len=ESMF_MAXSTR) :: filename, STR1, tmp character(len=ESMF_MAXSTR) :: symd, shms - ! real(ESMF_KIND_R8), allocatable :: scanTime(:,:) - real, allocatable :: scanTime(:,:) - real, allocatable :: lon_true(:,:) - real, allocatable :: lat_true(:,:) + real(ESMF_KIND_R8), allocatable :: scanTime(:,:) + real(ESMF_KIND_R8), allocatable :: lon_true(:,:) + real(ESMF_KIND_R8), allocatable :: lat_true(:,:) integer :: yy, mm, dd, h, m, s, sec, second integer :: i, j, L integer :: ncid, ncid2, varid @@ -1522,36 +1441,35 @@ subroutine get_obs_time(this, grid, obs_time, rc) integer, optional, intent(out) :: rc integer :: status - integer :: i_1, i_n, j_1, j_n ! regional array bounds - - !! shared mem real(kind=ESMF_KIND_R8), pointer :: fptr(:,:) - real, pointer :: centers(:,:) - real, allocatable :: lon_true(:,:) - real, allocatable :: lat_true(:,:) - real, allocatable :: time_true(:,:) + real(kind=ESMF_KIND_R8), pointer :: centers(:,:) + real(kind=ESMF_KIND_R8), allocatable :: lon_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: lat_true(:,:) + real(kind=ESMF_KIND_R8), allocatable :: time_true(:,:) + real(kind=ESMF_KIND_R8), pointer :: arr_time(:,:) integer :: i, j, k - integer :: Xdim, Ydim - integer :: Xdim_full, Ydim_full + integer :: Xdim, Ydim, count integer :: nx, ny - integer :: IM_WORLD, JM_WORLD + integer :: i_1, i_n, j_1, j_n ! regional array bounds + ! debug + type(ESMF_VM) :: vm + integer :: mypet, petcount + integer :: mpic - !- shared mem case in MPI - ! + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) + Xdim=this%im_world Ydim=this%jm_world - Xdim_full=this%cell_across_swath - Ydim_full=this%cell_along_swath + count=Xdim*Ydim call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_time,[Xdim,Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) - - ! read and set Time - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then + if (mapl_am_i_root()) then allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & this%index_name_lon, this%index_name_lat, & @@ -1563,21 +1481,68 @@ subroutine get_obs_time(this, grid, obs_time, rc) k=0 do j=this%epoch_index(3), this%epoch_index(4) k=k+1 - centers(1:Xdim, k) = time_true(1:Xdim, j) + arr_time(1:Xdim, k) = time_true(1:Xdim, j) enddo - deallocate (lon_true, lat_true, time_true) + deallocate( lon_true, lat_true, time_true ) + + write(6,*) 'in root, time' + write(6,'(11x,100E12.5)') arr_time(::5,189) end if call MAPL_SyncSharedMemory(_RC) + call MAPL_BcastShared (VM, data=arr_time, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + + write(6,'(2x,a,2x,i5,4x,100E12.5)') 'PET, time', mypet, arr_time(::5,189) + call MPI_Barrier(mpic, status) + !(Xdim, Ydim) - obs_time = centers(i_1:i_n,j_1:j_n) + obs_time = arr_time(i_1:i_n,j_1:j_n) if(MAPL_ShmInitialized) then - call MAPL_DeAllocNodeArray(centers,_RC) + call MAPL_DeAllocNodeArray(arr_time,_RC) else - deallocate(centers) + deallocate(arr_time) end if + +! !- shared mem case in MPI +! ! +! Xdim=this%im_world +! Ydim=this%jm_world +! +! call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) +! call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) +! call MAPL_SyncSharedMemory(_RC) +! +! ! read and set Time +! +! if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then +! allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) +! call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & +! this%index_name_lon, this%index_name_lat, & +! var_name_lon=this%var_name_lon, & +! var_name_lat=this%var_name_lat, & +! var_name_time=this%var_name_time, & +! lon=lon_true, lat=lat_true, time=time_true, & +! Tfilter=.true., _RC) +! k=0 +! do j=this%epoch_index(3), this%epoch_index(4) +! k=k+1 +! centers(1:Xdim, k) = time_true(1:Xdim, j) +! enddo +! deallocate (lon_true, lat_true, time_true) +! end if +! call MAPL_SyncSharedMemory(_RC) +! +! !(Xdim, Ydim) +! obs_time = centers(i_1:i_n,j_1:j_n) +! +! if(MAPL_ShmInitialized) then +! call MAPL_DeAllocNodeArray(centers,_RC) +! else +! deallocate(centers) +! end if + _RETURN(_SUCCESS) end subroutine get_obs_time From 628c59b21ff449d4e6323bdacb9cbb79f2e1d139 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 11 Jan 2024 23:19:41 -0700 Subject: [PATCH 29/86] incremental cleanup --- base/MAPL_SwathGridFactory.F90 | 85 +++++----------------- gridcomps/History/MAPL_HistoryGridComp.F90 | 3 - 2 files changed, 20 insertions(+), 68 deletions(-) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 2c4ff94af8d6..8cec02c76410 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -169,12 +169,11 @@ function make_new_grid(this, unusable, rc) result(grid) _UNUSED_DUMMY(unusable) - if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: bf this%create_basic_grid' + !!if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: bf this%create_basic_grid' grid = this%create_basic_grid(_RC) - if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%create_basic_grid' - + !!if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%create_basic_grid' call this%add_horz_coordinates_from_file(grid,_RC) - if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%add_horz_coordinates_from_file' + !!if (mapl_am_I_root()) write(6,*) 'MAPL_SwathGridFactory.F90: af this%add_horz_coordinates_from_file' _RETURN(_SUCCESS) end function make_new_grid @@ -247,8 +246,8 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _UNUSED_DUMMY(unusable) - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) +!! call ESMF_VMGetCurrent(vm,_RC) +!! call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) Xdim=this%im_world Ydim=this%jm_world @@ -278,22 +277,17 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 deallocate( lon_true, lat_true, time_true ) - write(6,*) 'in root' - write(6,'(11x,100f10.1)') arr_lon(::5,189) +! write(6,*) 'in root' +! write(6,'(11x,100f10.1)') arr_lon(::5,189) end if - call MPI_Barrier(mpic, status) +! call MPI_Barrier(mpic, status) call MAPL_SyncSharedMemory(_RC) call MAPL_BcastShared (VM, data=arr_lon, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) call MAPL_BcastShared (VM, data=arr_lat, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) -! call MAPL_BroadcastToNodes (arr_lon, count, MAPL_ROOT, _RC) -! call MAPL_SyncSharedMemory(_RC) -! call MAPL_BroadcastToNodes (arr_lat, count, MAPL_ROOT, _RC) -! call MAPL_SyncSharedMemory(_RC) - - write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) - call MPI_Barrier(mpic, status) +! write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) +! call MPI_Barrier(mpic, status) call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & @@ -316,15 +310,15 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! if (mapl_am_I_root()) then ! write(6,'(2x,a,10i8)') & -! 'ck: Xdim, Ydim, Xdim_full, Ydim_full', Xdim, Ydim, Xdim_full, Ydim_full +! 'ck: Xdim, Ydim', Xdim, Ydim ! write(6,'(2x,a,10i8)') & ! 'ck: i_1, i_n, j_1, j_n', i_1, i_n, j_1, j_n ! end if - write(6,*) 'MAPL_AmNodeRoot, MAPL_ShmInitialized=', MAPL_AmNodeRoot, MAPL_ShmInitialized - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet - end if +! write(6,*) 'MAPL_AmNodeRoot, MAPL_ShmInitialized=', MAPL_AmNodeRoot, MAPL_ShmInitialized +! if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then +! write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet +! end if _RETURN(_SUCCESS) @@ -1485,15 +1479,15 @@ subroutine get_obs_time(this, grid, obs_time, rc) enddo deallocate( lon_true, lat_true, time_true ) - write(6,*) 'in root, time' - write(6,'(11x,100E12.5)') arr_time(::5,189) +! write(6,*) 'in root, time' +! write(6,'(11x,100E12.5)') arr_time(::5,189) end if call MAPL_SyncSharedMemory(_RC) call MAPL_BcastShared (VM, data=arr_time, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) - write(6,'(2x,a,2x,i5,4x,100E12.5)') 'PET, time', mypet, arr_time(::5,189) - call MPI_Barrier(mpic, status) +! write(6,'(2x,a,2x,i5,4x,100E12.5)') 'PET, time', mypet, arr_time(::5,189) +! call MPI_Barrier(mpic, status) !(Xdim, Ydim) obs_time = arr_time(i_1:i_n,j_1:j_n) @@ -1502,46 +1496,7 @@ subroutine get_obs_time(this, grid, obs_time, rc) call MAPL_DeAllocNodeArray(arr_time,_RC) else deallocate(arr_time) - end if - - -! !- shared mem case in MPI -! ! -! Xdim=this%im_world -! Ydim=this%jm_world -! -! call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) -! call MAPL_AllocateShared(centers,[Xdim,Ydim],transroot=.true.,_RC) -! call MAPL_SyncSharedMemory(_RC) -! -! ! read and set Time -! -! if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then -! allocate( lon_true(0,0), lat_true(0,0), time_true(0,0) ) -! call read_M_files_4_swath (this%filenames(1:this%M_file), nx, ny, & -! this%index_name_lon, this%index_name_lat, & -! var_name_lon=this%var_name_lon, & -! var_name_lat=this%var_name_lat, & -! var_name_time=this%var_name_time, & -! lon=lon_true, lat=lat_true, time=time_true, & -! Tfilter=.true., _RC) -! k=0 -! do j=this%epoch_index(3), this%epoch_index(4) -! k=k+1 -! centers(1:Xdim, k) = time_true(1:Xdim, j) -! enddo -! deallocate (lon_true, lat_true, time_true) -! end if -! call MAPL_SyncSharedMemory(_RC) -! -! !(Xdim, Ydim) -! obs_time = centers(i_1:i_n,j_1:j_n) -! -! if(MAPL_ShmInitialized) then -! call MAPL_DeAllocNodeArray(centers,_RC) -! else -! deallocate(centers) -! end if + end if _RETURN(_SUCCESS) end subroutine get_obs_time diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index a742d8654335..9f5329b99ec5 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -631,9 +631,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if call Hsampler%config_accumulate(key, config, _RC) output_grid = Hsampler%create_grid(key, currTime, grid_type=grid_type, _RC) - if (mapl_am_i_root()) write(6,*) 'nail af Hsampler%create_grid' - - end if call IntState%output_grids%set(key, output_grid) call iter%next() From ce97de1b85a31b633ddb729405aadafe51020cac Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 12 Jan 2024 00:14:48 -0700 Subject: [PATCH 30/86] small changes in format --- CHANGELOG.md | 5 +++-- Tests/ExtDataDriverGridComp.F90 | 6 +----- base/MAPL_Comms.F90 | 4 ---- base/MAPL_SwathGridFactory.F90 | 1 - gridcomps/History/MAPL_EpochSwathMod.F90 | 2 +- 5 files changed, 5 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7f512a9e0edf..c4adc1993125 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,8 +13,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Handle regrid accumulate for time step (1 sec) during which no obs exists - Use IntState%stampoffset(n) to adjust filenames for an epoch time - parse "GOCART::CO2" from 'geovals_fields' entry in PLATFORM -- Add Shmem to ExtDataDriverGridComp.F90 -- Read swath data on root, pass to NodeRoot for Shmem, so to avoid race in reading nc files +- Add call MAPL_InitializeShmem to ExtDataDriverGridComp.F90 +- Read swath data on root, call MAPL_CommsBcast [which sends data to Shmem (when Shmem initialized) or to MAPL_comm otherwise]. This approach avoids race in reading nc files [e.g. 37 files for 3 hr swath data] + - Added memory utility, MAPL_MemReport that can be used in any code linking MAPL diff --git a/Tests/ExtDataDriverGridComp.F90 b/Tests/ExtDataDriverGridComp.F90 index c303f61be6e1..551e2eb61297 100644 --- a/Tests/ExtDataDriverGridComp.F90 +++ b/Tests/ExtDataDriverGridComp.F90 @@ -11,7 +11,7 @@ module ExtData_DriverGridCompMod use MAPL_HistoryGridCompMod, only : Hist_SetServices => SetServices use MAPL_Profiler, only : get_global_time_profiler, BaseProfiler use mpi -! use MAPL_ShmemMod + implicit none private @@ -144,10 +144,8 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) type(ExtData_DriverGridComp), pointer :: cap class(BaseProfiler), pointer :: t_p logical :: use_extdata2g - integer :: useShmem - _UNUSED_DUMMY(import_state) _UNUSED_DUMMY(export_state) _UNUSED_DUMMY(clock) @@ -171,7 +169,6 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) cap%AmIRoot = AmIRoot_ - ! Open the CAP's configuration from CAP.rc !------------------------------------------ @@ -196,7 +193,6 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) _VERIFY(status) end if - call ESMF_ConfigGetAttribute(cap%config,cap%run_fbf,label="RUN_FBF:",default=.false.) call ESMF_ConfigGetAttribute(cap%config,cap%run_hist,label="RUN_HISTORY:",default=.true.) call ESMF_ConfigGetAttribute(cap%config,cap%run_extdata,label="RUN_EXTDATA:",default=.true.) diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index a0684d51f9bb..d980491ebe30 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -1126,12 +1126,8 @@ subroutine MAPL_BcastShared_2DR8(VM, Data, N, Root, RootOnly, rc) integer, optional, intent(IN ) :: Root logical, intent(IN ) :: RootOnly integer, optional, intent( OUT) :: rc - - integer :: status - - if(.not.MAPL_ShmInitialized) then if (RootOnly) then _RETURN(ESMF_SUCCESS) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 8cec02c76410..7ce23e8ab65f 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -289,7 +289,6 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) ! call MPI_Barrier(mpic, status) - call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) fptr=real(arr_lon(i_1:i_n,j_1:j_n), kind=ESMF_KIND_R8) diff --git a/gridcomps/History/MAPL_EpochSwathMod.F90 b/gridcomps/History/MAPL_EpochSwathMod.F90 index 82fdebcbd9b6..ae42ac808963 100644 --- a/gridcomps/History/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/MAPL_EpochSwathMod.F90 @@ -262,7 +262,7 @@ end subroutine regrid_accumulate_on_xysubset subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) implicit none - class(samplerHQ), target :: this + class(samplerHQ) :: this class(sampler) :: sp type (StringGridMap), target, intent(inout) :: output_grids character(len=*), intent(in) :: key_grid_label From 84595af77da585916a0e304d91725ff945b5c881 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 12 Jan 2024 09:19:57 -0700 Subject: [PATCH 31/86] changed rc=status to _RC, EX to exist, and deleted some dead code to remove confusion. --- Tests/ExtDataDriverGridComp.F90 | 9 ++++----- base/MAPL_Comms.F90 | 12 ++++-------- base/MAPL_ObsUtil.F90 | 18 ++++++------------ 3 files changed, 14 insertions(+), 25 deletions(-) diff --git a/Tests/ExtDataDriverGridComp.F90 b/Tests/ExtDataDriverGridComp.F90 index 551e2eb61297..d4d11b038ed4 100644 --- a/Tests/ExtDataDriverGridComp.F90 +++ b/Tests/ExtDataDriverGridComp.F90 @@ -187,10 +187,9 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call MAPL_Set(MAPLOBJ, name = cap%name, cf = cap%config, rc = status) _VERIFY(status) - call MAPL_GetResource(MAPLOBJ, useShmem, label = 'USE_SHMEM:', default = 0, rc = status) + call MAPL_GetResource(MAPLOBJ, useShmem, label = 'USE_SHMEM:', default = 0, _RC) if (useShmem /= 0) then - call MAPL_InitializeShmem (rc = status) - _VERIFY(status) + call MAPL_InitializeShmem (_RC) end if call ESMF_ConfigGetAttribute(cap%config,cap%run_fbf,label="RUN_FBF:",default=.false.) @@ -492,8 +491,8 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigDestroy(cap%config, rc = status) _VERIFY(status) - call MAPL_FinalizeSHMEM (rc = status) - _VERIFY(status) + call MAPL_FinalizeSHMEM (_RC) + _RETURN(ESMF_SUCCESS) end subroutine finalize_gc diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index d980491ebe30..12053ea06722 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -1132,15 +1132,11 @@ subroutine MAPL_BcastShared_2DR8(VM, Data, N, Root, RootOnly, rc) if (RootOnly) then _RETURN(ESMF_SUCCESS) end if - call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, RC=status) - _RETURN(STATUS) + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, _RC) else - call MAPL_SyncSharedMemory(RC=STATUS) - _VERIFY(STATUS) - call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, rc=status) - _VERIFY(STATUS) - call MAPL_SyncSharedMemory(RC=STATUS) - _VERIFY(STATUS) + call MAPL_SyncSharedMemory(_RC) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, _RC) + call MAPL_SyncSharedMemory(_RC) endif _RETURN(ESMF_SUCCESS) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index ba81b21584c1..981a1d3b8ac2 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -99,12 +99,6 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & obsfile_Ts_index = n1 obsfile_Te_index = n2 -! if ( dT2_s - n2*dT0_s < 1 ) then -! obsfile_Te_index = n2 - 1 -! else -! obsfile_Te_index = n2 -! end if - _RETURN(ESMF_SUCCESS) end subroutine get_obsfile_Tbracket_from_epoch @@ -218,7 +212,7 @@ subroutine Find_M_files_for_currTime (currTime, & integer :: n1, n2 integer :: i, j integer :: status - logical :: EX + logical :: exist !__ s1. Arithmetic index list based on s,e,interval ! @@ -268,8 +262,8 @@ subroutine Find_M_files_for_currTime (currTime, & do i= n1, n2 test_file = get_filename_from_template_use_index & (obsfile_start_time, obsfile_interval, & - i, file_template, EX, rc=rc) - if (EX) then + i, file_template, exist, rc=rc) + if (exist) then j=j+1 filenames(j) = test_file end if @@ -474,7 +468,7 @@ end subroutine read_M_files_4_swath ! because of (bash ls) command therein ! function get_filename_from_template_use_index (obsfile_start_time, obsfile_interval, & - f_index, file_template, EX, rc) result(filename) + f_index, file_template, exist, rc) result(filename) use Plain_netCDF_Time, only : ESMF_time_to_two_integer use MAPL_StringTemplate, only : fill_grads_template character(len=ESMF_MAXSTR) :: filename @@ -482,7 +476,7 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter type(ESMF_TimeInterval), intent(in) :: obsfile_interval character(len=*), intent(in) :: file_template integer, intent(in) :: f_index - logical, intent(out) :: EX + logical, intent(out) :: exist integer, optional, intent(out) :: rc integer :: itime(2) @@ -514,7 +508,7 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter ! call fill_grads_template ( filename, file_template, & experiment_id='', nymd=nymd, nhms=nhms, _RC ) - inquire(file= trim(filename), EXIST = EX) + inquire(file= trim(filename), EXIST = exist) _RETURN(_SUCCESS) From 52aa5a3abed76eab1e0879c8848ded81fe85b602 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 12 Jan 2024 13:47:16 -0500 Subject: [PATCH 32/86] updates for geostitionary output part 1 --- CHANGELOG.md | 2 + base/MAPL_EsmfRegridder.F90 | 57 ++++++++++++++++---------- base/MAPL_XYGridFactory.F90 | 48 ++++++++++++++++++---- shared/Constants/InternalConstants.F90 | 5 +++ 4 files changed, 84 insertions(+), 28 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c50ea8f9ef5f..ded382be21e9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - Added memory utility, MAPL_MemReport that can be used in any code linking MAPL +- Added capability in XY grid factory to add a mask to the grid any points are missing needed for geostationary input data +- Added capability in the MAPL ESMF regridding wrapper to apply a destination mask if the destination grid contains a mask ### Changed diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 581545b41c57..78e4dcd1cabd 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -12,6 +12,7 @@ module MAPL_EsmfRegridderMod use MAPL_GridManagerMod use MAPL_BaseMod, only: MAPL_undef, MAPL_GridHasDE use MAPL_RegridderSpecRouteHandleMap + use MAPL_ConstantsMod implicit none private @@ -138,7 +139,7 @@ subroutine regrid_scalar_2d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -193,7 +194,7 @@ subroutine regrid_scalar_2d_real64(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -245,7 +246,7 @@ subroutine transpose_regrid_scalar_2d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) @@ -328,7 +329,7 @@ subroutine regrid_scalar_3d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -411,7 +412,7 @@ subroutine regrid_scalar_3d_real64(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -492,7 +493,7 @@ subroutine transpose_regrid_scalar_3d_real32(this, q_in, q_out, rc) if (HasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) @@ -581,7 +582,7 @@ subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -675,7 +676,7 @@ subroutine regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rotate, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -765,7 +766,7 @@ subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rot if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) @@ -881,7 +882,7 @@ subroutine regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -990,7 +991,7 @@ subroutine regrid_vector_3d_real64(this, u_in, v_in, u_out, v_out, rc) if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, rc=status) @@ -1107,7 +1108,7 @@ subroutine transpose_regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rot if (hasDE) then call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,rc=status) _VERIFY(status) - p_dst = 0 + p_dst = MAPL_UNDEF end if call this%do_regrid(src_field, dst_field, doTranspose=.true.,rc=status) @@ -1433,7 +1434,7 @@ subroutine create_route_handle(this, kind, rc) real(ESMF_KIND_R8), pointer :: factorList(:) type(ESMF_RouteHandle) :: dummy_rh type(ESMF_UnmappedAction_Flag) :: unmappedaction - logical :: global, isPresent + logical :: global, isPresent, has_mask type(RegridderSpecRouteHandleMap), pointer :: route_handles, transpose_route_handles type(ESMF_RouteHandle) :: route_handle, transpose_route_handle @@ -1482,6 +1483,8 @@ subroutine create_route_handle(this, kind, rc) dst_dummy_r8 = 0 end if end if + call ESMF_GridGetItem(spec%grid_out,itemflag=ESMF_GRIDITEM_MASK, & + staggerloc=ESMF_STAGGERLOC_CENTER, isPresent = has_mask, _RC) counter = counter + 1 @@ -1493,16 +1496,25 @@ subroutine create_route_handle(this, kind, rc) end if select case (spec%regrid_method) case (REGRID_METHOD_BILINEAR, REGRID_METHOD_BILINEAR_MONOTONIC) - - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & - & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) - _VERIFY(status) + if (has_mask) then + call ESMF_FieldRegridStore(src_field, dst_field, & + & dstMaskValues = [MAPL_MASK_OUT], & + & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & + & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, _RC) + else + call ESMF_FieldRegridStore(src_field, dst_field, & + & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & + & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, _RC) + end if case (REGRID_METHOD_PATCH) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_PATCH, & & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? @@ -1512,6 +1524,7 @@ subroutine create_route_handle(this, kind, rc) _VERIFY(status) case (REGRID_METHOD_CONSERVE_2ND) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, & & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? @@ -1520,6 +1533,7 @@ subroutine create_route_handle(this, kind, rc) & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) _VERIFY(status) case (REGRID_METHOD_CONSERVE, REGRID_METHOD_CONSERVE_MONOTONIC, REGRID_METHOD_VOTE, REGRID_METHOD_FRACTION) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_CONSERVE, & & srcTermProcessing = srcTermProcessing, & @@ -1527,6 +1541,7 @@ subroutine create_route_handle(this, kind, rc) & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) _VERIFY(status) case (REGRID_METHOD_NEAREST_STOD) + _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") call ESMF_FieldRegridStore(src_field, dst_field, & & regridmethod=ESMF_REGRIDMETHOD_NEAREST_STOD, & & factorList=factorList, factorIndexList=factorIndexList, & diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 7d3f8fc81746..f210e0546e94 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -8,6 +8,8 @@ module MAPL_XYGridFactoryMod use MAPL_ExceptionHandling use MAPL_ShmemMod use MAPL_Constants + use MAPL_CommsMod + use MAPL_BaseMod use ESMF use pFIO use NetCDF @@ -65,6 +67,7 @@ module MAPL_XYGridFactoryMod procedure :: decomps_are_equal procedure :: physical_params_are_equal procedure :: file_has_corners + procedure :: add_mask end type XYGridFactory character(len=*), parameter :: MOD_NAME = 'MAPL_XYGridFactory::' @@ -138,8 +141,8 @@ function make_new_grid(this, unusable, rc) result(grid) grid = this%create_basic_grid(rc=status) _VERIFY(status) - call this%add_horz_coordinates_from_file(grid, rc=status) - _VERIFY(status) + call this%add_horz_coordinates_from_file(grid, _RC) + call this%add_mask(grid,_RC) _RETURN(_SUCCESS) @@ -215,7 +218,6 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _UNUSED_DUMMY(unusable) - lon_center_name = "lons" lat_center_name = "lats" lon_corner_name = "corner_lons" @@ -253,7 +255,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,centers) _VERIFY(status) - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 + where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -269,7 +271,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,centers) _VERIFY(status) - centers=centers*MAPL_DEGREES_TO_RADIANS_R8 + where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -296,7 +298,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,corners) _VERIFY(status) - corners=corners*MAPL_DEGREES_TO_RADIANS_R8 + where(corners /= MAPL_UNDEF) corners=corners*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -312,7 +314,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _VERIFY(status) status = nf90_get_var(ncid,varid,corners) _VERIFY(status) - corners=corners*MAPL_DEGREES_TO_RADIANS_R8 + where(corners /= MAPL_UNDEF) corners=corners*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) @@ -894,4 +896,36 @@ subroutine file_has_corners(this,rc) _RETURN(_SUCCESS) end subroutine + subroutine add_mask(this,grid,rc) + class(XYGridFactory), intent(in) :: this + type(ESMF_Grid), intent(inout) :: grid + integer, intent(out), optional :: rc + + integer(ESMF_KIND_I4), pointer :: mask(:,:) + real(ESMF_KIND_R8), pointer :: fptr(:,:) + integer :: i,j,status + type(ESMF_VM) :: vm + integer :: has_undef, local_has_undef + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=fptr, rc=status) + local_has_undef = 0 + if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) + if (has_undef == 1) then + _RETURN(_SUCCESS) + end if + + call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK,_RC) + call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & + itemflag=ESMF_GRIDITEM_MASK,farrayPtr=mask,_RC) + + mask = MAPL_MASK_IN + where(fptr==MAPL_UNDEF) mask = MAPL_MASK_OUT + + _RETURN(_SUCCESS) + end subroutine + end module MAPL_XYGridFactoryMod diff --git a/shared/Constants/InternalConstants.F90 b/shared/Constants/InternalConstants.F90 index d9ab4f35b774..ac2935ea9911 100644 --- a/shared/Constants/InternalConstants.F90 +++ b/shared/Constants/InternalConstants.F90 @@ -173,6 +173,11 @@ module MAPL_InternalConstantsMod enumerator MAPL_Quantize_GranularBR enumerator MAPL_Quantize_BitRound endenum + ! Constant masking + enum, bind(c) + enumerator MAPL_MASK_OUT + enumerator MAPL_MASK_IN + endenum !EOP end module MAPL_InternalConstantsMod From 7dad367aa2a423c25e01214baf55f8094fc0e669 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 12 Jan 2024 14:11:09 -0500 Subject: [PATCH 33/86] fix typo in last commit --- base/MAPL_XYGridFactory.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index f210e0546e94..31b8860276c9 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -914,7 +914,7 @@ subroutine add_mask(this,grid,rc) if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) - if (has_undef == 1) then + if (has_undef == 0) then _RETURN(_SUCCESS) end if From 68480319861ede2ad9b379d50c91dc025d131fda Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 12 Jan 2024 12:23:56 -0700 Subject: [PATCH 34/86] avoid using temporary variables for time_loc_R8, lon_loc and lat_loc in subroutine read_M_files_4_swath in MAPL_ObsUtil.F90 --- base/MAPL_ObsUtil.F90 | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 981a1d3b8ac2..96ada969b733 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -427,6 +427,19 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & else + if (allocated (time)) then + deallocate(time) + allocate (time(Xdim, Ydim)) + end if + if (allocated (lon)) then + deallocate(lon) + allocate (lon(Xdim, Ydim)) + end if + if (allocated (lat)) then + deallocate(lat) + allocate (lat(Xdim, Ydim)) + end if + jx=0 do i = 1, M filename = filenames(i) @@ -434,24 +447,13 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & nlat = nlats(i) if (present(var_name_time).AND.present(time)) then - allocate (time_loc_R8(nlon, nlat)) - call get_var_from_name_w_group (var_name_time, time_loc_R8, filename, _RC) - time(1:nlon,jx+1:jx+nlat) = time_loc_R8(1:nlon,1:nlat) - deallocate(time_loc_R8) + call get_var_from_name_w_group (var_name_time, time(1:nlon,jx+1:jx+nlat), filename, _RC) end if - if (present(var_name_lon).AND.present(lon)) then - allocate (lon_loc(nlon, nlat)) - call get_var_from_name_w_group (var_name_lon, lon_loc, filename, _RC) - lon(1:nlon,jx+1:jx+nlat) = lon_loc(1:nlon,1:nlat) - deallocate(lon_loc) + call get_var_from_name_w_group (var_name_lon, lon(1:nlon,jx+1:jx+nlat), filename, _RC) end if - if (present(var_name_lat).AND.present(lat)) then - allocate (lat_loc(nlon, nlat)) - call get_var_from_name_w_group (var_name_lat, lat_loc, filename, _RC) - lat(1:nlon,jx+1:jx+nlat) = lat_loc(1:nlon,1:nlat) - deallocate(lat_loc) + call get_var_from_name_w_group (var_name_lat, lat(1:nlon,jx+1:jx+nlat), filename, _RC) end if jx = jx + nlat From c250cceaf925add5a75a4739b823ba6c9d3ebd0c Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 12 Jan 2024 13:08:46 -0700 Subject: [PATCH 35/86] test From 03f5b0dc0acf87e856322ef6f19228333cbd5b15 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Sun, 14 Jan 2024 21:07:18 -0700 Subject: [PATCH 36/86] test --- Apps/abi_fixed_coord.F90 | 1743 +++++++++++++++++++++++++++++++++++ Apps/time_ave_util.F90 | 1744 +----------------------------------- base/Plain_netCDF_Time.F90 | 27 + 3 files changed, 1771 insertions(+), 1743 deletions(-) create mode 100644 Apps/abi_fixed_coord.F90 mode change 100644 => 120000 Apps/time_ave_util.F90 diff --git a/Apps/abi_fixed_coord.F90 b/Apps/abi_fixed_coord.F90 new file mode 100644 index 000000000000..7f0190788d30 --- /dev/null +++ b/Apps/abi_fixed_coord.F90 @@ -0,0 +1,1743 @@ +#define I_AM_MAIN +#include "MAPL_Generic.h" + +program time_ave + + use ESMF + use MAPL + use MAPL_FileMetadataUtilsMod + use gFTL_StringVector + use MPI + use, intrinsic :: iso_fortran_env, only: int32, int64, int16, real32, real64 + use ieee_arithmetic, only: isnan => ieee_is_nan + + implicit none + + integer comm,myid,npes,ierror + integer imglobal + integer jmglobal + logical root + +! ********************************************************************** +! ********************************************************************** +! **** **** +! **** Program to create time-averaged HDF files **** +! **** **** +! ********************************************************************** +! ********************************************************************** + + integer im,jm,lm + + integer nymd, nhms + integer nymd0,nhms0 + integer nymdp,nhmsp + integer nymdm,nhmsm + integer ntod, ndt, ntods + integer month, year + integer monthp, yearp + integer monthm, yearm + integer begdate, begtime + integer enddate, endtime + + integer id,rc,timeinc,timeid + integer ntime,nvars,ncvid,nvars2 + + character(len=ESMF_MAXSTR), allocatable :: fname(:) + character(len=ESMF_MAXSTR) template + character(len=ESMF_MAXSTR) name + character(len=ESMF_MAXSTR) ext + character(len=ESMF_MAXSTR) output, doutput, hdfile, rcfile + character(len=8) date0 + character(len=2) time0 + character(len=1) char + data output /'monthly_ave'/ + data rcfile /'NULL'/ + data doutput /'NULL'/ + data template/'NULL'/ + + integer n,m,nargs,L,nfiles,nv,km,mvars,mv,ndvars + + real plev,qming,qmaxg + real previous_undef,undef + real, allocatable :: lev(:) + integer, allocatable :: kmvar(:) , kmvar2(:) + integer, allocatable :: yymmdd(:) + integer, allocatable :: hhmmss(:) + integer, allocatable :: nloc(:) + integer, allocatable :: iloc(:) + + character(len=ESMF_MAXSTR), allocatable :: vname(:), vname2(:) + character(len=ESMF_MAXSTR), allocatable :: vtitle(:), vtitle2(:) + character(len=ESMF_MAXSTR), allocatable :: vunits(:), vunits2(:) + + real, allocatable :: qmin(:) + real, allocatable :: qmax(:) + real, allocatable :: dumz1(:,:) + real, allocatable :: dumz2(:,:) + real, allocatable :: dum(:,:,:) + real(REAL64), allocatable :: q(:,:,:,:) + integer, allocatable :: ntimes(:,:,:,:) + + integer timinc,i,j,k,nmax,kbeg,kend,loc1,loc2 + integer nstar + logical tend, first, strict, diurnal, mdiurnal, lquad, ldquad + logical ignore_nan + data first /.true./ + data strict /.true./ + + type(ESMF_Config) :: config + + integer, allocatable :: qloc(:,:) + character(len=ESMF_MAXSTR), allocatable :: quadratics(:,:) + character(len=ESMF_MAXSTR), allocatable :: quadtmp(:,:) + character(len=ESMF_MAXSTR), allocatable :: aliases(:,:) + character(len=ESMF_MAXSTR), allocatable :: aliastmp(:,:) + character(len=ESMF_MAXSTR) name1, name2, name3, dummy + integer nquad + integer nalias + logical, allocatable :: lzstar(:) + + integer ntmin, ntcrit, nc + + type(FileMetadata) :: basic_metadata + type(FileMetadataUtils) :: file_metadata + type(NetCDF4_FileFormatter) :: file_handle + integer :: status + class(AbstractGridfactory), allocatable :: factory + type(ESMF_Grid) :: output_grid,input_grid + character(len=:), allocatable :: output_grid_name + integer :: global_dims(3), local_dims(3) + type(ESMF_Time), allocatable :: time_series(:) + type(ESMF_TIme) :: etime + type(ESMF_Clock) :: clock + type(ESMF_TimeInterval) :: time_interval + type(ESMF_FieldBundle) :: primary_bundle,final_bundle,diurnal_bundle + type(ESMF_Field) :: field + type(ServerManager) :: io_server + type(FieldBundleWriter) :: standard_writer, diurnal_writer + real(ESMF_KIND_R4), pointer :: ptr2d(:,:),ptr3d(:,:,:) + character(len=ESMF_MAXSTR) :: grid_type + logical :: allow_zonal_means + character(len=ESMF_MAXPATHLEN) :: arg_str + character(len=:), allocatable :: lev_name + character(len=ESMF_MAXSTR) :: lev_units + integer :: n_times + type(verticalData) :: vertical_data + logical :: file_has_lev + type(DistributedProfiler), target :: t_prof + type(ProfileReporter) :: reporter + +! ********************************************************************** +! **** Initialization **** +! ********************************************************************** + +!call timebeg ('main') + + call mpi_init ( ierror ) ; comm = mpi_comm_world + call mpi_comm_rank ( comm,myid,ierror ) + call mpi_comm_size ( comm,npes,ierror ) + call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,mpiCommunicator=MPI_COMM_WORLD, _RC) + call MAPL_Initialize(_RC) + t_prof = DistributedProfiler('time_ave_util',MpiTImerGauge(),MPI_COMM_WORLD) + call t_prof%start(_RC) + call io_server%initialize(MPI_COMM_WORLD,_RC) + root = myid.eq.0 + call ESMF_CalendarSetDefault(ESMF_CALKIND_GREGORIAN,_RC) + +! Read Command Line Arguments +! --------------------------- + begdate = -999 + begtime = -999 + enddate = -999 + endtime = -999 + ndt = -999 + ntod = -999 + ntmin = -999 + nargs = command_argument_count() + if( nargs.eq.0 ) then + call usage(root) + else + lquad = .TRUE. + ldquad = .FALSE. + diurnal = .FALSE. + mdiurnal = .FALSE. + ignore_nan = .FALSE. + do n=1,nargs + call get_command_argument(n,arg_str) + select case(trim(arg_str)) + case('-template') + call get_command_argument(n+1,template) + case('-tag') + call get_command_argument(n+1,output) + case('-rc') + call get_command_argument(n+1,rcfile) + case('-begdate') + call get_command_argument(n+1,arg_str) + read(arg_str,*)begdate + case('-begtime') + call get_command_argument(n+1,arg_str) + read(arg_str,*)begtime + case('-enddate') + call get_command_argument(n+1,arg_str) + read(arg_str,*)enddate + case('-endtime') + call get_command_argument(n+1,arg_str) + read(arg_str,*)endtime + case('-ntmin') + call get_command_argument(n+1,arg_str) + read(arg_str,*)ntmin + case('-ntod') + call get_command_argument(n+1,arg_str) + read(arg_str,*)ntod + case('-ndt') + call get_command_argument(n+1,arg_str) + read(arg_str,*)ndt + case('-strict') + call get_command_argument(n+1,arg_str) + read(arg_str,*)strict + case('-ogrid') + call get_command_argument(n+1,arg_str) + output_grid_name = trim(arg_str) + case('-noquad') + lquad = .FALSE. + case('-ignore_nan') + ignore_nan = .TRUE. + case('-d') + diurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-md') + mdiurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-dv') + ldquad = .true. + diurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-mdv') + ldquad = .true. + mdiurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-eta') + nfiles = 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + do while (char .ne. '-' .and. n+nfiles.ne.nargs) + nfiles = nfiles + 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + enddo + if (char.eq.'-') nfiles = nfiles-1 + allocate(fname(nfiles)) + do m=1,nfiles + call get_command_argument(n+m,fname(m)) + enddo + case('-hdf') + nfiles = 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + do while (char .ne. '-' .and. n+nfiles.ne.nargs) + nfiles = nfiles + 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + enddo + if (char.eq.'-') nfiles = nfiles-1 + allocate(fname(nfiles)) + do m=1,nfiles + call get_command_argument(n+m,fname(m)) + enddo + end select + enddo + end if + + if( (diurnal.or.mdiurnal) .and. trim(doutput).eq.'NULL' ) then + doutput = trim(output) // "_diurnal" + if( mdiurnal ) diurnal = .FALSE. + endif + + if (root .and. ignore_nan) print *,' ignore nan is true' + + +! Read RC Quadratics +! ------------------ + if( trim(rcfile).eq.'NULL' ) then + nquad = 0 + nalias = 0 + else + config = ESMF_ConfigCreate ( rc=rc ) + call ESMF_ConfigLoadFile ( config, trim(rcfile), rc=rc ) + call ESMF_ConfigFindLabel ( config, 'QUADRATICS:', rc=rc ) + tend = .false. + m = 0 + do while (.not.tend) + m = m+1 + allocate( quadtmp(3,m) ) + call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=name3,default='XXX',rc=rc ) + call ESMF_ConfigNextLine ( config,tableEnd=tend, rc=rc ) + if( m==1 ) then + quadtmp(1,m) = name1 + quadtmp(2,m) = name2 + quadtmp(3,m) = name3 + allocate( quadratics(3,m) ) + quadratics = quadtmp + else + quadtmp(1,1:m-1) = quadratics(1,:) + quadtmp(2,1:m-1) = quadratics(2,:) + quadtmp(3,1:m-1) = quadratics(3,:) + quadtmp(1,m) = name1 + quadtmp(2,m) = name2 + quadtmp(3,m) = name3 + deallocate( quadratics ) + allocate( quadratics(3,m) ) + quadratics = quadtmp + endif + deallocate (quadtmp) + enddo + nquad = m + +! Read RC Aliases +! --------------- + call ESMF_ConfigFindLabel ( config, 'ALIASES:', rc=rc ) + tend = .false. + m = 0 + do while (.not.tend) + m = m+1 + allocate( aliastmp(2,m) ) + call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) + call ESMF_ConfigNextLine ( config,tableEnd=tend ,rc=rc ) + if( m==1 ) then + aliastmp(1,m) = name1 + aliastmp(2,m) = name2 + allocate( aliases(2,m) ) + aliases = aliastmp + else + aliastmp(1,1:m-1) = aliases(1,:) + aliastmp(2,1:m-1) = aliases(2,:) + aliastmp(1,m) = name1 + aliastmp(2,m) = name2 + deallocate( aliases ) + allocate( aliases(2,m) ) + aliases = aliastmp + endif + deallocate (aliastmp) + enddo + nalias = m + endif + if (.not. allocated(aliases)) allocate(aliases(0,0)) + +! ********************************************************************** +! **** Read HDF File **** +! ********************************************************************** + + call t_prof%start('initialize') + + if( trim(template).ne.'NULL' ) then + name = template + else + name = fname(1) + endif + + n = index(trim(name),'.',back=.true.) + ext = trim(name(n+1:)) + + call file_handle%open(trim(name),PFIO_READ,_RC) + basic_metadata = file_handle%read(_RC) + call file_handle%close(_RC) + + allocate(factory, source=grid_manager%make_factory(trim(name))) + input_grid = grid_manager%make_grid(factory) + file_has_lev = has_level(input_grid,_RC) + call MAPL_GridGet(input_grid,globalCellCountPerDim=global_dims,_RC) + lm = global_dims(3) + + if (file_has_lev) then + call get_file_levels(trim(name),vertical_data,_RC) + end if + + if (allocated(output_grid_name)) then + output_grid = create_output_grid(output_grid_name,lm,_RC) + else + output_grid = input_grid + end if + call ESMF_AttributeGet(output_grid,'GridType',grid_type,_RC) + allow_zonal_means = trim(grid_type) == 'LatLon' + if (trim(grid_type) == "Cubed-Sphere") then + _ASSERT(mod(npes,6)==0,"If input files are Cubed-Sphere, must be run on multiple of 6 proccessors") + end if + call MAPL_GridGet(output_grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) + im = local_dims(1) + jm = local_dims(2) + lm = local_dims(3) + imglobal = global_dims(1) + jmglobal = global_dims(2) + + call file_metadata%create(basic_metadata,trim(name)) + call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) + primary_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) + call ESMF_FieldBundleSet(primary_bundle,grid=output_grid,_RC) + call MAPL_Read_Bundle(primary_bundle,trim(name),time=time_series(1),_RC) + call ESMF_FieldBundleGet(primary_bundle,fieldCount=nvars,_RC) + allocate(vname(nvars)) + call ESMF_FieldBundleGet(primary_bundle,fieldNameList=vname,_RC) + kmvar = get_level_info(primary_bundle,_RC) + vtitle = get_long_names(primary_bundle,_RC) + vunits = get_units(primary_bundle,_RC) + + final_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) + call ESMF_FieldBundleSet(final_bundle,grid=output_grid,_RC) + diurnal_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) + call ESMF_FieldBundleSet(diurnal_bundle,grid=output_grid,_RC) + call copy_bundle_to_bundle(primary_bundle,final_bundle,_RC) + + if (size(time_series)>1) then + time_interval = time_series(2) - time_series(1) + else if (size(time_series)==1) then + call ESMF_TimeIntervalSet(time_interval,h=6,_RC) + end if + clock = ESMF_ClockCreate(startTime=time_series(1),timeStep=time_interval,_RC) + + nvars2 = nvars + + if (file_has_lev) then + lev_name = file_metadata%get_level_name(_RC) + call file_metadata%get_coordinate_info(lev_name,coords=lev,coordUnits=lev_units,_RC) + end if + + previous_undef = file_metadata%var_get_missing_value(trim(vname(1)),_RC) + do i=2,size(vname) + undef = file_metadata%var_get_missing_value(trim(vname(i)),_RC) + _ASSERT(undef == previous_undef,"conflicting undefined values in your variables") + previous_undef = undef + enddo + undef = previous_undef + + +! Set NDT for Strict Time Testing +! ------------------------------- + if( ntod.ne.-999 ) ndt = 86400 + if( ndt .eq.-999 ) ndt = compute_nsecf (timinc) + if( timinc .eq. 0 ) then + timeId = ncvid (id, 'time', rc) + call ncagt (id, timeId, 'time_increment', timinc, rc) + if( timinc .eq. 0 ) then + if( root ) then + print * + print *, 'Warning, GFIO Inquire states TIMINC = ',timinc + print *, ' This will be reset to 060000 ' + print *, ' Use -ndt NNN (in seconds) to overide this' + endif + timinc = 060000 + endif + ndt = compute_nsecf (timinc) + endif + +! Determine Number of Time Periods within 1-Day +! --------------------------------------------- + ntods = 0 + if( diurnal .or. mdiurnal ) then + if( ndt.lt.86400 ) ntods = 86400/ndt + endif + +! Set Minimum Required Times for Time Average (Default: 10 Days for Monthly Mean) +! ------------------------------------------------------------------------------- + if( ntmin.eq.-999 ) then + if( ntod.eq.-999 ) then + ntcrit = 10 * ( 86400.0/real(compute_nsecf(timinc)) ) + else + ntcrit = 10 + endif + else + ntcrit = ntmin + endif + +! Determine Location Index for Each Variable in File +! -------------------------------------------------- + if( root ) print * + allocate ( nloc(nvars) ) + nloc(1) = 1 + if( root ) write(6,7000) 1,trim(vname(1)),nloc(1),trim(vtitle(1)),max(1,kmvar(1)) + do n=2,nvars + nloc(n) = nloc(n-1)+max(1,kmvar(n-1)) + if( root ) write(6,7000) n,trim(vname(n)),nloc(n),trim(vtitle(n)),max(1,kmvar(n)) +7000 format(1x,'Primary Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a40,2x,i2,3x,i2,3x,i2) + enddo + + nmax = nloc(nvars)+max(1,kmvar(nvars))-1 + allocate( dum (im,jm,nmax) ) + allocate( dumz1(im,jm) ) + allocate( dumz2(im,jm) ) + +! Append Default Quadratics to User-Supplied List +! ----------------------------------------------- + if( lquad ) then + if( nquad.eq.0 ) then + allocate( quadratics(3,nvars) ) + do n=1,nvars + quadratics(1,n) = trim( vname(n) ) + quadratics(2,n) = trim( vname(n) ) + quadratics(3,n) = 'XXX' + enddo + nquad = nvars + else + allocate( quadtmp(3,nquad+nvars) ) + quadtmp(1,1:nquad) = quadratics(1,:) + quadtmp(2,1:nquad) = quadratics(2,:) + quadtmp(3,1:nquad) = quadratics(3,:) + do n=1,nvars + quadtmp(1,nquad+n) = trim( vname(n) ) + quadtmp(2,nquad+n) = trim( vname(n) ) + quadtmp(3,nquad+n) = 'XXX' + enddo + nquad = nquad + nvars + deallocate( quadratics ) + allocate( quadratics(3,nquad) ) + quadratics = quadtmp + deallocate( quadtmp ) + endif + endif + + allocate ( qloc(2,nquad) ) + allocate ( lzstar(nquad) ) ; lzstar = .FALSE. + +! Determine Possible Quadratics +! ----------------------------- + km=kmvar(nvars) + m= nvars + do n=1,nquad + call check_quad ( quadratics(1,n),vname,nvars,aliases,nalias,qloc(1,n) ) + if( qloc(1,n)*qloc(2,n).ne.0 ) then + m=m+1 + allocate ( iloc(m) ) + iloc(1:m-1) = nloc + iloc(m) = iloc(m-1)+max(1,km) + deallocate ( nloc ) + allocate ( nloc(m) ) + nloc = iloc + deallocate ( iloc ) + km=kmvar( qloc(1,n) ) + endif + enddo + + mvars = m + nmax = nloc(m)+max(1,km)-1 + + allocate ( vname2( mvars) ) + allocate ( vtitle2( mvars) ) + allocate ( vunits2( mvars) ) + allocate ( kmvar2( mvars) ) + + vname2( 1:nvars) = vname + vtitle2( 1:nvars) = vtitle + vunits2( 1:nvars) = vunits + kmvar2( 1:nvars) = kmvar + + if( root .and. mvars.gt.nvars ) print * + mv= nvars + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv = mv+1 + + if( trim(quadratics(1,nv)).eq.trim(quadratics(2,nv)) ) then + vname2(mv) = "Var_" // trim(vname(qloc(1,nv))) + vtitle2(mv) = "Variance_of_" // trim(vname(qloc(1,nv))) + else + vname2(mv) = "Cov_" // trim(vname(qloc(1,nv))) // "_" // trim(vname(qloc(2,nv))) + vtitle2(mv) = "Covariance_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) + endif + + if( trim(quadratics(3,nv)).ne.'XXX' ) vname2(mv) = trim(quadratics(3,nv)) + + nstar = index( trim(quadratics(1,nv)),'star',back=.true. ) + if( nstar.ne.0 ) then + _ASSERT(allow_zonal_means,"grid is not lat-lon so cannot compute zonal means") + lzstar(nv) = .TRUE. + vtitle2(mv) = "Product_of_Zonal_Mean_Deviations_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) + endif + + vunits2(mv) = trim(vunits(qloc(1,nv))) // " " // trim(vunits(qloc(2,nv))) + kmvar2(mv) = kmvar(qloc(1,nv)) + + call add_new_field_to_bundle(final_bundle,output_grid,kmvar(qloc(1,nv)),vname2(mv),vtitle2(mv),vunits2(mv),_RC) + + if( root ) write(6,7001) mv,trim(vname2(mv)),nloc(mv),trim(vtitle2(mv)),max(1,kmvar(qloc(1,nv))),qloc(1,nv),qloc(2,nv) +7001 format(1x,' Quad Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a50,2x,i2,3x,i3,3x,i3) + endif + enddo + +!deallocate ( lev ) + deallocate ( yymmdd ) + deallocate ( hhmmss ) + deallocate ( vname ) + deallocate ( vtitle ) + deallocate ( vunits ) + deallocate ( kmvar ) + + allocate( qmin(nmax) ) + allocate( qmax(nmax) ) + allocate( q(im,jm,nmax,0:ntods) ) + allocate( ntimes(im,jm,nmax,0:ntods) ) + ntimes = 0 + q = 0 + qmin = abs(undef) + qmax = -abs(undef) + + if( root ) then + print * + write(6,7002) mvars,nmax,im,jm,nmax,ntods +7002 format(1x,'Total Number of Variables: ',i3,/ & + 1x,'Total Size: ',i5,/ & + 1x,'Allocating q(',i4,',',i3,',',i5,',0:',i2.2,')') + print * + print *, 'Files: ' + do n=1,nfiles + print *, n,trim(fname(n)) + enddo + print * + if( ntod.eq.-999 ) then + print *, 'Averging Time-Period NHMS: ',ntod,' (ALL Possible Time Periods Used)' + else + print *, 'Averging Time-Period NHMS: ',ntod + endif + if( begdate.ne.-999 .or. begtime.ne.-999 ) print *, 'Beginning Date for Averaging: ',begdate,begtime + if( enddate.ne.-999 .or. endtime.ne.-999 ) print *, ' Ending Date for Averaging: ',enddate,endtime + if( strict ) then + print *, 'Every Time Period Required for Averaging, STRICT = ',strict + else + print *, 'Only Averaging Time Periods Supplied, STRICT = ',strict + endif + write(6,7003) ntcrit +7003 format(1x,'Required Minimum Number of Defined Time Periods: ',i3,' (Otherwise, UNDEF)') + print * + endif + + call t_prof%stop('initialize') + +! ********************************************************************** +! **** Read HDF Files **** +! ********************************************************************** + + k = 0 + + do n=1,nfiles + + if (allocated(time_series)) deallocate(time_series) + if (allocated(yymmdd)) deallocate(yymmdd) + if (allocated(hhmmss)) deallocate(hhmmss) + call file_handle%open(trim(fname(n)),PFIO_READ,_RC) + basic_metadata = file_handle%read(_RC) + call file_handle%close(_RC) + call file_metadata%create(basic_metadata,trim(fname(n))) + call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) + + + do m=1,ntime + nymd = yymmdd(m) + nhms = hhmmss(m) + if( nhms<0 ) then + nhms = compute_nhmsf( compute_nsecf(nhms) + 86400 ) + call tick (nymd,nhms,-86400) + endif + + if( ( begdate.ne.-999 .and. begtime.ne.-999 ) .and. & + ( begdate.gt.nymd .or. & + ( begdate.eq.nymd.and.begtime.gt.nhms ) ) ) cycle + + if( ( enddate.ne.-999 .and. endtime.ne.-999 ) .and. & + ( enddate.lt.nymd .or. & + ( enddate.eq.nymd.and.endtime.lt.nhms ) ) ) cycle + + k = k+1 + if( k.gt.ntods ) k = 1 + if( ntod.eq.-999 .or. ntod.eq.nhms ) then + if( root ) write(6,3000) nymd,nhms,timinc,trim(fname(n)),k +3000 format(1x,'Reading nymd: ',i8.8,' nhms: ',i6.6,' TimInc: ',i6.6,' from File: ',a,' tod = ',i2) + year = nymd/10000 + month = mod(nymd,10000)/100 + +! Check for Correct First Dataset +! ------------------------------- + if( strict .and. first ) then + nymdm = nymd + nhmsm = nhms + call tick (nymdm,nhmsm,-ndt) + yearm = nymdm/10000 + monthm = mod(nymdm,10000)/100 + if( year.eq.yearm .and. month.eq.monthm ) then + if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct First Time Period!' + _FAIL("error processing dataset") + endif + endif + +! Check Date and Time for STRICT Time Testing +! ------------------------------------------- + if( strict .and. .not.first ) then + if( nymd.ne.nymdp .or. nhms.ne.nhmsp ) then + if( root ) print *, 'Date: ',nymdp,' Time: ',nhmsp,' not found!' + _FAIL("error processing dataset") + endif + endif + nymdp = nymd + nhmsp = nhms + +! Primary Fields +! -------------- + + etime = local_esmf_timeset(nymd,nhms,_RC) + call MAPL_Read_Bundle(primary_bundle,trim(fname(1)),time=etime,file_override=trim(fname(n)),_RC) + do nv=1,nvars2 + call ESMF_FieldBundleGet(primary_bundle,trim(vname2(nv)),field=field,_RC) + call t_prof%start('PRIME') + if( kmvar2(nv).eq.0 ) then + kbeg = 0 + kend = 1 + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + dum(:,:,nloc(nv))=ptr2d + else + kbeg = 1 + kend = kmvar2(nv) + + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + dum(:,:,nloc(nv):nloc(nv)+kmvar2(nv)-1) = ptr3d + endif + + rc = 0 + do L=1,max(1,kmvar2(nv)) + do j=1,jm + do i=1,im + if( isnan( dum(i,j,nloc(nv)+L-1) ) .or. ( dum(i,j,nloc(nv)+L-1).gt.HUGE(dum(i,j,nloc(nv)+L-1)) ) ) then +!print *, 'Warning! Nan or Infinity detected for ',trim(vname2(nv)),' at lat: ',lattice%jglobal(j),' lon: ',lattice%iglobal(i) + if( root .and. ignore_nan ) then + print *, 'Setting Nan or Infinity to UNDEF' + print * + else + rc = 1 + endif + dum(i,j,nloc(nv)+L-1) = undef + endif + if( defined(dum(i,j,nloc(nv)+L-1),undef) ) then + q(i,j,nloc(nv)+L-1,0) = q(i,j,nloc(nv)+L-1,0) + dum(i,j,nloc(nv)+L-1) + ntimes(i,j,nloc(nv)+L-1,0) = ntimes(i,j,nloc(nv)+L-1,0) + 1 + if( qmin(nloc(nv)+L-1).gt.dum(i,j,nloc(nv)+L-1) ) qmin(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) + if( qmax(nloc(nv)+L-1).lt.dum(i,j,nloc(nv)+L-1) ) qmax(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) + if( ntods.ne.0 ) then + q(i,j,nloc(nv)+L-1,k) = q(i,j,nloc(nv)+L-1,k) + dum(i,j,nloc(nv)+L-1) + ntimes(i,j,nloc(nv)+L-1,k) = ntimes(i,j,nloc(nv)+L-1,k) + 1 + endif + endif + enddo + enddo + enddo + call t_prof%stop('PRIME') + + enddo + +! Quadratics +! ---------- + call t_prof%start('QUAD') + mv= nvars2 + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv=mv+1 + do L=1,max(1,kmvar2(qloc(1,nv))) + if( lzstar(nv) ) then + call latlon_zstar (dum(:,:,nloc(qloc(1,nv))+L-1),dumz1,undef,output_grid,_RC) + call latlon_zstar (dum(:,:,nloc(qloc(2,nv))+L-1),dumz2,undef,output_grid,_RC) + do j=1,jm + do i=1,im + if( defined(dumz1(i,j),undef) .and. & + defined(dumz2(i,j),undef) ) then + q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dumz1(i,j)*dumz2(i,j) + ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 + if( ntods.ne.0 ) then + q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dumz1(i,j)*dumz2(i,j) + ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 + endif + endif + enddo + enddo + else + do j=1,jm + do i=1,im + if( defined(dum(i,j,nloc(qloc(1,nv))+L-1),undef) .and. & + defined(dum(i,j,nloc(qloc(2,nv))+L-1),undef) ) then + q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dum(i,j,nloc(qloc(1,nv))+L-1) & + * dum(i,j,nloc(qloc(2,nv))+L-1) + ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 + if( ntods.ne.0 ) then + q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dum(i,j,nloc(qloc(1,nv))+L-1) & + * dum(i,j,nloc(qloc(2,nv))+L-1) + ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 + endif + endif + enddo + enddo + endif + enddo + endif + enddo + call t_prof%stop('QUAD') + + if( first ) then + nymd0 = nymd + nhms0 = nhms + first = .false. + endif + +! Update Date and Time for Strict Test +! ------------------------------------ + call tick (nymdp,nhmsp,ndt) + yearp = nymdp/10000 + monthp = mod(nymdp,10000)/100 + + endif ! End ntod Test + enddo ! End ntime Loop within file + + call MPI_BARRIER(comm,status) + enddo + + do k=0,ntods + if( k.eq.0 ) then + nc = ntcrit + else + nc = max( 1,ntcrit/ntods ) + endif + do n=1,nmax + do j=1,jm + do i=1,im + if( ntimes(i,j,n,k).lt.nc ) then + q(i,j,n,k) = undef + else + q(i,j,n,k) = q(i,j,n,k)/ntimes(i,j,n,k) + endif + enddo + enddo + enddo + enddo + +! ********************************************************************** +! **** Write HDF Monthly Output File **** +! ********************************************************************** + +call t_prof%start('Write_AVE') + +! Check for Correct Last Dataset +! ------------------------------ + if( strict .and. ( year.eq.yearp .and. month.eq.monthp ) ) then + if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct Last Time Period!' + _FAIL("Error processing dataset") + endif + + write(date0,4000) nymd0/100 + write(time0,2000) nhms0/10000 + + hdfile = trim(output) // "." // trim(date0) // "." // trim(ext) + +1000 format(i8.8) +2000 format(i2.2) +4000 format(i6.6) + + timeinc = 060000 + +! Primary Fields +! -------------- + if( root ) print * + do n=1,nvars2 + call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) + if( kmvar2(n).eq.0 ) then + kbeg = 0 + kend = 1 + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = q(:,:,nloc(n),0) + else + kbeg = 1 + kend = kmvar2(n) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,0) + endif + if( root ) write(6,3001) trim(vname2(n)),nloc(n),trim(hdfile) +3001 format(1x,'Writing ',a,' at location ',i6,' into File: ',a) + dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,0) + enddo + +! Quadratics +! ---------- + mv= nvars2 + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv=mv+1 + if( root ) write(6,3001) trim(vname2(mv)),nloc(mv),trim(hdfile) + call ESMF_FieldBundleGet(final_bundle,trim(vname2(mv)),field=field,_RC) + + if( kmvar2(qloc(1,nv)).eq.0 ) then + kbeg = 0 + kend = 1 + else + kbeg = 1 + kend = kmvar2(qloc(1,nv)) + endif + loc1 = nloc( qloc(1,nv) ) + loc2 = nloc( qloc(2,nv) ) + if( .not.lzstar(nv) ) then + where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - q(:,:,loc1:loc1+kend-1,0) & + * q(:,:,loc2:loc2+kend-1,0) + elsewhere + dum(:,:,1:kend) = undef + endwhere + else + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) + endif + if( kmvar2(qloc(1,nv)).eq.0 ) then + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = dum(:,:,1) + else + kend = kmvar2(qloc(1,nv)) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = dum(:,:,1:kend) + endif + endif + enddo + + if( root ) then + print * + print *, 'Created: ',trim(hdfile) + print * + endif + call t_prof%stop('Write_AVE') + etime = local_esmf_timeset(nymd0,nhms0,_RC) + call ESMF_ClockSet(clock,currTime=etime, _RC) + call standard_writer%create_from_bundle(final_bundle,clock,n_steps=1,time_interval=timeinc,vertical_data=vertical_data,_RC) + call standard_writer%start_new_file(trim(hdfile),_RC) + call standard_writer%write_to_file(_RC) + +! ********************************************************************** +! **** Write HDF Monthly Diurnal Output File **** +! ********************************************************************** + + if( ntods.ne.0 ) then + call t_prof%start('Write_Diurnal') + timeinc = compute_nhmsf( 86400/ntods ) + + do k=1,ntods + + if( k.eq.1 .or. mdiurnal ) then + + write(date0,4000) nymd0/100 + write(time0,2000) nhms0/10000 + + if( diurnal ) hdfile = trim(doutput) // "." // trim(date0) // "." // trim(ext) + if( mdiurnal ) hdfile = trim(doutput) // "." // trim(date0) // "_" // trim(time0) // "z." // trim(ext) + + if( ldquad ) then + ndvars = mvars ! Include Quadratics in Diurnal Files + if (k==1) then + call copy_bundle_to_bundle(final_bundle,diurnal_bundle,_RC) + end if + else + ndvars = nvars2 ! Only Include Primary Fields in Diurnal Files (Default) + if (k==1) then + do n=1,nvars + call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) + call MAPL_FieldBundleAdd(diurnal_bundle,field,_RC) + enddo + endif + endif + endif + +! Primary Fields +! -------------- + do n=1,nvars2 + call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(n)),field=field,_RC) + if( kmvar2(n).eq.0 ) then + kbeg = 0 + kend = 1 + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = q(:,:,nloc(n),k) + else + kbeg = 1 + kend = kmvar2(n) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,k) + endif + dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,k) + enddo + +! Quadratics +! ---------- + if( ndvars.eq.mvars ) then + mv= nvars2 + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv=mv+1 + call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(mv)),field=field,_RC) + if( kmvar2(qloc(1,nv)).eq.0 ) then + kbeg = 0 + kend = 1 + else + kbeg = 1 + kend = kmvar2(qloc(1,nv)) + endif + loc1 = nloc( qloc(1,nv) ) + loc2 = nloc( qloc(2,nv) ) + if( .not.lzstar(nv) ) then + where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - q(:,:,loc1:loc1+kend-1,k) & + * q(:,:,loc2:loc2+kend-1,k) + elsewhere + dum(:,:,1:kend) = undef + endwhere + else + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) + endif + if( kmvar2(qloc(1,nv)).eq.0 ) then + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = dum(:,:,1) + else + kend = kmvar2(qloc(1,nv)) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = dum(:,:,1:kend) + endif + endif + enddo + endif + + + etime = local_esmf_timeset(nymd0,nhms0,_RC) + call ESMF_ClockSet(clock,currTime=etime, _RC) + if (k==1 .or. mdiurnal) then + if (mdiurnal) then + n_times = 1 + else + n_times = ntods + end if + if (k==1) then + call diurnal_writer%create_from_bundle(diurnal_bundle,clock,n_steps=n_times,time_interval=timeinc,vertical_data=vertical_data) + end if + call diurnal_writer%start_new_file(trim(hdfile),_RC) + end if + call diurnal_writer%write_to_file(_RC) + if( root .and. mdiurnal ) then + print *, 'Created: ',trim(hdfile) + endif + call tick (nymd0,nhms0,ndt) + enddo + + if( root .and. diurnal ) then + print *, 'Created: ',trim(hdfile) + endif + if( root ) print * + + call t_prof%stop('Write_Diurnal') + endif + +! ********************************************************************** +! **** Write Min/Max Information **** +! ********************************************************************** + + if( root ) print * + do n=1,nvars2 + do L=1,max(1,kmvar2(n)) + if( kmvar2(n).eq.0 ) then + plev = 0 + else + plev = lev(L) + endif + + call mpi_reduce( qmin(nloc(n)+L-1),qming,1,mpi_real,mpi_min,0,comm,ierror ) + call mpi_reduce( qmax(nloc(n)+L-1),qmaxg,1,mpi_real,mpi_max,0,comm,ierror ) + if( root ) then + if(L.eq.1) then + write(6,3101) trim(vname2(n)),plev,qming,qmaxg + else + write(6,3102) trim(vname2(n)),plev,qming,qmaxg + endif + endif +3101 format(1x,'Primary Field: ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) +3102 format(1x,' ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) + enddo + call MPI_BARRIER(comm,status) + if( root ) print * + enddo + if( root ) print * + +! ********************************************************************** +! **** Timing Information **** +! ********************************************************************** + + call io_server%finalize() + call t_prof%stop() + call t_prof%reduce() + call t_prof%finalize() + call generate_report() + call MAPL_Finalize() + call MPI_Finalize(status) + stop + +contains + + function create_output_grid(grid_name,lm,rc) result(new_grid) + type(ESMF_Grid) :: new_grid + character(len=*), intent(inout) :: grid_name + integer, intent(in) :: lm + integer, optional, intent(out) :: rc + + type(ESMF_Config) :: cf + integer :: nn,im_world,jm_world,nx, ny + character(len=5) :: imsz,jmsz + character(len=2) :: pole,dateline + + nn = len_trim(grid_name) + imsz = grid_name(3:index(grid_name,'x')-1) + jmsz = grid_name(index(grid_name,'x')+1:nn-3) + pole = grid_name(1:2) + dateline = grid_name(nn-1:nn) + read(IMSZ,*) im_world + read(JMSZ,*) jm_world + + cf = MAPL_ConfigCreate(_RC) + call MAPL_ConfigSetAttribute(cf,value=lm, label=trim(grid_name)//".LM:",_RC) + if (dateline=='CF') then + call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) + call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) + call MAPL_ConfigSetAttribute(cf,value="Cubed-Sphere", label=trim(grid_name)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cf,value=6, label=trim(grid_name)//".NF:",_RC) + call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) + else if (dateline=='TM') then + _FAIL("Tripolar not yet implemented for outpout") + else + call MAPL_MakeDecomposition(nx,ny,_RC) + call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) + call MAPL_ConfigSetAttribute(cf,value="LatLon", label=trim(grid_name)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cf,value=jm_world,label=trim(grid_name)//".JM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) + call MAPL_ConfigSetAttribute(cf,value=pole, label=trim(grid_name)//".POLE:",_RC) + call MAPL_ConfigSetAttribute(cf,value=dateline, label=trim(grid_name)//".DATELINE:",_RC) + if (pole=='XY' .and. dateline=='XY') then + _FAIL("regional lat-lon output not supported") + end if + end if + + new_grid = grid_manager%make_grid(cf,prefix=trim(grid_name)//".",_RC) + if (present(rc)) then + rc=_SUCCESS + end if + end function create_output_grid + + subroutine get_file_levels(filename,vertical_data,rc) + character(len=*), intent(in) :: filename + type(VerticalData), intent(inout) :: vertical_data + integer, intent(out), optional :: rc + + integer :: status + type(NetCDF4_fileFormatter) :: formatter + type(FileMetadata) :: basic_metadata + type(FileMetadataUtils) :: metadata + character(len=:), allocatable :: lev_name + character(len=ESMF_MAXSTR) :: long_name + character(len=ESMF_MAXSTR) :: standard_name + character(len=ESMF_MAXSTR) :: vcoord + character(len=ESMF_MAXSTR) :: lev_units + real, allocatable, target :: levs(:) + real, pointer :: plevs(:) + + call formatter%open(trim(filename),pFIO_Read,_RC) + basic_metadata=formatter%read(_RC) + call metadata%create(basic_metadata,trim(filename)) + lev_name = metadata%get_level_name(_RC) + if (lev_name /= '') then + call metadata%get_coordinate_info(lev_name,coords=levs,coordUnits=lev_units,long_name=long_name,& + standard_name=standard_name,coordinate_attr=vcoord,_RC) + plevs => levs + vertical_data = VerticalData(levels=plevs,vunit=lev_units,vcoord=vcoord,standard_name=standard_name,long_name=long_name, & + force_no_regrid=.true.,_RC) + nullify(plevs) + end if + + if (present(rc)) then + rc=_SUCCESS + end if + + end subroutine get_file_levels + + function has_level(grid,rc) result(grid_has_level) + logical :: grid_has_level + type(ESMF_Grid), intent(in) :: grid + integer, intent(out), optional :: rc + integer :: status, global_dims(3) + call MAPL_GridGet(grid,globalCellCountPerDim=global_dims,_RC) + grid_has_level = (global_dims(3)>1) + if (present(rc)) then + RC=_SUCCESS + end if + end function has_level + + subroutine copy_bundle_to_bundle(input_bundle,output_bundle,rc) + type(ESMF_FieldBundle), intent(inout) :: input_bundle + type(ESMF_FieldBundle), intent(inout) :: output_bundle + integer, intent(out), optional :: rc + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: i,num_fields + call ESMF_FieldBundleGet(input_bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + call ESMF_FieldBundleGet(input_bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(input_bundle,field_list(i),field=field,_RC) + call MAPL_FieldBundleAdd(output_bundle,field,_RC) + enddo + if (present(rc)) then + RC=_SUCCESS + end if + end subroutine copy_bundle_to_bundle + + subroutine add_new_field_to_bundle(bundle,grid,lm,field_name,long_name,units,rc) + type(ESMF_FieldBundle), intent(inout) :: bundle + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: lm + character(len=*), intent(in) :: field_name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + integer, intent(out), optional :: rc + + integer :: status + type(ESMF_Field) :: field + + if (lm == 0) then + field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4,_RC) + else if (lm > 0) then + field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4, & + ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + end if + call ESMF_AttributeSet(field,name='LONG_NAME',value=trim(long_name),_RC) + call ESMF_AttributeSet(field,name='UNITS',value=trim(units),_RC) + if (lm == 0) then + call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzOnly,_RC) + call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationNone,_RC) + else if (lm > 0) then + call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzVert,_RC) + call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationCenter,_RC) + end if + call MAPL_FieldBundleAdd(bundle,field,_RC) + if (present(rc)) then + RC=_SUCCESS + end if + end subroutine add_new_field_to_bundle + + subroutine get_file_times(file_metadata,num_times,time_series,time_interval,yymmdd,hhmmss,rc) + type(FileMetadataUtils), intent(inout) :: file_metadata + integer, intent(out) :: num_times + type(ESMF_Time), allocatable, intent(inout) :: time_series(:) + integer, intent(inout), allocatable :: yymmdd(:) + integer, intent(inout), allocatable :: hhmmss(:) + integer, intent(out) :: time_interval + integer, intent(out), optional :: rc + + integer :: status + type(ESMF_TimeInterval) :: esmf_time_interval + integer :: hour, minute, second, year, month, day, i + + num_times = file_metadata%get_dimension('time',_RC) + call file_metadata%get_time_info(timeVector=time_series,_RC) + if (num_times == 1) then + time_interval = file_metadata%get_var_attr_int32('time','time_increment',_RC) + else if (num_times > 1) then + esmf_time_interval = time_series(2)-time_series(1) + call ESMF_TimeIntervalGet(esmf_time_interval,h=hour,m=minute,s=second,_RC) + time_interval = hour*10000+minute*100+second + end if + + allocate(yymmdd(num_times),hhmmss(num_times)) + do i = 1,num_times + call ESMF_TimeGet(time_series(i),yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) + yymmdd(i)=year*10000+month*100+day + hhmmss(i)=hour*10000+minute*100+second + enddo + if (present(rc)) then + rc=_SUCCESS + end if + end subroutine get_file_times + + function get_level_info(bundle,rc) result(kmvar) + integer, allocatable :: kmvar(:) + type(ESMF_FieldBundle), intent(in) :: bundle + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: rank,i,num_fields,lb(1),ub(1) + call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + allocate(kmvar(num_fields)) + call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) + call ESMF_FieldGet(field,rank=rank,_RC) + if (rank==2) then + kmvar(i)=0 + else if (rank==3) then + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + kmvar(i)=ub(1)-lb(1)+1 + else + _FAIL("Unsupported rank") + end if + end do + if (present(rc)) then + RC=_SUCCESS + end if + end function get_level_info + + function get_long_names(bundle,rc) result(long_names) + character(len=ESMF_MAXSTR), allocatable :: long_names(:) + type(ESMF_FieldBundle), intent(in) :: bundle + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: i,num_fields + + call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + allocate(long_names(num_fields)) + call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) + call ESMF_AttributeGet(field,name='LONG_NAME',value=long_names(i),_RC) + enddo + if (present(rc)) then + RC=_SUCCESS + end if + end function get_long_names + + function get_units(bundle,rc) result(units) + character(len=ESMF_MAXSTR), allocatable :: units(:) + type(ESMF_FieldBundle), intent(in) :: bundle + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: i,num_fields + + call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + allocate(units(num_fields)) + call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) + call ESMF_AttributeGet(field,name='UNITS',value=units(i),_RC) + enddo + if (present(rc)) then + RC=_SUCCESS + end if + end function get_units + + function local_esmf_timeset(yymmdd,hhmmss,rc) result(etime) + type(ESMF_Time) :: etime + integer, intent(in) :: yymmdd + integer, intent(in) :: hhmmss + integer, intent(out), optional :: rc + + integer :: year,month,day,hour,minute,second,status + year = yymmdd/10000 + month = mod(yymmdd/100,100) + day = mod(yymmdd,100) + + hour = hhmmss/10000 + minute = mod(hhmmss/100,100) + second = mod(hhmmss,100) + + call ESMF_TimeSet(etime,yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) + if (present(rc)) then + rc=_SUCCESS + endif + end function local_esmf_timeset + + function defined ( q,undef ) + implicit none + logical defined + real q,undef + defined = q /= undef + end function defined + + subroutine latlon_zstar (q,qp,undef,grid,rc) + real, intent(inout) :: q(:,:) + real, intent(out) :: qp(:,:) + real, intent(in) :: undef + type (ESMF_Grid), intent(inout) :: grid + integer, optional, intent(out) :: rc + + integer :: local_dims(3) + integer im,jm,i,j,status + real, allocatable :: qz(:) + + call MAPL_GridGet(grid,localCellCountPerDim=local_dims,_RC) + im = local_dims(1) + jm = local_dims(2) + allocate(qz(jm)) + + call latlon_zmean ( q,qz,undef,grid ) + do j=1,jm + if( qz(j).eq. undef ) then + qp(:,j) = undef + else + do i=1,im + if( defined( q(i,j),undef) ) then + qp(i,j) = q(i,j) - qz(j) + else + qp(i,j) = undef + endif + enddo + endif + enddo + if (present(rc)) then + rc=_SUCCESS + endif + end subroutine latlon_zstar + + subroutine latlon_zmean ( q,qz,undef,grid,rc) + real, intent(inout) :: q(:,:) + real, intent(inout) :: qz(:) + real, intent(in) :: undef + type(ESMF_Grid), intent(inout) :: grid + integer, optional, intent(out) :: rc + + integer :: im,jm,im_global,jm_global,local_dims(3),global_dims(3),status,nx,ny + real, allocatable :: qg(:,:) + real, allocatable :: buf(:,:) + real :: qsum + integer :: mpistatus(mpi_status_size) + integer, allocatable :: ims(:),jms(:) + integer j,n,peid,peid0,i1,j1,in,jn,mypet,i_start,i_end,isum + type(ESMF_VM) :: vm + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,localPet=mypet,_RC) + call MAPL_GridGet(grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) + im = local_dims(1) + jm = local_dims(2) + im_global = global_dims(1) + jm_global = global_dims(2) + call get_esmf_grid_layout(grid,nx,ny,ims,jms,_RC) + call mapl_grid_interior(grid,i1,in,j1,jn) + + qz = 0.0 + allocate( qg(im_global,jm) ) + peid0 = (mypet/nx)*ny + if (i1==1) then + i_start = 1 + i_end = ims(1) + qg(i_start:i_end,:)=q + do n=1,nx-1 + allocate(buf(ims(n+1),jm)) + peid = mypet + n + call mpi_recv(buf,ims(n+1)*jm,MPI_FLOAT,peid,peid,MPI_COMM_WORLD,mpistatus,status) + _VERIFY(status) + i_start=i_end+1 + i_end = i_start+ims(n)-1 + qg(i_start:i_end,:)=buf + deallocate(buf) + enddo + else + call mpi_send(q,im*jm,MPI_FLOAT,peid0,mypet,MPI_COMM_WORLD,status) + _VERIFY(status) + end if + +! compute zonal mean + if (i1 == 1) then + do j=1,jm + isum = count(qg(:,j) /= undef) + qsum = sum(qg(:,j),mask=qg(:,j)/=undef) + if (isum == 0) then + qz(j)=undef + else + qz(j)=qsum/real(isum) + end if + enddo + +! send mean back to other ranks + do n=1,nx-1 + peid = peid0+n + call mpi_send(qz,jm,MPI_FLOAT,peid,peid0,MPI_COMM_WORLD,status) + _VERIFY(status) + enddo + else + call mpi_recv(qz,jm,MPI_FLOAT,peid0,peid0,MPI_COMM_WORLD,mpistatus,status) + _VERIFY(status) + end if + + if (present(rc)) then + rc=_SUCCESS + endif + + end subroutine latlon_zmean + + subroutine get_esmf_grid_layout(grid,nx,ny,ims_out,jms_out,rc) + type(ESMF_Grid), intent(inout) :: grid + integer, intent(out) :: nx + integer, intent(out) :: ny + integer, intent(inout), allocatable :: ims_out(:) + integer, intent(inout), allocatable :: jms_out(:) + integer, optional, intent(out) :: rc + + type(ESMF_VM) :: vm + integer :: status + type(ESMF_DistGrid) :: dist_grid + integer, allocatable :: minindex(:,:),maxindex(:,:) + integer :: dim_count, ndes + integer, pointer :: ims(:),jms(:) + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,petCount=ndes,_RC) + call ESMF_GridGet(grid,distgrid=dist_grid,dimCOunt=dim_count,_RC) + allocate(minindex(dim_count,ndes),maxindex(dim_count,ndes)) + call MAPL_DistGridGet(dist_grid,minIndex=minindex,maxIndex=maxindex,_RC) + call MAPL_GetImsJms(minindex(1,:),maxindex(1,:),minindex(2,:),maxindex(2,:),ims,jms,_RC) + nx = size(ims) + ny = size(jms) + allocate(ims_out(nx),jms_out(ny)) + ims_out = ims + jms_out = jms + + if (present(rc)) then + rc=_SUCCESS + endif + + end subroutine get_esmf_grid_layout + + subroutine check_quad ( quad,vname,nvars,aliases,nalias,qloc ) + integer :: nvars, nalias + character(len=ESMF_MAXSTR) quad(2), aliases(2,nalias), vname(nvars) + integer qloc(2) + integer m,n + +! Initialize Location of Quadratics +! --------------------------------- + qloc = 0 + +! Check Quadratic Name against HDF Variable Names +! ----------------------------------------------- + do n=1,nvars + if( trim(vname(n)).eq.trim(quad(1)) ) qloc(1) = n + if( trim(vname(n)).eq.trim(quad(2)) ) qloc(2) = n + enddo + +! Check Quadratic Name against Aliases +! ------------------------------------ + do m=1,nalias + if( trim(quad(1)).eq.trim(aliases(1,m)) ) then + do n=1,nvars + if( trim(vname(n)).eq.trim(quad(1)) .or. & + trim(vname(n)).eq.trim(aliases(2,m)) ) then + qloc(1) = n + exit + endif + enddo + endif + if( trim(quad(2)).eq.trim(aliases(1,m)) ) then + do n=1,nvars + if( trim(vname(n)).eq.trim(quad(2)) .or. & + trim(vname(n)).eq.trim(aliases(2,m)) ) then + qloc(2) = n + exit + endif + enddo + endif + enddo + + end subroutine check_quad + + function compute_nsecf (nhms) result(seconds) + integer :: seconds + integer, intent(in) :: nhms + seconds = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) + end function compute_nsecf + + function compute_nhmsf (nsec) result(nhmsf) + integer :: nhmsf + integer, intent(in) :: nsec + nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) + end function compute_nhmsf + + subroutine tick (nymd,nhms,ndt) + integer, intent(inout) :: nymd + integer, intent(inout) :: nhms + integer, intent(in) :: ndt + + integer :: nsec + + if(ndt.ne.0) then + nsec = compute_nsecf(nhms) + ndt + + if (nsec.gt.86400) then + do while (nsec.gt.86400) + nsec = nsec - 86400 + nymd = compute_incymd (nymd,1) + enddo + endif + + if (nsec.eq.86400) then + nsec = 0 + nymd = compute_incymd (nymd,1) + endif + + if (nsec.lt.00000) then + do while (nsec.lt.0) + nsec = 86400 + nsec + nymd = compute_incymd (nymd,-1) + enddo + endif + + nhms = compute_nhmsf (nsec) + endif + + end subroutine tick + + function compute_incymd (nymd,m) result(incymd) + integer :: incymd + integer, intent(in) :: nymd + integer, intent(in) :: m +!*********************************************************************** +! purpose +! incymd: nymd changed by one day +! modymd: nymd converted to julian date +! description of parameters +! nymd current date in yymmdd format +! m +/- 1 (day adjustment) +! +!*********************************************************************** +!* goddard laboratory for atmospheres * +!*********************************************************************** + + integer ndpm(12) + data ndpm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ + integer :: ny,nm,nd +!*********************************************************************** +! + ny = nymd / 10000 + nm = mod(nymd,10000) / 100 + nd = mod(nymd,100) + m + + if (nd.eq.0) then + nm = nm - 1 + if (nm.eq.0) then + nm = 12 + ny = ny - 1 + endif + nd = ndpm(nm) + if (nm.eq.2 .and. is_leap_year(ny)) nd = 29 + endif + + if (nd.eq.29 .and. nm.eq.2 .and. is_leap_year(ny)) go to 20 + + if (nd.gt.ndpm(nm)) then + nd = 1 + nm = nm + 1 + if (nm.gt.12) then + nm = 1 + ny = ny + 1 + endif + endif + +20 continue + incymd = ny*10000 + nm*100 + nd + return + + end function compute_incymd + + logical function is_leap_year(year) + integer, intent(in) :: year + is_leap_year = (mod(year,4) == 0) .and. (mod(year,100) == 0 .or. mod(year,400) == 0) + end function is_leap_year + + subroutine usage(root) + logical, intent(in) :: root + integer :: status,errorcode + if(root) then + write(6,100) +100 format( "usage: ",/,/ & + " time_ave.x -hdf filenames (in hdf format)",/ & + " <-template template>" ,/ & + " <-tag tag>" ,/ & + " <-rc rcfile>" ,/ & + " <-ntod ntod>" ,/ & + " <-ntmin ntmin>" ,/ & + " <-strict strict>" ,/ & + " <-d>" ,/ & + " <-md>" ,/,/ & + "where:",/,/ & + " -hdf filenames: filenames (in hdf format) to average",/ & + " -template template: filename to use as template if hdf files differ (default: 1st filename)",/ & + " -begdate yyyymmdd: optional parameter for date to begin averaging",/ & + " -begtime hhmmss: optional parameter for time to begin averaging",/ & + " -enddate yyyymmdd: optional parameter for date to end averaging",/ & + " -endtime hhmmss: optional parameter for time to end averaging",/ & + " -tag tag: optional tag for output file (default: monthly_ave)",/ & + " -rc rcfile: optional resource filename for quadratics (default: no quadratics)",/ & + " -ntod ntod: optional time-of-day (hhmmss) to average (default: all time periods)",/ & + " -ntmin ntmin: optional parameter for required min. timeperiods (default: 10 days equiv)",/ & + " -strict strict: optional logical parameter for strict time testing (default: .true.)",/ & + " -d dtag: optional parameter to create & tag monthly mean diurnal file ", & + "(all times included)",/ & + " -md dtag: optional parameter to create & tag multiple monthly mean diurnal files ", & + "(one time per file)",/ & + " -dv dtag: like -d but includes diurnal variances",/ & + " -mdv dtag: like -md but includes diurnal variances",/ & + ) + endif + call MPI_Abort(MPI_COMM_WORLD,errorcode,status) + end subroutine usage + + subroutine generate_report() + + character(:), allocatable :: report_lines(:) + integer :: i + character(1) :: empty(0) + + reporter = ProfileReporter(empty) + call reporter%add_column(NameColumn(20)) + call reporter%add_column(FormattedTextColumn('Inclusive','(f9.6)', 9, InclusiveColumn('MEAN'))) + call reporter%add_column(FormattedTextColumn('% Incl','(f6.2)', 6, PercentageColumn(InclusiveColumn('MEAN'),'MAX'))) + call reporter%add_column(FormattedTextColumn('Exclusive','(f9.6)', 9, ExclusiveColumn('MEAN'))) + call reporter%add_column(FormattedTextColumn('% Excl','(f6.2)', 6, PercentageColumn(ExclusiveColumn('MEAN')))) + call reporter%add_column(FormattedTextColumn(' Max Excl)','(f9.6)', 9, ExclusiveColumn('MAX'))) + call reporter%add_column(FormattedTextColumn(' Min Excl)','(f9.6)', 9, ExclusiveColumn('MIN'))) + call reporter%add_column(FormattedTextColumn('Max PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MAX_PE'))) + call reporter%add_column(FormattedTextColumn('Min PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MIN_PE'))) + report_lines = reporter%generate_report(t_prof) + if (mapl_am_I_root()) then + write(*,'(a)')'Final profile' + write(*,'(a)')'=============' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + end if + end subroutine generate_report + + +end program time_ave diff --git a/Apps/time_ave_util.F90 b/Apps/time_ave_util.F90 deleted file mode 100644 index 7f0190788d30..000000000000 --- a/Apps/time_ave_util.F90 +++ /dev/null @@ -1,1743 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program time_ave - - use ESMF - use MAPL - use MAPL_FileMetadataUtilsMod - use gFTL_StringVector - use MPI - use, intrinsic :: iso_fortran_env, only: int32, int64, int16, real32, real64 - use ieee_arithmetic, only: isnan => ieee_is_nan - - implicit none - - integer comm,myid,npes,ierror - integer imglobal - integer jmglobal - logical root - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to create time-averaged HDF files **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - integer im,jm,lm - - integer nymd, nhms - integer nymd0,nhms0 - integer nymdp,nhmsp - integer nymdm,nhmsm - integer ntod, ndt, ntods - integer month, year - integer monthp, yearp - integer monthm, yearm - integer begdate, begtime - integer enddate, endtime - - integer id,rc,timeinc,timeid - integer ntime,nvars,ncvid,nvars2 - - character(len=ESMF_MAXSTR), allocatable :: fname(:) - character(len=ESMF_MAXSTR) template - character(len=ESMF_MAXSTR) name - character(len=ESMF_MAXSTR) ext - character(len=ESMF_MAXSTR) output, doutput, hdfile, rcfile - character(len=8) date0 - character(len=2) time0 - character(len=1) char - data output /'monthly_ave'/ - data rcfile /'NULL'/ - data doutput /'NULL'/ - data template/'NULL'/ - - integer n,m,nargs,L,nfiles,nv,km,mvars,mv,ndvars - - real plev,qming,qmaxg - real previous_undef,undef - real, allocatable :: lev(:) - integer, allocatable :: kmvar(:) , kmvar2(:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: nloc(:) - integer, allocatable :: iloc(:) - - character(len=ESMF_MAXSTR), allocatable :: vname(:), vname2(:) - character(len=ESMF_MAXSTR), allocatable :: vtitle(:), vtitle2(:) - character(len=ESMF_MAXSTR), allocatable :: vunits(:), vunits2(:) - - real, allocatable :: qmin(:) - real, allocatable :: qmax(:) - real, allocatable :: dumz1(:,:) - real, allocatable :: dumz2(:,:) - real, allocatable :: dum(:,:,:) - real(REAL64), allocatable :: q(:,:,:,:) - integer, allocatable :: ntimes(:,:,:,:) - - integer timinc,i,j,k,nmax,kbeg,kend,loc1,loc2 - integer nstar - logical tend, first, strict, diurnal, mdiurnal, lquad, ldquad - logical ignore_nan - data first /.true./ - data strict /.true./ - - type(ESMF_Config) :: config - - integer, allocatable :: qloc(:,:) - character(len=ESMF_MAXSTR), allocatable :: quadratics(:,:) - character(len=ESMF_MAXSTR), allocatable :: quadtmp(:,:) - character(len=ESMF_MAXSTR), allocatable :: aliases(:,:) - character(len=ESMF_MAXSTR), allocatable :: aliastmp(:,:) - character(len=ESMF_MAXSTR) name1, name2, name3, dummy - integer nquad - integer nalias - logical, allocatable :: lzstar(:) - - integer ntmin, ntcrit, nc - - type(FileMetadata) :: basic_metadata - type(FileMetadataUtils) :: file_metadata - type(NetCDF4_FileFormatter) :: file_handle - integer :: status - class(AbstractGridfactory), allocatable :: factory - type(ESMF_Grid) :: output_grid,input_grid - character(len=:), allocatable :: output_grid_name - integer :: global_dims(3), local_dims(3) - type(ESMF_Time), allocatable :: time_series(:) - type(ESMF_TIme) :: etime - type(ESMF_Clock) :: clock - type(ESMF_TimeInterval) :: time_interval - type(ESMF_FieldBundle) :: primary_bundle,final_bundle,diurnal_bundle - type(ESMF_Field) :: field - type(ServerManager) :: io_server - type(FieldBundleWriter) :: standard_writer, diurnal_writer - real(ESMF_KIND_R4), pointer :: ptr2d(:,:),ptr3d(:,:,:) - character(len=ESMF_MAXSTR) :: grid_type - logical :: allow_zonal_means - character(len=ESMF_MAXPATHLEN) :: arg_str - character(len=:), allocatable :: lev_name - character(len=ESMF_MAXSTR) :: lev_units - integer :: n_times - type(verticalData) :: vertical_data - logical :: file_has_lev - type(DistributedProfiler), target :: t_prof - type(ProfileReporter) :: reporter - -! ********************************************************************** -! **** Initialization **** -! ********************************************************************** - -!call timebeg ('main') - - call mpi_init ( ierror ) ; comm = mpi_comm_world - call mpi_comm_rank ( comm,myid,ierror ) - call mpi_comm_size ( comm,npes,ierror ) - call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,mpiCommunicator=MPI_COMM_WORLD, _RC) - call MAPL_Initialize(_RC) - t_prof = DistributedProfiler('time_ave_util',MpiTImerGauge(),MPI_COMM_WORLD) - call t_prof%start(_RC) - call io_server%initialize(MPI_COMM_WORLD,_RC) - root = myid.eq.0 - call ESMF_CalendarSetDefault(ESMF_CALKIND_GREGORIAN,_RC) - -! Read Command Line Arguments -! --------------------------- - begdate = -999 - begtime = -999 - enddate = -999 - endtime = -999 - ndt = -999 - ntod = -999 - ntmin = -999 - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage(root) - else - lquad = .TRUE. - ldquad = .FALSE. - diurnal = .FALSE. - mdiurnal = .FALSE. - ignore_nan = .FALSE. - do n=1,nargs - call get_command_argument(n,arg_str) - select case(trim(arg_str)) - case('-template') - call get_command_argument(n+1,template) - case('-tag') - call get_command_argument(n+1,output) - case('-rc') - call get_command_argument(n+1,rcfile) - case('-begdate') - call get_command_argument(n+1,arg_str) - read(arg_str,*)begdate - case('-begtime') - call get_command_argument(n+1,arg_str) - read(arg_str,*)begtime - case('-enddate') - call get_command_argument(n+1,arg_str) - read(arg_str,*)enddate - case('-endtime') - call get_command_argument(n+1,arg_str) - read(arg_str,*)endtime - case('-ntmin') - call get_command_argument(n+1,arg_str) - read(arg_str,*)ntmin - case('-ntod') - call get_command_argument(n+1,arg_str) - read(arg_str,*)ntod - case('-ndt') - call get_command_argument(n+1,arg_str) - read(arg_str,*)ndt - case('-strict') - call get_command_argument(n+1,arg_str) - read(arg_str,*)strict - case('-ogrid') - call get_command_argument(n+1,arg_str) - output_grid_name = trim(arg_str) - case('-noquad') - lquad = .FALSE. - case('-ignore_nan') - ignore_nan = .TRUE. - case('-d') - diurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-md') - mdiurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-dv') - ldquad = .true. - diurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-mdv') - ldquad = .true. - mdiurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-eta') - nfiles = 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - do while (char .ne. '-' .and. n+nfiles.ne.nargs) - nfiles = nfiles + 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - enddo - if (char.eq.'-') nfiles = nfiles-1 - allocate(fname(nfiles)) - do m=1,nfiles - call get_command_argument(n+m,fname(m)) - enddo - case('-hdf') - nfiles = 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - do while (char .ne. '-' .and. n+nfiles.ne.nargs) - nfiles = nfiles + 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - enddo - if (char.eq.'-') nfiles = nfiles-1 - allocate(fname(nfiles)) - do m=1,nfiles - call get_command_argument(n+m,fname(m)) - enddo - end select - enddo - end if - - if( (diurnal.or.mdiurnal) .and. trim(doutput).eq.'NULL' ) then - doutput = trim(output) // "_diurnal" - if( mdiurnal ) diurnal = .FALSE. - endif - - if (root .and. ignore_nan) print *,' ignore nan is true' - - -! Read RC Quadratics -! ------------------ - if( trim(rcfile).eq.'NULL' ) then - nquad = 0 - nalias = 0 - else - config = ESMF_ConfigCreate ( rc=rc ) - call ESMF_ConfigLoadFile ( config, trim(rcfile), rc=rc ) - call ESMF_ConfigFindLabel ( config, 'QUADRATICS:', rc=rc ) - tend = .false. - m = 0 - do while (.not.tend) - m = m+1 - allocate( quadtmp(3,m) ) - call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name3,default='XXX',rc=rc ) - call ESMF_ConfigNextLine ( config,tableEnd=tend, rc=rc ) - if( m==1 ) then - quadtmp(1,m) = name1 - quadtmp(2,m) = name2 - quadtmp(3,m) = name3 - allocate( quadratics(3,m) ) - quadratics = quadtmp - else - quadtmp(1,1:m-1) = quadratics(1,:) - quadtmp(2,1:m-1) = quadratics(2,:) - quadtmp(3,1:m-1) = quadratics(3,:) - quadtmp(1,m) = name1 - quadtmp(2,m) = name2 - quadtmp(3,m) = name3 - deallocate( quadratics ) - allocate( quadratics(3,m) ) - quadratics = quadtmp - endif - deallocate (quadtmp) - enddo - nquad = m - -! Read RC Aliases -! --------------- - call ESMF_ConfigFindLabel ( config, 'ALIASES:', rc=rc ) - tend = .false. - m = 0 - do while (.not.tend) - m = m+1 - allocate( aliastmp(2,m) ) - call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) - call ESMF_ConfigNextLine ( config,tableEnd=tend ,rc=rc ) - if( m==1 ) then - aliastmp(1,m) = name1 - aliastmp(2,m) = name2 - allocate( aliases(2,m) ) - aliases = aliastmp - else - aliastmp(1,1:m-1) = aliases(1,:) - aliastmp(2,1:m-1) = aliases(2,:) - aliastmp(1,m) = name1 - aliastmp(2,m) = name2 - deallocate( aliases ) - allocate( aliases(2,m) ) - aliases = aliastmp - endif - deallocate (aliastmp) - enddo - nalias = m - endif - if (.not. allocated(aliases)) allocate(aliases(0,0)) - -! ********************************************************************** -! **** Read HDF File **** -! ********************************************************************** - - call t_prof%start('initialize') - - if( trim(template).ne.'NULL' ) then - name = template - else - name = fname(1) - endif - - n = index(trim(name),'.',back=.true.) - ext = trim(name(n+1:)) - - call file_handle%open(trim(name),PFIO_READ,_RC) - basic_metadata = file_handle%read(_RC) - call file_handle%close(_RC) - - allocate(factory, source=grid_manager%make_factory(trim(name))) - input_grid = grid_manager%make_grid(factory) - file_has_lev = has_level(input_grid,_RC) - call MAPL_GridGet(input_grid,globalCellCountPerDim=global_dims,_RC) - lm = global_dims(3) - - if (file_has_lev) then - call get_file_levels(trim(name),vertical_data,_RC) - end if - - if (allocated(output_grid_name)) then - output_grid = create_output_grid(output_grid_name,lm,_RC) - else - output_grid = input_grid - end if - call ESMF_AttributeGet(output_grid,'GridType',grid_type,_RC) - allow_zonal_means = trim(grid_type) == 'LatLon' - if (trim(grid_type) == "Cubed-Sphere") then - _ASSERT(mod(npes,6)==0,"If input files are Cubed-Sphere, must be run on multiple of 6 proccessors") - end if - call MAPL_GridGet(output_grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) - im = local_dims(1) - jm = local_dims(2) - lm = local_dims(3) - imglobal = global_dims(1) - jmglobal = global_dims(2) - - call file_metadata%create(basic_metadata,trim(name)) - call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) - primary_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) - call ESMF_FieldBundleSet(primary_bundle,grid=output_grid,_RC) - call MAPL_Read_Bundle(primary_bundle,trim(name),time=time_series(1),_RC) - call ESMF_FieldBundleGet(primary_bundle,fieldCount=nvars,_RC) - allocate(vname(nvars)) - call ESMF_FieldBundleGet(primary_bundle,fieldNameList=vname,_RC) - kmvar = get_level_info(primary_bundle,_RC) - vtitle = get_long_names(primary_bundle,_RC) - vunits = get_units(primary_bundle,_RC) - - final_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) - call ESMF_FieldBundleSet(final_bundle,grid=output_grid,_RC) - diurnal_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) - call ESMF_FieldBundleSet(diurnal_bundle,grid=output_grid,_RC) - call copy_bundle_to_bundle(primary_bundle,final_bundle,_RC) - - if (size(time_series)>1) then - time_interval = time_series(2) - time_series(1) - else if (size(time_series)==1) then - call ESMF_TimeIntervalSet(time_interval,h=6,_RC) - end if - clock = ESMF_ClockCreate(startTime=time_series(1),timeStep=time_interval,_RC) - - nvars2 = nvars - - if (file_has_lev) then - lev_name = file_metadata%get_level_name(_RC) - call file_metadata%get_coordinate_info(lev_name,coords=lev,coordUnits=lev_units,_RC) - end if - - previous_undef = file_metadata%var_get_missing_value(trim(vname(1)),_RC) - do i=2,size(vname) - undef = file_metadata%var_get_missing_value(trim(vname(i)),_RC) - _ASSERT(undef == previous_undef,"conflicting undefined values in your variables") - previous_undef = undef - enddo - undef = previous_undef - - -! Set NDT for Strict Time Testing -! ------------------------------- - if( ntod.ne.-999 ) ndt = 86400 - if( ndt .eq.-999 ) ndt = compute_nsecf (timinc) - if( timinc .eq. 0 ) then - timeId = ncvid (id, 'time', rc) - call ncagt (id, timeId, 'time_increment', timinc, rc) - if( timinc .eq. 0 ) then - if( root ) then - print * - print *, 'Warning, GFIO Inquire states TIMINC = ',timinc - print *, ' This will be reset to 060000 ' - print *, ' Use -ndt NNN (in seconds) to overide this' - endif - timinc = 060000 - endif - ndt = compute_nsecf (timinc) - endif - -! Determine Number of Time Periods within 1-Day -! --------------------------------------------- - ntods = 0 - if( diurnal .or. mdiurnal ) then - if( ndt.lt.86400 ) ntods = 86400/ndt - endif - -! Set Minimum Required Times for Time Average (Default: 10 Days for Monthly Mean) -! ------------------------------------------------------------------------------- - if( ntmin.eq.-999 ) then - if( ntod.eq.-999 ) then - ntcrit = 10 * ( 86400.0/real(compute_nsecf(timinc)) ) - else - ntcrit = 10 - endif - else - ntcrit = ntmin - endif - -! Determine Location Index for Each Variable in File -! -------------------------------------------------- - if( root ) print * - allocate ( nloc(nvars) ) - nloc(1) = 1 - if( root ) write(6,7000) 1,trim(vname(1)),nloc(1),trim(vtitle(1)),max(1,kmvar(1)) - do n=2,nvars - nloc(n) = nloc(n-1)+max(1,kmvar(n-1)) - if( root ) write(6,7000) n,trim(vname(n)),nloc(n),trim(vtitle(n)),max(1,kmvar(n)) -7000 format(1x,'Primary Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a40,2x,i2,3x,i2,3x,i2) - enddo - - nmax = nloc(nvars)+max(1,kmvar(nvars))-1 - allocate( dum (im,jm,nmax) ) - allocate( dumz1(im,jm) ) - allocate( dumz2(im,jm) ) - -! Append Default Quadratics to User-Supplied List -! ----------------------------------------------- - if( lquad ) then - if( nquad.eq.0 ) then - allocate( quadratics(3,nvars) ) - do n=1,nvars - quadratics(1,n) = trim( vname(n) ) - quadratics(2,n) = trim( vname(n) ) - quadratics(3,n) = 'XXX' - enddo - nquad = nvars - else - allocate( quadtmp(3,nquad+nvars) ) - quadtmp(1,1:nquad) = quadratics(1,:) - quadtmp(2,1:nquad) = quadratics(2,:) - quadtmp(3,1:nquad) = quadratics(3,:) - do n=1,nvars - quadtmp(1,nquad+n) = trim( vname(n) ) - quadtmp(2,nquad+n) = trim( vname(n) ) - quadtmp(3,nquad+n) = 'XXX' - enddo - nquad = nquad + nvars - deallocate( quadratics ) - allocate( quadratics(3,nquad) ) - quadratics = quadtmp - deallocate( quadtmp ) - endif - endif - - allocate ( qloc(2,nquad) ) - allocate ( lzstar(nquad) ) ; lzstar = .FALSE. - -! Determine Possible Quadratics -! ----------------------------- - km=kmvar(nvars) - m= nvars - do n=1,nquad - call check_quad ( quadratics(1,n),vname,nvars,aliases,nalias,qloc(1,n) ) - if( qloc(1,n)*qloc(2,n).ne.0 ) then - m=m+1 - allocate ( iloc(m) ) - iloc(1:m-1) = nloc - iloc(m) = iloc(m-1)+max(1,km) - deallocate ( nloc ) - allocate ( nloc(m) ) - nloc = iloc - deallocate ( iloc ) - km=kmvar( qloc(1,n) ) - endif - enddo - - mvars = m - nmax = nloc(m)+max(1,km)-1 - - allocate ( vname2( mvars) ) - allocate ( vtitle2( mvars) ) - allocate ( vunits2( mvars) ) - allocate ( kmvar2( mvars) ) - - vname2( 1:nvars) = vname - vtitle2( 1:nvars) = vtitle - vunits2( 1:nvars) = vunits - kmvar2( 1:nvars) = kmvar - - if( root .and. mvars.gt.nvars ) print * - mv= nvars - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv = mv+1 - - if( trim(quadratics(1,nv)).eq.trim(quadratics(2,nv)) ) then - vname2(mv) = "Var_" // trim(vname(qloc(1,nv))) - vtitle2(mv) = "Variance_of_" // trim(vname(qloc(1,nv))) - else - vname2(mv) = "Cov_" // trim(vname(qloc(1,nv))) // "_" // trim(vname(qloc(2,nv))) - vtitle2(mv) = "Covariance_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) - endif - - if( trim(quadratics(3,nv)).ne.'XXX' ) vname2(mv) = trim(quadratics(3,nv)) - - nstar = index( trim(quadratics(1,nv)),'star',back=.true. ) - if( nstar.ne.0 ) then - _ASSERT(allow_zonal_means,"grid is not lat-lon so cannot compute zonal means") - lzstar(nv) = .TRUE. - vtitle2(mv) = "Product_of_Zonal_Mean_Deviations_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) - endif - - vunits2(mv) = trim(vunits(qloc(1,nv))) // " " // trim(vunits(qloc(2,nv))) - kmvar2(mv) = kmvar(qloc(1,nv)) - - call add_new_field_to_bundle(final_bundle,output_grid,kmvar(qloc(1,nv)),vname2(mv),vtitle2(mv),vunits2(mv),_RC) - - if( root ) write(6,7001) mv,trim(vname2(mv)),nloc(mv),trim(vtitle2(mv)),max(1,kmvar(qloc(1,nv))),qloc(1,nv),qloc(2,nv) -7001 format(1x,' Quad Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a50,2x,i2,3x,i3,3x,i3) - endif - enddo - -!deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - - allocate( qmin(nmax) ) - allocate( qmax(nmax) ) - allocate( q(im,jm,nmax,0:ntods) ) - allocate( ntimes(im,jm,nmax,0:ntods) ) - ntimes = 0 - q = 0 - qmin = abs(undef) - qmax = -abs(undef) - - if( root ) then - print * - write(6,7002) mvars,nmax,im,jm,nmax,ntods -7002 format(1x,'Total Number of Variables: ',i3,/ & - 1x,'Total Size: ',i5,/ & - 1x,'Allocating q(',i4,',',i3,',',i5,',0:',i2.2,')') - print * - print *, 'Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - if( ntod.eq.-999 ) then - print *, 'Averging Time-Period NHMS: ',ntod,' (ALL Possible Time Periods Used)' - else - print *, 'Averging Time-Period NHMS: ',ntod - endif - if( begdate.ne.-999 .or. begtime.ne.-999 ) print *, 'Beginning Date for Averaging: ',begdate,begtime - if( enddate.ne.-999 .or. endtime.ne.-999 ) print *, ' Ending Date for Averaging: ',enddate,endtime - if( strict ) then - print *, 'Every Time Period Required for Averaging, STRICT = ',strict - else - print *, 'Only Averaging Time Periods Supplied, STRICT = ',strict - endif - write(6,7003) ntcrit -7003 format(1x,'Required Minimum Number of Defined Time Periods: ',i3,' (Otherwise, UNDEF)') - print * - endif - - call t_prof%stop('initialize') - -! ********************************************************************** -! **** Read HDF Files **** -! ********************************************************************** - - k = 0 - - do n=1,nfiles - - if (allocated(time_series)) deallocate(time_series) - if (allocated(yymmdd)) deallocate(yymmdd) - if (allocated(hhmmss)) deallocate(hhmmss) - call file_handle%open(trim(fname(n)),PFIO_READ,_RC) - basic_metadata = file_handle%read(_RC) - call file_handle%close(_RC) - call file_metadata%create(basic_metadata,trim(fname(n))) - call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) - - - do m=1,ntime - nymd = yymmdd(m) - nhms = hhmmss(m) - if( nhms<0 ) then - nhms = compute_nhmsf( compute_nsecf(nhms) + 86400 ) - call tick (nymd,nhms,-86400) - endif - - if( ( begdate.ne.-999 .and. begtime.ne.-999 ) .and. & - ( begdate.gt.nymd .or. & - ( begdate.eq.nymd.and.begtime.gt.nhms ) ) ) cycle - - if( ( enddate.ne.-999 .and. endtime.ne.-999 ) .and. & - ( enddate.lt.nymd .or. & - ( enddate.eq.nymd.and.endtime.lt.nhms ) ) ) cycle - - k = k+1 - if( k.gt.ntods ) k = 1 - if( ntod.eq.-999 .or. ntod.eq.nhms ) then - if( root ) write(6,3000) nymd,nhms,timinc,trim(fname(n)),k -3000 format(1x,'Reading nymd: ',i8.8,' nhms: ',i6.6,' TimInc: ',i6.6,' from File: ',a,' tod = ',i2) - year = nymd/10000 - month = mod(nymd,10000)/100 - -! Check for Correct First Dataset -! ------------------------------- - if( strict .and. first ) then - nymdm = nymd - nhmsm = nhms - call tick (nymdm,nhmsm,-ndt) - yearm = nymdm/10000 - monthm = mod(nymdm,10000)/100 - if( year.eq.yearm .and. month.eq.monthm ) then - if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct First Time Period!' - _FAIL("error processing dataset") - endif - endif - -! Check Date and Time for STRICT Time Testing -! ------------------------------------------- - if( strict .and. .not.first ) then - if( nymd.ne.nymdp .or. nhms.ne.nhmsp ) then - if( root ) print *, 'Date: ',nymdp,' Time: ',nhmsp,' not found!' - _FAIL("error processing dataset") - endif - endif - nymdp = nymd - nhmsp = nhms - -! Primary Fields -! -------------- - - etime = local_esmf_timeset(nymd,nhms,_RC) - call MAPL_Read_Bundle(primary_bundle,trim(fname(1)),time=etime,file_override=trim(fname(n)),_RC) - do nv=1,nvars2 - call ESMF_FieldBundleGet(primary_bundle,trim(vname2(nv)),field=field,_RC) - call t_prof%start('PRIME') - if( kmvar2(nv).eq.0 ) then - kbeg = 0 - kend = 1 - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - dum(:,:,nloc(nv))=ptr2d - else - kbeg = 1 - kend = kmvar2(nv) - - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - dum(:,:,nloc(nv):nloc(nv)+kmvar2(nv)-1) = ptr3d - endif - - rc = 0 - do L=1,max(1,kmvar2(nv)) - do j=1,jm - do i=1,im - if( isnan( dum(i,j,nloc(nv)+L-1) ) .or. ( dum(i,j,nloc(nv)+L-1).gt.HUGE(dum(i,j,nloc(nv)+L-1)) ) ) then -!print *, 'Warning! Nan or Infinity detected for ',trim(vname2(nv)),' at lat: ',lattice%jglobal(j),' lon: ',lattice%iglobal(i) - if( root .and. ignore_nan ) then - print *, 'Setting Nan or Infinity to UNDEF' - print * - else - rc = 1 - endif - dum(i,j,nloc(nv)+L-1) = undef - endif - if( defined(dum(i,j,nloc(nv)+L-1),undef) ) then - q(i,j,nloc(nv)+L-1,0) = q(i,j,nloc(nv)+L-1,0) + dum(i,j,nloc(nv)+L-1) - ntimes(i,j,nloc(nv)+L-1,0) = ntimes(i,j,nloc(nv)+L-1,0) + 1 - if( qmin(nloc(nv)+L-1).gt.dum(i,j,nloc(nv)+L-1) ) qmin(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) - if( qmax(nloc(nv)+L-1).lt.dum(i,j,nloc(nv)+L-1) ) qmax(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) - if( ntods.ne.0 ) then - q(i,j,nloc(nv)+L-1,k) = q(i,j,nloc(nv)+L-1,k) + dum(i,j,nloc(nv)+L-1) - ntimes(i,j,nloc(nv)+L-1,k) = ntimes(i,j,nloc(nv)+L-1,k) + 1 - endif - endif - enddo - enddo - enddo - call t_prof%stop('PRIME') - - enddo - -! Quadratics -! ---------- - call t_prof%start('QUAD') - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - do L=1,max(1,kmvar2(qloc(1,nv))) - if( lzstar(nv) ) then - call latlon_zstar (dum(:,:,nloc(qloc(1,nv))+L-1),dumz1,undef,output_grid,_RC) - call latlon_zstar (dum(:,:,nloc(qloc(2,nv))+L-1),dumz2,undef,output_grid,_RC) - do j=1,jm - do i=1,im - if( defined(dumz1(i,j),undef) .and. & - defined(dumz2(i,j),undef) ) then - q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dumz1(i,j)*dumz2(i,j) - ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 - if( ntods.ne.0 ) then - q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dumz1(i,j)*dumz2(i,j) - ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 - endif - endif - enddo - enddo - else - do j=1,jm - do i=1,im - if( defined(dum(i,j,nloc(qloc(1,nv))+L-1),undef) .and. & - defined(dum(i,j,nloc(qloc(2,nv))+L-1),undef) ) then - q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dum(i,j,nloc(qloc(1,nv))+L-1) & - * dum(i,j,nloc(qloc(2,nv))+L-1) - ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 - if( ntods.ne.0 ) then - q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dum(i,j,nloc(qloc(1,nv))+L-1) & - * dum(i,j,nloc(qloc(2,nv))+L-1) - ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 - endif - endif - enddo - enddo - endif - enddo - endif - enddo - call t_prof%stop('QUAD') - - if( first ) then - nymd0 = nymd - nhms0 = nhms - first = .false. - endif - -! Update Date and Time for Strict Test -! ------------------------------------ - call tick (nymdp,nhmsp,ndt) - yearp = nymdp/10000 - monthp = mod(nymdp,10000)/100 - - endif ! End ntod Test - enddo ! End ntime Loop within file - - call MPI_BARRIER(comm,status) - enddo - - do k=0,ntods - if( k.eq.0 ) then - nc = ntcrit - else - nc = max( 1,ntcrit/ntods ) - endif - do n=1,nmax - do j=1,jm - do i=1,im - if( ntimes(i,j,n,k).lt.nc ) then - q(i,j,n,k) = undef - else - q(i,j,n,k) = q(i,j,n,k)/ntimes(i,j,n,k) - endif - enddo - enddo - enddo - enddo - -! ********************************************************************** -! **** Write HDF Monthly Output File **** -! ********************************************************************** - -call t_prof%start('Write_AVE') - -! Check for Correct Last Dataset -! ------------------------------ - if( strict .and. ( year.eq.yearp .and. month.eq.monthp ) ) then - if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct Last Time Period!' - _FAIL("Error processing dataset") - endif - - write(date0,4000) nymd0/100 - write(time0,2000) nhms0/10000 - - hdfile = trim(output) // "." // trim(date0) // "." // trim(ext) - -1000 format(i8.8) -2000 format(i2.2) -4000 format(i6.6) - - timeinc = 060000 - -! Primary Fields -! -------------- - if( root ) print * - do n=1,nvars2 - call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) - if( kmvar2(n).eq.0 ) then - kbeg = 0 - kend = 1 - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = q(:,:,nloc(n),0) - else - kbeg = 1 - kend = kmvar2(n) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,0) - endif - if( root ) write(6,3001) trim(vname2(n)),nloc(n),trim(hdfile) -3001 format(1x,'Writing ',a,' at location ',i6,' into File: ',a) - dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,0) - enddo - -! Quadratics -! ---------- - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - if( root ) write(6,3001) trim(vname2(mv)),nloc(mv),trim(hdfile) - call ESMF_FieldBundleGet(final_bundle,trim(vname2(mv)),field=field,_RC) - - if( kmvar2(qloc(1,nv)).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(qloc(1,nv)) - endif - loc1 = nloc( qloc(1,nv) ) - loc2 = nloc( qloc(2,nv) ) - if( .not.lzstar(nv) ) then - where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - q(:,:,loc1:loc1+kend-1,0) & - * q(:,:,loc2:loc2+kend-1,0) - elsewhere - dum(:,:,1:kend) = undef - endwhere - else - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - endif - if( kmvar2(qloc(1,nv)).eq.0 ) then - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = dum(:,:,1) - else - kend = kmvar2(qloc(1,nv)) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = dum(:,:,1:kend) - endif - endif - enddo - - if( root ) then - print * - print *, 'Created: ',trim(hdfile) - print * - endif - call t_prof%stop('Write_AVE') - etime = local_esmf_timeset(nymd0,nhms0,_RC) - call ESMF_ClockSet(clock,currTime=etime, _RC) - call standard_writer%create_from_bundle(final_bundle,clock,n_steps=1,time_interval=timeinc,vertical_data=vertical_data,_RC) - call standard_writer%start_new_file(trim(hdfile),_RC) - call standard_writer%write_to_file(_RC) - -! ********************************************************************** -! **** Write HDF Monthly Diurnal Output File **** -! ********************************************************************** - - if( ntods.ne.0 ) then - call t_prof%start('Write_Diurnal') - timeinc = compute_nhmsf( 86400/ntods ) - - do k=1,ntods - - if( k.eq.1 .or. mdiurnal ) then - - write(date0,4000) nymd0/100 - write(time0,2000) nhms0/10000 - - if( diurnal ) hdfile = trim(doutput) // "." // trim(date0) // "." // trim(ext) - if( mdiurnal ) hdfile = trim(doutput) // "." // trim(date0) // "_" // trim(time0) // "z." // trim(ext) - - if( ldquad ) then - ndvars = mvars ! Include Quadratics in Diurnal Files - if (k==1) then - call copy_bundle_to_bundle(final_bundle,diurnal_bundle,_RC) - end if - else - ndvars = nvars2 ! Only Include Primary Fields in Diurnal Files (Default) - if (k==1) then - do n=1,nvars - call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) - call MAPL_FieldBundleAdd(diurnal_bundle,field,_RC) - enddo - endif - endif - endif - -! Primary Fields -! -------------- - do n=1,nvars2 - call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(n)),field=field,_RC) - if( kmvar2(n).eq.0 ) then - kbeg = 0 - kend = 1 - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = q(:,:,nloc(n),k) - else - kbeg = 1 - kend = kmvar2(n) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,k) - endif - dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,k) - enddo - -! Quadratics -! ---------- - if( ndvars.eq.mvars ) then - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(mv)),field=field,_RC) - if( kmvar2(qloc(1,nv)).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(qloc(1,nv)) - endif - loc1 = nloc( qloc(1,nv) ) - loc2 = nloc( qloc(2,nv) ) - if( .not.lzstar(nv) ) then - where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - q(:,:,loc1:loc1+kend-1,k) & - * q(:,:,loc2:loc2+kend-1,k) - elsewhere - dum(:,:,1:kend) = undef - endwhere - else - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - endif - if( kmvar2(qloc(1,nv)).eq.0 ) then - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = dum(:,:,1) - else - kend = kmvar2(qloc(1,nv)) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = dum(:,:,1:kend) - endif - endif - enddo - endif - - - etime = local_esmf_timeset(nymd0,nhms0,_RC) - call ESMF_ClockSet(clock,currTime=etime, _RC) - if (k==1 .or. mdiurnal) then - if (mdiurnal) then - n_times = 1 - else - n_times = ntods - end if - if (k==1) then - call diurnal_writer%create_from_bundle(diurnal_bundle,clock,n_steps=n_times,time_interval=timeinc,vertical_data=vertical_data) - end if - call diurnal_writer%start_new_file(trim(hdfile),_RC) - end if - call diurnal_writer%write_to_file(_RC) - if( root .and. mdiurnal ) then - print *, 'Created: ',trim(hdfile) - endif - call tick (nymd0,nhms0,ndt) - enddo - - if( root .and. diurnal ) then - print *, 'Created: ',trim(hdfile) - endif - if( root ) print * - - call t_prof%stop('Write_Diurnal') - endif - -! ********************************************************************** -! **** Write Min/Max Information **** -! ********************************************************************** - - if( root ) print * - do n=1,nvars2 - do L=1,max(1,kmvar2(n)) - if( kmvar2(n).eq.0 ) then - plev = 0 - else - plev = lev(L) - endif - - call mpi_reduce( qmin(nloc(n)+L-1),qming,1,mpi_real,mpi_min,0,comm,ierror ) - call mpi_reduce( qmax(nloc(n)+L-1),qmaxg,1,mpi_real,mpi_max,0,comm,ierror ) - if( root ) then - if(L.eq.1) then - write(6,3101) trim(vname2(n)),plev,qming,qmaxg - else - write(6,3102) trim(vname2(n)),plev,qming,qmaxg - endif - endif -3101 format(1x,'Primary Field: ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) -3102 format(1x,' ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) - enddo - call MPI_BARRIER(comm,status) - if( root ) print * - enddo - if( root ) print * - -! ********************************************************************** -! **** Timing Information **** -! ********************************************************************** - - call io_server%finalize() - call t_prof%stop() - call t_prof%reduce() - call t_prof%finalize() - call generate_report() - call MAPL_Finalize() - call MPI_Finalize(status) - stop - -contains - - function create_output_grid(grid_name,lm,rc) result(new_grid) - type(ESMF_Grid) :: new_grid - character(len=*), intent(inout) :: grid_name - integer, intent(in) :: lm - integer, optional, intent(out) :: rc - - type(ESMF_Config) :: cf - integer :: nn,im_world,jm_world,nx, ny - character(len=5) :: imsz,jmsz - character(len=2) :: pole,dateline - - nn = len_trim(grid_name) - imsz = grid_name(3:index(grid_name,'x')-1) - jmsz = grid_name(index(grid_name,'x')+1:nn-3) - pole = grid_name(1:2) - dateline = grid_name(nn-1:nn) - read(IMSZ,*) im_world - read(JMSZ,*) jm_world - - cf = MAPL_ConfigCreate(_RC) - call MAPL_ConfigSetAttribute(cf,value=lm, label=trim(grid_name)//".LM:",_RC) - if (dateline=='CF') then - call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) - call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) - call MAPL_ConfigSetAttribute(cf,value="Cubed-Sphere", label=trim(grid_name)//".GRID_TYPE:",_RC) - call MAPL_ConfigSetAttribute(cf,value=6, label=trim(grid_name)//".NF:",_RC) - call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) - call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) - else if (dateline=='TM') then - _FAIL("Tripolar not yet implemented for outpout") - else - call MAPL_MakeDecomposition(nx,ny,_RC) - call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) - call MAPL_ConfigSetAttribute(cf,value="LatLon", label=trim(grid_name)//".GRID_TYPE:",_RC) - call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) - call MAPL_ConfigSetAttribute(cf,value=jm_world,label=trim(grid_name)//".JM_WORLD:",_RC) - call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) - call MAPL_ConfigSetAttribute(cf,value=pole, label=trim(grid_name)//".POLE:",_RC) - call MAPL_ConfigSetAttribute(cf,value=dateline, label=trim(grid_name)//".DATELINE:",_RC) - if (pole=='XY' .and. dateline=='XY') then - _FAIL("regional lat-lon output not supported") - end if - end if - - new_grid = grid_manager%make_grid(cf,prefix=trim(grid_name)//".",_RC) - if (present(rc)) then - rc=_SUCCESS - end if - end function create_output_grid - - subroutine get_file_levels(filename,vertical_data,rc) - character(len=*), intent(in) :: filename - type(VerticalData), intent(inout) :: vertical_data - integer, intent(out), optional :: rc - - integer :: status - type(NetCDF4_fileFormatter) :: formatter - type(FileMetadata) :: basic_metadata - type(FileMetadataUtils) :: metadata - character(len=:), allocatable :: lev_name - character(len=ESMF_MAXSTR) :: long_name - character(len=ESMF_MAXSTR) :: standard_name - character(len=ESMF_MAXSTR) :: vcoord - character(len=ESMF_MAXSTR) :: lev_units - real, allocatable, target :: levs(:) - real, pointer :: plevs(:) - - call formatter%open(trim(filename),pFIO_Read,_RC) - basic_metadata=formatter%read(_RC) - call metadata%create(basic_metadata,trim(filename)) - lev_name = metadata%get_level_name(_RC) - if (lev_name /= '') then - call metadata%get_coordinate_info(lev_name,coords=levs,coordUnits=lev_units,long_name=long_name,& - standard_name=standard_name,coordinate_attr=vcoord,_RC) - plevs => levs - vertical_data = VerticalData(levels=plevs,vunit=lev_units,vcoord=vcoord,standard_name=standard_name,long_name=long_name, & - force_no_regrid=.true.,_RC) - nullify(plevs) - end if - - if (present(rc)) then - rc=_SUCCESS - end if - - end subroutine get_file_levels - - function has_level(grid,rc) result(grid_has_level) - logical :: grid_has_level - type(ESMF_Grid), intent(in) :: grid - integer, intent(out), optional :: rc - integer :: status, global_dims(3) - call MAPL_GridGet(grid,globalCellCountPerDim=global_dims,_RC) - grid_has_level = (global_dims(3)>1) - if (present(rc)) then - RC=_SUCCESS - end if - end function has_level - - subroutine copy_bundle_to_bundle(input_bundle,output_bundle,rc) - type(ESMF_FieldBundle), intent(inout) :: input_bundle - type(ESMF_FieldBundle), intent(inout) :: output_bundle - integer, intent(out), optional :: rc - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: i,num_fields - call ESMF_FieldBundleGet(input_bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - call ESMF_FieldBundleGet(input_bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(input_bundle,field_list(i),field=field,_RC) - call MAPL_FieldBundleAdd(output_bundle,field,_RC) - enddo - if (present(rc)) then - RC=_SUCCESS - end if - end subroutine copy_bundle_to_bundle - - subroutine add_new_field_to_bundle(bundle,grid,lm,field_name,long_name,units,rc) - type(ESMF_FieldBundle), intent(inout) :: bundle - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: lm - character(len=*), intent(in) :: field_name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: units - integer, intent(out), optional :: rc - - integer :: status - type(ESMF_Field) :: field - - if (lm == 0) then - field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4,_RC) - else if (lm > 0) then - field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4, & - ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - end if - call ESMF_AttributeSet(field,name='LONG_NAME',value=trim(long_name),_RC) - call ESMF_AttributeSet(field,name='UNITS',value=trim(units),_RC) - if (lm == 0) then - call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzOnly,_RC) - call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationNone,_RC) - else if (lm > 0) then - call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzVert,_RC) - call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationCenter,_RC) - end if - call MAPL_FieldBundleAdd(bundle,field,_RC) - if (present(rc)) then - RC=_SUCCESS - end if - end subroutine add_new_field_to_bundle - - subroutine get_file_times(file_metadata,num_times,time_series,time_interval,yymmdd,hhmmss,rc) - type(FileMetadataUtils), intent(inout) :: file_metadata - integer, intent(out) :: num_times - type(ESMF_Time), allocatable, intent(inout) :: time_series(:) - integer, intent(inout), allocatable :: yymmdd(:) - integer, intent(inout), allocatable :: hhmmss(:) - integer, intent(out) :: time_interval - integer, intent(out), optional :: rc - - integer :: status - type(ESMF_TimeInterval) :: esmf_time_interval - integer :: hour, minute, second, year, month, day, i - - num_times = file_metadata%get_dimension('time',_RC) - call file_metadata%get_time_info(timeVector=time_series,_RC) - if (num_times == 1) then - time_interval = file_metadata%get_var_attr_int32('time','time_increment',_RC) - else if (num_times > 1) then - esmf_time_interval = time_series(2)-time_series(1) - call ESMF_TimeIntervalGet(esmf_time_interval,h=hour,m=minute,s=second,_RC) - time_interval = hour*10000+minute*100+second - end if - - allocate(yymmdd(num_times),hhmmss(num_times)) - do i = 1,num_times - call ESMF_TimeGet(time_series(i),yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) - yymmdd(i)=year*10000+month*100+day - hhmmss(i)=hour*10000+minute*100+second - enddo - if (present(rc)) then - rc=_SUCCESS - end if - end subroutine get_file_times - - function get_level_info(bundle,rc) result(kmvar) - integer, allocatable :: kmvar(:) - type(ESMF_FieldBundle), intent(in) :: bundle - integer, optional, intent(out) :: rc - - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: rank,i,num_fields,lb(1),ub(1) - call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - allocate(kmvar(num_fields)) - call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) - call ESMF_FieldGet(field,rank=rank,_RC) - if (rank==2) then - kmvar(i)=0 - else if (rank==3) then - call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - kmvar(i)=ub(1)-lb(1)+1 - else - _FAIL("Unsupported rank") - end if - end do - if (present(rc)) then - RC=_SUCCESS - end if - end function get_level_info - - function get_long_names(bundle,rc) result(long_names) - character(len=ESMF_MAXSTR), allocatable :: long_names(:) - type(ESMF_FieldBundle), intent(in) :: bundle - integer, optional, intent(out) :: rc - - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: i,num_fields - - call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - allocate(long_names(num_fields)) - call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) - call ESMF_AttributeGet(field,name='LONG_NAME',value=long_names(i),_RC) - enddo - if (present(rc)) then - RC=_SUCCESS - end if - end function get_long_names - - function get_units(bundle,rc) result(units) - character(len=ESMF_MAXSTR), allocatable :: units(:) - type(ESMF_FieldBundle), intent(in) :: bundle - integer, optional, intent(out) :: rc - - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: i,num_fields - - call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - allocate(units(num_fields)) - call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) - call ESMF_AttributeGet(field,name='UNITS',value=units(i),_RC) - enddo - if (present(rc)) then - RC=_SUCCESS - end if - end function get_units - - function local_esmf_timeset(yymmdd,hhmmss,rc) result(etime) - type(ESMF_Time) :: etime - integer, intent(in) :: yymmdd - integer, intent(in) :: hhmmss - integer, intent(out), optional :: rc - - integer :: year,month,day,hour,minute,second,status - year = yymmdd/10000 - month = mod(yymmdd/100,100) - day = mod(yymmdd,100) - - hour = hhmmss/10000 - minute = mod(hhmmss/100,100) - second = mod(hhmmss,100) - - call ESMF_TimeSet(etime,yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) - if (present(rc)) then - rc=_SUCCESS - endif - end function local_esmf_timeset - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = q /= undef - end function defined - - subroutine latlon_zstar (q,qp,undef,grid,rc) - real, intent(inout) :: q(:,:) - real, intent(out) :: qp(:,:) - real, intent(in) :: undef - type (ESMF_Grid), intent(inout) :: grid - integer, optional, intent(out) :: rc - - integer :: local_dims(3) - integer im,jm,i,j,status - real, allocatable :: qz(:) - - call MAPL_GridGet(grid,localCellCountPerDim=local_dims,_RC) - im = local_dims(1) - jm = local_dims(2) - allocate(qz(jm)) - - call latlon_zmean ( q,qz,undef,grid ) - do j=1,jm - if( qz(j).eq. undef ) then - qp(:,j) = undef - else - do i=1,im - if( defined( q(i,j),undef) ) then - qp(i,j) = q(i,j) - qz(j) - else - qp(i,j) = undef - endif - enddo - endif - enddo - if (present(rc)) then - rc=_SUCCESS - endif - end subroutine latlon_zstar - - subroutine latlon_zmean ( q,qz,undef,grid,rc) - real, intent(inout) :: q(:,:) - real, intent(inout) :: qz(:) - real, intent(in) :: undef - type(ESMF_Grid), intent(inout) :: grid - integer, optional, intent(out) :: rc - - integer :: im,jm,im_global,jm_global,local_dims(3),global_dims(3),status,nx,ny - real, allocatable :: qg(:,:) - real, allocatable :: buf(:,:) - real :: qsum - integer :: mpistatus(mpi_status_size) - integer, allocatable :: ims(:),jms(:) - integer j,n,peid,peid0,i1,j1,in,jn,mypet,i_start,i_end,isum - type(ESMF_VM) :: vm - - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm,localPet=mypet,_RC) - call MAPL_GridGet(grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) - im = local_dims(1) - jm = local_dims(2) - im_global = global_dims(1) - jm_global = global_dims(2) - call get_esmf_grid_layout(grid,nx,ny,ims,jms,_RC) - call mapl_grid_interior(grid,i1,in,j1,jn) - - qz = 0.0 - allocate( qg(im_global,jm) ) - peid0 = (mypet/nx)*ny - if (i1==1) then - i_start = 1 - i_end = ims(1) - qg(i_start:i_end,:)=q - do n=1,nx-1 - allocate(buf(ims(n+1),jm)) - peid = mypet + n - call mpi_recv(buf,ims(n+1)*jm,MPI_FLOAT,peid,peid,MPI_COMM_WORLD,mpistatus,status) - _VERIFY(status) - i_start=i_end+1 - i_end = i_start+ims(n)-1 - qg(i_start:i_end,:)=buf - deallocate(buf) - enddo - else - call mpi_send(q,im*jm,MPI_FLOAT,peid0,mypet,MPI_COMM_WORLD,status) - _VERIFY(status) - end if - -! compute zonal mean - if (i1 == 1) then - do j=1,jm - isum = count(qg(:,j) /= undef) - qsum = sum(qg(:,j),mask=qg(:,j)/=undef) - if (isum == 0) then - qz(j)=undef - else - qz(j)=qsum/real(isum) - end if - enddo - -! send mean back to other ranks - do n=1,nx-1 - peid = peid0+n - call mpi_send(qz,jm,MPI_FLOAT,peid,peid0,MPI_COMM_WORLD,status) - _VERIFY(status) - enddo - else - call mpi_recv(qz,jm,MPI_FLOAT,peid0,peid0,MPI_COMM_WORLD,mpistatus,status) - _VERIFY(status) - end if - - if (present(rc)) then - rc=_SUCCESS - endif - - end subroutine latlon_zmean - - subroutine get_esmf_grid_layout(grid,nx,ny,ims_out,jms_out,rc) - type(ESMF_Grid), intent(inout) :: grid - integer, intent(out) :: nx - integer, intent(out) :: ny - integer, intent(inout), allocatable :: ims_out(:) - integer, intent(inout), allocatable :: jms_out(:) - integer, optional, intent(out) :: rc - - type(ESMF_VM) :: vm - integer :: status - type(ESMF_DistGrid) :: dist_grid - integer, allocatable :: minindex(:,:),maxindex(:,:) - integer :: dim_count, ndes - integer, pointer :: ims(:),jms(:) - - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm,petCount=ndes,_RC) - call ESMF_GridGet(grid,distgrid=dist_grid,dimCOunt=dim_count,_RC) - allocate(minindex(dim_count,ndes),maxindex(dim_count,ndes)) - call MAPL_DistGridGet(dist_grid,minIndex=minindex,maxIndex=maxindex,_RC) - call MAPL_GetImsJms(minindex(1,:),maxindex(1,:),minindex(2,:),maxindex(2,:),ims,jms,_RC) - nx = size(ims) - ny = size(jms) - allocate(ims_out(nx),jms_out(ny)) - ims_out = ims - jms_out = jms - - if (present(rc)) then - rc=_SUCCESS - endif - - end subroutine get_esmf_grid_layout - - subroutine check_quad ( quad,vname,nvars,aliases,nalias,qloc ) - integer :: nvars, nalias - character(len=ESMF_MAXSTR) quad(2), aliases(2,nalias), vname(nvars) - integer qloc(2) - integer m,n - -! Initialize Location of Quadratics -! --------------------------------- - qloc = 0 - -! Check Quadratic Name against HDF Variable Names -! ----------------------------------------------- - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(1)) ) qloc(1) = n - if( trim(vname(n)).eq.trim(quad(2)) ) qloc(2) = n - enddo - -! Check Quadratic Name against Aliases -! ------------------------------------ - do m=1,nalias - if( trim(quad(1)).eq.trim(aliases(1,m)) ) then - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(1)) .or. & - trim(vname(n)).eq.trim(aliases(2,m)) ) then - qloc(1) = n - exit - endif - enddo - endif - if( trim(quad(2)).eq.trim(aliases(1,m)) ) then - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(2)) .or. & - trim(vname(n)).eq.trim(aliases(2,m)) ) then - qloc(2) = n - exit - endif - enddo - endif - enddo - - end subroutine check_quad - - function compute_nsecf (nhms) result(seconds) - integer :: seconds - integer, intent(in) :: nhms - seconds = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - end function compute_nsecf - - function compute_nhmsf (nsec) result(nhmsf) - integer :: nhmsf - integer, intent(in) :: nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - end function compute_nhmsf - - subroutine tick (nymd,nhms,ndt) - integer, intent(inout) :: nymd - integer, intent(inout) :: nhms - integer, intent(in) :: ndt - - integer :: nsec - - if(ndt.ne.0) then - nsec = compute_nsecf(nhms) + ndt - - if (nsec.gt.86400) then - do while (nsec.gt.86400) - nsec = nsec - 86400 - nymd = compute_incymd (nymd,1) - enddo - endif - - if (nsec.eq.86400) then - nsec = 0 - nymd = compute_incymd (nymd,1) - endif - - if (nsec.lt.00000) then - do while (nsec.lt.0) - nsec = 86400 + nsec - nymd = compute_incymd (nymd,-1) - enddo - endif - - nhms = compute_nhmsf (nsec) - endif - - end subroutine tick - - function compute_incymd (nymd,m) result(incymd) - integer :: incymd - integer, intent(in) :: nymd - integer, intent(in) :: m -!*********************************************************************** -! purpose -! incymd: nymd changed by one day -! modymd: nymd converted to julian date -! description of parameters -! nymd current date in yymmdd format -! m +/- 1 (day adjustment) -! -!*********************************************************************** -!* goddard laboratory for atmospheres * -!*********************************************************************** - - integer ndpm(12) - data ndpm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - integer :: ny,nm,nd -!*********************************************************************** -! - ny = nymd / 10000 - nm = mod(nymd,10000) / 100 - nd = mod(nymd,100) + m - - if (nd.eq.0) then - nm = nm - 1 - if (nm.eq.0) then - nm = 12 - ny = ny - 1 - endif - nd = ndpm(nm) - if (nm.eq.2 .and. is_leap_year(ny)) nd = 29 - endif - - if (nd.eq.29 .and. nm.eq.2 .and. is_leap_year(ny)) go to 20 - - if (nd.gt.ndpm(nm)) then - nd = 1 - nm = nm + 1 - if (nm.gt.12) then - nm = 1 - ny = ny + 1 - endif - endif - -20 continue - incymd = ny*10000 + nm*100 + nd - return - - end function compute_incymd - - logical function is_leap_year(year) - integer, intent(in) :: year - is_leap_year = (mod(year,4) == 0) .and. (mod(year,100) == 0 .or. mod(year,400) == 0) - end function is_leap_year - - subroutine usage(root) - logical, intent(in) :: root - integer :: status,errorcode - if(root) then - write(6,100) -100 format( "usage: ",/,/ & - " time_ave.x -hdf filenames (in hdf format)",/ & - " <-template template>" ,/ & - " <-tag tag>" ,/ & - " <-rc rcfile>" ,/ & - " <-ntod ntod>" ,/ & - " <-ntmin ntmin>" ,/ & - " <-strict strict>" ,/ & - " <-d>" ,/ & - " <-md>" ,/,/ & - "where:",/,/ & - " -hdf filenames: filenames (in hdf format) to average",/ & - " -template template: filename to use as template if hdf files differ (default: 1st filename)",/ & - " -begdate yyyymmdd: optional parameter for date to begin averaging",/ & - " -begtime hhmmss: optional parameter for time to begin averaging",/ & - " -enddate yyyymmdd: optional parameter for date to end averaging",/ & - " -endtime hhmmss: optional parameter for time to end averaging",/ & - " -tag tag: optional tag for output file (default: monthly_ave)",/ & - " -rc rcfile: optional resource filename for quadratics (default: no quadratics)",/ & - " -ntod ntod: optional time-of-day (hhmmss) to average (default: all time periods)",/ & - " -ntmin ntmin: optional parameter for required min. timeperiods (default: 10 days equiv)",/ & - " -strict strict: optional logical parameter for strict time testing (default: .true.)",/ & - " -d dtag: optional parameter to create & tag monthly mean diurnal file ", & - "(all times included)",/ & - " -md dtag: optional parameter to create & tag multiple monthly mean diurnal files ", & - "(one time per file)",/ & - " -dv dtag: like -d but includes diurnal variances",/ & - " -mdv dtag: like -md but includes diurnal variances",/ & - ) - endif - call MPI_Abort(MPI_COMM_WORLD,errorcode,status) - end subroutine usage - - subroutine generate_report() - - character(:), allocatable :: report_lines(:) - integer :: i - character(1) :: empty(0) - - reporter = ProfileReporter(empty) - call reporter%add_column(NameColumn(20)) - call reporter%add_column(FormattedTextColumn('Inclusive','(f9.6)', 9, InclusiveColumn('MEAN'))) - call reporter%add_column(FormattedTextColumn('% Incl','(f6.2)', 6, PercentageColumn(InclusiveColumn('MEAN'),'MAX'))) - call reporter%add_column(FormattedTextColumn('Exclusive','(f9.6)', 9, ExclusiveColumn('MEAN'))) - call reporter%add_column(FormattedTextColumn('% Excl','(f6.2)', 6, PercentageColumn(ExclusiveColumn('MEAN')))) - call reporter%add_column(FormattedTextColumn(' Max Excl)','(f9.6)', 9, ExclusiveColumn('MAX'))) - call reporter%add_column(FormattedTextColumn(' Min Excl)','(f9.6)', 9, ExclusiveColumn('MIN'))) - call reporter%add_column(FormattedTextColumn('Max PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MAX_PE'))) - call reporter%add_column(FormattedTextColumn('Min PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MIN_PE'))) - report_lines = reporter%generate_report(t_prof) - if (mapl_am_I_root()) then - write(*,'(a)')'Final profile' - write(*,'(a)')'=============' - do i = 1, size(report_lines) - write(*,'(a)') report_lines(i) - end do - write(*,'(a)') '' - end if - end subroutine generate_report - - -end program time_ave diff --git a/Apps/time_ave_util.F90 b/Apps/time_ave_util.F90 new file mode 120000 index 000000000000..66f59afe2b3a --- /dev/null +++ b/Apps/time_ave_util.F90 @@ -0,0 +1 @@ +abi_fixed_coord.F90 \ No newline at end of file diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index be20b3d76bb1..50cc9861adc0 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -234,6 +234,33 @@ subroutine get_v1d_netcdf_R8(filename, name, array, Xdim, group_name, rc) end subroutine get_v1d_netcdf_R8 + subroutine get_v1d_netcdf_R8_w_offset(filename, name, array, Xdim, group_name, rc) + use netcdf + implicit none + character(len=*), intent(in) :: name, filename + character(len=*), optional, intent(in) :: group_name + integer, intent(in) :: Xdim + real(REAL64), dimension(Xdim), intent(out) :: array + integer, optional, intent(out) :: rc + integer :: status + integer :: ncid, varid, ncid2 + + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + if(present(group_name)) then + ncid2= ncid + call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + end if + call check_nc_status(nf90_inq_varid(ncid, name, varid), _RC) + call check_nc_status(nf90_get_var(ncid, varid, array), _RC) + if(present(group_name)) then + call check_nc_status(nf90_close(ncid2), _RC) + else + call check_nc_status(nf90_close(ncid), _RC) + end if + _RETURN(_SUCCESS) + + end subroutine + subroutine check_nc_status(status, rc) use netcdf implicit none From edd27b212836d5646ffc608e7af7f112e1994b10 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 15 Jan 2024 11:07:01 -0700 Subject: [PATCH 37/86] Read goes_imager_projection:longitude_of_projection_origin = -75. to lambda0 --- Apps/abi_fixed_coord.F90 | 1760 +----------------------------------- base/MAPL_ObsUtil.F90 | 67 +- base/Plain_netCDF_Time.F90 | 73 +- 3 files changed, 157 insertions(+), 1743 deletions(-) diff --git a/Apps/abi_fixed_coord.F90 b/Apps/abi_fixed_coord.F90 index 7f0190788d30..08f0a56a8087 100644 --- a/Apps/abi_fixed_coord.F90 +++ b/Apps/abi_fixed_coord.F90 @@ -1,1743 +1,47 @@ #define I_AM_MAIN #include "MAPL_Generic.h" -program time_ave +program ABI_fixed_coord use ESMF use MAPL use MAPL_FileMetadataUtilsMod use gFTL_StringVector use MPI - use, intrinsic :: iso_fortran_env, only: int32, int64, int16, real32, real64 + use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64 use ieee_arithmetic, only: isnan => ieee_is_nan - + use Plain_netCDF_Time implicit none - integer comm,myid,npes,ierror - integer imglobal - integer jmglobal - logical root - -! ********************************************************************** -! ********************************************************************** -! **** **** -! **** Program to create time-averaged HDF files **** -! **** **** -! ********************************************************************** -! ********************************************************************** - - integer im,jm,lm - - integer nymd, nhms - integer nymd0,nhms0 - integer nymdp,nhmsp - integer nymdm,nhmsm - integer ntod, ndt, ntods - integer month, year - integer monthp, yearp - integer monthm, yearm - integer begdate, begtime - integer enddate, endtime - - integer id,rc,timeinc,timeid - integer ntime,nvars,ncvid,nvars2 - - character(len=ESMF_MAXSTR), allocatable :: fname(:) - character(len=ESMF_MAXSTR) template - character(len=ESMF_MAXSTR) name - character(len=ESMF_MAXSTR) ext - character(len=ESMF_MAXSTR) output, doutput, hdfile, rcfile - character(len=8) date0 - character(len=2) time0 - character(len=1) char - data output /'monthly_ave'/ - data rcfile /'NULL'/ - data doutput /'NULL'/ - data template/'NULL'/ - - integer n,m,nargs,L,nfiles,nv,km,mvars,mv,ndvars - - real plev,qming,qmaxg - real previous_undef,undef - real, allocatable :: lev(:) - integer, allocatable :: kmvar(:) , kmvar2(:) - integer, allocatable :: yymmdd(:) - integer, allocatable :: hhmmss(:) - integer, allocatable :: nloc(:) - integer, allocatable :: iloc(:) - - character(len=ESMF_MAXSTR), allocatable :: vname(:), vname2(:) - character(len=ESMF_MAXSTR), allocatable :: vtitle(:), vtitle2(:) - character(len=ESMF_MAXSTR), allocatable :: vunits(:), vunits2(:) - - real, allocatable :: qmin(:) - real, allocatable :: qmax(:) - real, allocatable :: dumz1(:,:) - real, allocatable :: dumz2(:,:) - real, allocatable :: dum(:,:,:) - real(REAL64), allocatable :: q(:,:,:,:) - integer, allocatable :: ntimes(:,:,:,:) - - integer timinc,i,j,k,nmax,kbeg,kend,loc1,loc2 - integer nstar - logical tend, first, strict, diurnal, mdiurnal, lquad, ldquad - logical ignore_nan - data first /.true./ - data strict /.true./ - - type(ESMF_Config) :: config - integer, allocatable :: qloc(:,:) - character(len=ESMF_MAXSTR), allocatable :: quadratics(:,:) - character(len=ESMF_MAXSTR), allocatable :: quadtmp(:,:) - character(len=ESMF_MAXSTR), allocatable :: aliases(:,:) - character(len=ESMF_MAXSTR), allocatable :: aliastmp(:,:) - character(len=ESMF_MAXSTR) name1, name2, name3, dummy - integer nquad - integer nalias - logical, allocatable :: lzstar(:) + character*150 :: fn, kx, ky + character*150 :: var_name_proj, att_name_proj + integer :: nx, ny + real(REAL64), allocatable :: x(:), y(:) + real(REAL64) :: lambda0, lambda0_deg - integer ntmin, ntcrit, nc - - type(FileMetadata) :: basic_metadata - type(FileMetadataUtils) :: file_metadata - type(NetCDF4_FileFormatter) :: file_handle integer :: status - class(AbstractGridfactory), allocatable :: factory - type(ESMF_Grid) :: output_grid,input_grid - character(len=:), allocatable :: output_grid_name - integer :: global_dims(3), local_dims(3) - type(ESMF_Time), allocatable :: time_series(:) - type(ESMF_TIme) :: etime - type(ESMF_Clock) :: clock - type(ESMF_TimeInterval) :: time_interval - type(ESMF_FieldBundle) :: primary_bundle,final_bundle,diurnal_bundle - type(ESMF_Field) :: field - type(ServerManager) :: io_server - type(FieldBundleWriter) :: standard_writer, diurnal_writer - real(ESMF_KIND_R4), pointer :: ptr2d(:,:),ptr3d(:,:,:) - character(len=ESMF_MAXSTR) :: grid_type - logical :: allow_zonal_means - character(len=ESMF_MAXPATHLEN) :: arg_str - character(len=:), allocatable :: lev_name - character(len=ESMF_MAXSTR) :: lev_units - integer :: n_times - type(verticalData) :: vertical_data - logical :: file_has_lev - type(DistributedProfiler), target :: t_prof - type(ProfileReporter) :: reporter - -! ********************************************************************** -! **** Initialization **** -! ********************************************************************** - -!call timebeg ('main') - - call mpi_init ( ierror ) ; comm = mpi_comm_world - call mpi_comm_rank ( comm,myid,ierror ) - call mpi_comm_size ( comm,npes,ierror ) - call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,mpiCommunicator=MPI_COMM_WORLD, _RC) - call MAPL_Initialize(_RC) - t_prof = DistributedProfiler('time_ave_util',MpiTImerGauge(),MPI_COMM_WORLD) - call t_prof%start(_RC) - call io_server%initialize(MPI_COMM_WORLD,_RC) - root = myid.eq.0 - call ESMF_CalendarSetDefault(ESMF_CALKIND_GREGORIAN,_RC) - -! Read Command Line Arguments -! --------------------------- - begdate = -999 - begtime = -999 - enddate = -999 - endtime = -999 - ndt = -999 - ntod = -999 - ntmin = -999 - nargs = command_argument_count() - if( nargs.eq.0 ) then - call usage(root) - else - lquad = .TRUE. - ldquad = .FALSE. - diurnal = .FALSE. - mdiurnal = .FALSE. - ignore_nan = .FALSE. - do n=1,nargs - call get_command_argument(n,arg_str) - select case(trim(arg_str)) - case('-template') - call get_command_argument(n+1,template) - case('-tag') - call get_command_argument(n+1,output) - case('-rc') - call get_command_argument(n+1,rcfile) - case('-begdate') - call get_command_argument(n+1,arg_str) - read(arg_str,*)begdate - case('-begtime') - call get_command_argument(n+1,arg_str) - read(arg_str,*)begtime - case('-enddate') - call get_command_argument(n+1,arg_str) - read(arg_str,*)enddate - case('-endtime') - call get_command_argument(n+1,arg_str) - read(arg_str,*)endtime - case('-ntmin') - call get_command_argument(n+1,arg_str) - read(arg_str,*)ntmin - case('-ntod') - call get_command_argument(n+1,arg_str) - read(arg_str,*)ntod - case('-ndt') - call get_command_argument(n+1,arg_str) - read(arg_str,*)ndt - case('-strict') - call get_command_argument(n+1,arg_str) - read(arg_str,*)strict - case('-ogrid') - call get_command_argument(n+1,arg_str) - output_grid_name = trim(arg_str) - case('-noquad') - lquad = .FALSE. - case('-ignore_nan') - ignore_nan = .TRUE. - case('-d') - diurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-md') - mdiurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-dv') - ldquad = .true. - diurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-mdv') - ldquad = .true. - mdiurnal = .true. - if (n+1 .le. nargs) then - call get_command_argument(n+1,arg_str) - read(arg_str,fmt='(a1)') char - if (char.ne.'-') doutput=arg_str - end if - case('-eta') - nfiles = 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - do while (char .ne. '-' .and. n+nfiles.ne.nargs) - nfiles = nfiles + 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - enddo - if (char.eq.'-') nfiles = nfiles-1 - allocate(fname(nfiles)) - do m=1,nfiles - call get_command_argument(n+m,fname(m)) - enddo - case('-hdf') - nfiles = 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - do while (char .ne. '-' .and. n+nfiles.ne.nargs) - nfiles = nfiles + 1 - call get_command_argument(n+nfiles,arg_str) - read(arg_str,fmt='(a1)') char - enddo - if (char.eq.'-') nfiles = nfiles-1 - allocate(fname(nfiles)) - do m=1,nfiles - call get_command_argument(n+m,fname(m)) - enddo - end select - enddo - end if - - if( (diurnal.or.mdiurnal) .and. trim(doutput).eq.'NULL' ) then - doutput = trim(output) // "_diurnal" - if( mdiurnal ) diurnal = .FALSE. - endif - - if (root .and. ignore_nan) print *,' ignore nan is true' - - -! Read RC Quadratics -! ------------------ - if( trim(rcfile).eq.'NULL' ) then - nquad = 0 - nalias = 0 - else - config = ESMF_ConfigCreate ( rc=rc ) - call ESMF_ConfigLoadFile ( config, trim(rcfile), rc=rc ) - call ESMF_ConfigFindLabel ( config, 'QUADRATICS:', rc=rc ) - tend = .false. - m = 0 - do while (.not.tend) - m = m+1 - allocate( quadtmp(3,m) ) - call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name3,default='XXX',rc=rc ) - call ESMF_ConfigNextLine ( config,tableEnd=tend, rc=rc ) - if( m==1 ) then - quadtmp(1,m) = name1 - quadtmp(2,m) = name2 - quadtmp(3,m) = name3 - allocate( quadratics(3,m) ) - quadratics = quadtmp - else - quadtmp(1,1:m-1) = quadratics(1,:) - quadtmp(2,1:m-1) = quadratics(2,:) - quadtmp(3,1:m-1) = quadratics(3,:) - quadtmp(1,m) = name1 - quadtmp(2,m) = name2 - quadtmp(3,m) = name3 - deallocate( quadratics ) - allocate( quadratics(3,m) ) - quadratics = quadtmp - endif - deallocate (quadtmp) - enddo - nquad = m - -! Read RC Aliases -! --------------- - call ESMF_ConfigFindLabel ( config, 'ALIASES:', rc=rc ) - tend = .false. - m = 0 - do while (.not.tend) - m = m+1 - allocate( aliastmp(2,m) ) - call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) - call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) - call ESMF_ConfigNextLine ( config,tableEnd=tend ,rc=rc ) - if( m==1 ) then - aliastmp(1,m) = name1 - aliastmp(2,m) = name2 - allocate( aliases(2,m) ) - aliases = aliastmp - else - aliastmp(1,1:m-1) = aliases(1,:) - aliastmp(2,1:m-1) = aliases(2,:) - aliastmp(1,m) = name1 - aliastmp(2,m) = name2 - deallocate( aliases ) - allocate( aliases(2,m) ) - aliases = aliastmp - endif - deallocate (aliastmp) - enddo - nalias = m - endif - if (.not. allocated(aliases)) allocate(aliases(0,0)) - -! ********************************************************************** -! **** Read HDF File **** -! ********************************************************************** - - call t_prof%start('initialize') - - if( trim(template).ne.'NULL' ) then - name = template - else - name = fname(1) - endif - - n = index(trim(name),'.',back=.true.) - ext = trim(name(n+1:)) - - call file_handle%open(trim(name),PFIO_READ,_RC) - basic_metadata = file_handle%read(_RC) - call file_handle%close(_RC) - - allocate(factory, source=grid_manager%make_factory(trim(name))) - input_grid = grid_manager%make_grid(factory) - file_has_lev = has_level(input_grid,_RC) - call MAPL_GridGet(input_grid,globalCellCountPerDim=global_dims,_RC) - lm = global_dims(3) - - if (file_has_lev) then - call get_file_levels(trim(name),vertical_data,_RC) - end if - - if (allocated(output_grid_name)) then - output_grid = create_output_grid(output_grid_name,lm,_RC) - else - output_grid = input_grid - end if - call ESMF_AttributeGet(output_grid,'GridType',grid_type,_RC) - allow_zonal_means = trim(grid_type) == 'LatLon' - if (trim(grid_type) == "Cubed-Sphere") then - _ASSERT(mod(npes,6)==0,"If input files are Cubed-Sphere, must be run on multiple of 6 proccessors") - end if - call MAPL_GridGet(output_grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) - im = local_dims(1) - jm = local_dims(2) - lm = local_dims(3) - imglobal = global_dims(1) - jmglobal = global_dims(2) - - call file_metadata%create(basic_metadata,trim(name)) - call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) - primary_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) - call ESMF_FieldBundleSet(primary_bundle,grid=output_grid,_RC) - call MAPL_Read_Bundle(primary_bundle,trim(name),time=time_series(1),_RC) - call ESMF_FieldBundleGet(primary_bundle,fieldCount=nvars,_RC) - allocate(vname(nvars)) - call ESMF_FieldBundleGet(primary_bundle,fieldNameList=vname,_RC) - kmvar = get_level_info(primary_bundle,_RC) - vtitle = get_long_names(primary_bundle,_RC) - vunits = get_units(primary_bundle,_RC) - - final_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) - call ESMF_FieldBundleSet(final_bundle,grid=output_grid,_RC) - diurnal_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) - call ESMF_FieldBundleSet(diurnal_bundle,grid=output_grid,_RC) - call copy_bundle_to_bundle(primary_bundle,final_bundle,_RC) - - if (size(time_series)>1) then - time_interval = time_series(2) - time_series(1) - else if (size(time_series)==1) then - call ESMF_TimeIntervalSet(time_interval,h=6,_RC) - end if - clock = ESMF_ClockCreate(startTime=time_series(1),timeStep=time_interval,_RC) - - nvars2 = nvars - - if (file_has_lev) then - lev_name = file_metadata%get_level_name(_RC) - call file_metadata%get_coordinate_info(lev_name,coords=lev,coordUnits=lev_units,_RC) - end if - - previous_undef = file_metadata%var_get_missing_value(trim(vname(1)),_RC) - do i=2,size(vname) - undef = file_metadata%var_get_missing_value(trim(vname(i)),_RC) - _ASSERT(undef == previous_undef,"conflicting undefined values in your variables") - previous_undef = undef - enddo - undef = previous_undef - - -! Set NDT for Strict Time Testing -! ------------------------------- - if( ntod.ne.-999 ) ndt = 86400 - if( ndt .eq.-999 ) ndt = compute_nsecf (timinc) - if( timinc .eq. 0 ) then - timeId = ncvid (id, 'time', rc) - call ncagt (id, timeId, 'time_increment', timinc, rc) - if( timinc .eq. 0 ) then - if( root ) then - print * - print *, 'Warning, GFIO Inquire states TIMINC = ',timinc - print *, ' This will be reset to 060000 ' - print *, ' Use -ndt NNN (in seconds) to overide this' - endif - timinc = 060000 - endif - ndt = compute_nsecf (timinc) - endif - -! Determine Number of Time Periods within 1-Day -! --------------------------------------------- - ntods = 0 - if( diurnal .or. mdiurnal ) then - if( ndt.lt.86400 ) ntods = 86400/ndt - endif - -! Set Minimum Required Times for Time Average (Default: 10 Days for Monthly Mean) -! ------------------------------------------------------------------------------- - if( ntmin.eq.-999 ) then - if( ntod.eq.-999 ) then - ntcrit = 10 * ( 86400.0/real(compute_nsecf(timinc)) ) - else - ntcrit = 10 - endif - else - ntcrit = ntmin - endif - -! Determine Location Index for Each Variable in File -! -------------------------------------------------- - if( root ) print * - allocate ( nloc(nvars) ) - nloc(1) = 1 - if( root ) write(6,7000) 1,trim(vname(1)),nloc(1),trim(vtitle(1)),max(1,kmvar(1)) - do n=2,nvars - nloc(n) = nloc(n-1)+max(1,kmvar(n-1)) - if( root ) write(6,7000) n,trim(vname(n)),nloc(n),trim(vtitle(n)),max(1,kmvar(n)) -7000 format(1x,'Primary Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a40,2x,i2,3x,i2,3x,i2) - enddo - - nmax = nloc(nvars)+max(1,kmvar(nvars))-1 - allocate( dum (im,jm,nmax) ) - allocate( dumz1(im,jm) ) - allocate( dumz2(im,jm) ) - -! Append Default Quadratics to User-Supplied List -! ----------------------------------------------- - if( lquad ) then - if( nquad.eq.0 ) then - allocate( quadratics(3,nvars) ) - do n=1,nvars - quadratics(1,n) = trim( vname(n) ) - quadratics(2,n) = trim( vname(n) ) - quadratics(3,n) = 'XXX' - enddo - nquad = nvars - else - allocate( quadtmp(3,nquad+nvars) ) - quadtmp(1,1:nquad) = quadratics(1,:) - quadtmp(2,1:nquad) = quadratics(2,:) - quadtmp(3,1:nquad) = quadratics(3,:) - do n=1,nvars - quadtmp(1,nquad+n) = trim( vname(n) ) - quadtmp(2,nquad+n) = trim( vname(n) ) - quadtmp(3,nquad+n) = 'XXX' - enddo - nquad = nquad + nvars - deallocate( quadratics ) - allocate( quadratics(3,nquad) ) - quadratics = quadtmp - deallocate( quadtmp ) - endif - endif - - allocate ( qloc(2,nquad) ) - allocate ( lzstar(nquad) ) ; lzstar = .FALSE. - -! Determine Possible Quadratics -! ----------------------------- - km=kmvar(nvars) - m= nvars - do n=1,nquad - call check_quad ( quadratics(1,n),vname,nvars,aliases,nalias,qloc(1,n) ) - if( qloc(1,n)*qloc(2,n).ne.0 ) then - m=m+1 - allocate ( iloc(m) ) - iloc(1:m-1) = nloc - iloc(m) = iloc(m-1)+max(1,km) - deallocate ( nloc ) - allocate ( nloc(m) ) - nloc = iloc - deallocate ( iloc ) - km=kmvar( qloc(1,n) ) - endif - enddo - - mvars = m - nmax = nloc(m)+max(1,km)-1 - - allocate ( vname2( mvars) ) - allocate ( vtitle2( mvars) ) - allocate ( vunits2( mvars) ) - allocate ( kmvar2( mvars) ) - - vname2( 1:nvars) = vname - vtitle2( 1:nvars) = vtitle - vunits2( 1:nvars) = vunits - kmvar2( 1:nvars) = kmvar - - if( root .and. mvars.gt.nvars ) print * - mv= nvars - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv = mv+1 - - if( trim(quadratics(1,nv)).eq.trim(quadratics(2,nv)) ) then - vname2(mv) = "Var_" // trim(vname(qloc(1,nv))) - vtitle2(mv) = "Variance_of_" // trim(vname(qloc(1,nv))) - else - vname2(mv) = "Cov_" // trim(vname(qloc(1,nv))) // "_" // trim(vname(qloc(2,nv))) - vtitle2(mv) = "Covariance_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) - endif - - if( trim(quadratics(3,nv)).ne.'XXX' ) vname2(mv) = trim(quadratics(3,nv)) - - nstar = index( trim(quadratics(1,nv)),'star',back=.true. ) - if( nstar.ne.0 ) then - _ASSERT(allow_zonal_means,"grid is not lat-lon so cannot compute zonal means") - lzstar(nv) = .TRUE. - vtitle2(mv) = "Product_of_Zonal_Mean_Deviations_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) - endif - - vunits2(mv) = trim(vunits(qloc(1,nv))) // " " // trim(vunits(qloc(2,nv))) - kmvar2(mv) = kmvar(qloc(1,nv)) - - call add_new_field_to_bundle(final_bundle,output_grid,kmvar(qloc(1,nv)),vname2(mv),vtitle2(mv),vunits2(mv),_RC) - - if( root ) write(6,7001) mv,trim(vname2(mv)),nloc(mv),trim(vtitle2(mv)),max(1,kmvar(qloc(1,nv))),qloc(1,nv),qloc(2,nv) -7001 format(1x,' Quad Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a50,2x,i2,3x,i3,3x,i3) - endif - enddo - -!deallocate ( lev ) - deallocate ( yymmdd ) - deallocate ( hhmmss ) - deallocate ( vname ) - deallocate ( vtitle ) - deallocate ( vunits ) - deallocate ( kmvar ) - - allocate( qmin(nmax) ) - allocate( qmax(nmax) ) - allocate( q(im,jm,nmax,0:ntods) ) - allocate( ntimes(im,jm,nmax,0:ntods) ) - ntimes = 0 - q = 0 - qmin = abs(undef) - qmax = -abs(undef) - - if( root ) then - print * - write(6,7002) mvars,nmax,im,jm,nmax,ntods -7002 format(1x,'Total Number of Variables: ',i3,/ & - 1x,'Total Size: ',i5,/ & - 1x,'Allocating q(',i4,',',i3,',',i5,',0:',i2.2,')') - print * - print *, 'Files: ' - do n=1,nfiles - print *, n,trim(fname(n)) - enddo - print * - if( ntod.eq.-999 ) then - print *, 'Averging Time-Period NHMS: ',ntod,' (ALL Possible Time Periods Used)' - else - print *, 'Averging Time-Period NHMS: ',ntod - endif - if( begdate.ne.-999 .or. begtime.ne.-999 ) print *, 'Beginning Date for Averaging: ',begdate,begtime - if( enddate.ne.-999 .or. endtime.ne.-999 ) print *, ' Ending Date for Averaging: ',enddate,endtime - if( strict ) then - print *, 'Every Time Period Required for Averaging, STRICT = ',strict - else - print *, 'Only Averaging Time Periods Supplied, STRICT = ',strict - endif - write(6,7003) ntcrit -7003 format(1x,'Required Minimum Number of Defined Time Periods: ',i3,' (Otherwise, UNDEF)') - print * - endif - - call t_prof%stop('initialize') - -! ********************************************************************** -! **** Read HDF Files **** -! ********************************************************************** - - k = 0 - - do n=1,nfiles - - if (allocated(time_series)) deallocate(time_series) - if (allocated(yymmdd)) deallocate(yymmdd) - if (allocated(hhmmss)) deallocate(hhmmss) - call file_handle%open(trim(fname(n)),PFIO_READ,_RC) - basic_metadata = file_handle%read(_RC) - call file_handle%close(_RC) - call file_metadata%create(basic_metadata,trim(fname(n))) - call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) - - - do m=1,ntime - nymd = yymmdd(m) - nhms = hhmmss(m) - if( nhms<0 ) then - nhms = compute_nhmsf( compute_nsecf(nhms) + 86400 ) - call tick (nymd,nhms,-86400) - endif - - if( ( begdate.ne.-999 .and. begtime.ne.-999 ) .and. & - ( begdate.gt.nymd .or. & - ( begdate.eq.nymd.and.begtime.gt.nhms ) ) ) cycle - - if( ( enddate.ne.-999 .and. endtime.ne.-999 ) .and. & - ( enddate.lt.nymd .or. & - ( enddate.eq.nymd.and.endtime.lt.nhms ) ) ) cycle - - k = k+1 - if( k.gt.ntods ) k = 1 - if( ntod.eq.-999 .or. ntod.eq.nhms ) then - if( root ) write(6,3000) nymd,nhms,timinc,trim(fname(n)),k -3000 format(1x,'Reading nymd: ',i8.8,' nhms: ',i6.6,' TimInc: ',i6.6,' from File: ',a,' tod = ',i2) - year = nymd/10000 - month = mod(nymd,10000)/100 - -! Check for Correct First Dataset -! ------------------------------- - if( strict .and. first ) then - nymdm = nymd - nhmsm = nhms - call tick (nymdm,nhmsm,-ndt) - yearm = nymdm/10000 - monthm = mod(nymdm,10000)/100 - if( year.eq.yearm .and. month.eq.monthm ) then - if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct First Time Period!' - _FAIL("error processing dataset") - endif - endif - -! Check Date and Time for STRICT Time Testing -! ------------------------------------------- - if( strict .and. .not.first ) then - if( nymd.ne.nymdp .or. nhms.ne.nhmsp ) then - if( root ) print *, 'Date: ',nymdp,' Time: ',nhmsp,' not found!' - _FAIL("error processing dataset") - endif - endif - nymdp = nymd - nhmsp = nhms - -! Primary Fields -! -------------- - - etime = local_esmf_timeset(nymd,nhms,_RC) - call MAPL_Read_Bundle(primary_bundle,trim(fname(1)),time=etime,file_override=trim(fname(n)),_RC) - do nv=1,nvars2 - call ESMF_FieldBundleGet(primary_bundle,trim(vname2(nv)),field=field,_RC) - call t_prof%start('PRIME') - if( kmvar2(nv).eq.0 ) then - kbeg = 0 - kend = 1 - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - dum(:,:,nloc(nv))=ptr2d - else - kbeg = 1 - kend = kmvar2(nv) - - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - dum(:,:,nloc(nv):nloc(nv)+kmvar2(nv)-1) = ptr3d - endif - - rc = 0 - do L=1,max(1,kmvar2(nv)) - do j=1,jm - do i=1,im - if( isnan( dum(i,j,nloc(nv)+L-1) ) .or. ( dum(i,j,nloc(nv)+L-1).gt.HUGE(dum(i,j,nloc(nv)+L-1)) ) ) then -!print *, 'Warning! Nan or Infinity detected for ',trim(vname2(nv)),' at lat: ',lattice%jglobal(j),' lon: ',lattice%iglobal(i) - if( root .and. ignore_nan ) then - print *, 'Setting Nan or Infinity to UNDEF' - print * - else - rc = 1 - endif - dum(i,j,nloc(nv)+L-1) = undef - endif - if( defined(dum(i,j,nloc(nv)+L-1),undef) ) then - q(i,j,nloc(nv)+L-1,0) = q(i,j,nloc(nv)+L-1,0) + dum(i,j,nloc(nv)+L-1) - ntimes(i,j,nloc(nv)+L-1,0) = ntimes(i,j,nloc(nv)+L-1,0) + 1 - if( qmin(nloc(nv)+L-1).gt.dum(i,j,nloc(nv)+L-1) ) qmin(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) - if( qmax(nloc(nv)+L-1).lt.dum(i,j,nloc(nv)+L-1) ) qmax(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) - if( ntods.ne.0 ) then - q(i,j,nloc(nv)+L-1,k) = q(i,j,nloc(nv)+L-1,k) + dum(i,j,nloc(nv)+L-1) - ntimes(i,j,nloc(nv)+L-1,k) = ntimes(i,j,nloc(nv)+L-1,k) + 1 - endif - endif - enddo - enddo - enddo - call t_prof%stop('PRIME') - - enddo - -! Quadratics -! ---------- - call t_prof%start('QUAD') - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - do L=1,max(1,kmvar2(qloc(1,nv))) - if( lzstar(nv) ) then - call latlon_zstar (dum(:,:,nloc(qloc(1,nv))+L-1),dumz1,undef,output_grid,_RC) - call latlon_zstar (dum(:,:,nloc(qloc(2,nv))+L-1),dumz2,undef,output_grid,_RC) - do j=1,jm - do i=1,im - if( defined(dumz1(i,j),undef) .and. & - defined(dumz2(i,j),undef) ) then - q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dumz1(i,j)*dumz2(i,j) - ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 - if( ntods.ne.0 ) then - q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dumz1(i,j)*dumz2(i,j) - ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 - endif - endif - enddo - enddo - else - do j=1,jm - do i=1,im - if( defined(dum(i,j,nloc(qloc(1,nv))+L-1),undef) .and. & - defined(dum(i,j,nloc(qloc(2,nv))+L-1),undef) ) then - q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dum(i,j,nloc(qloc(1,nv))+L-1) & - * dum(i,j,nloc(qloc(2,nv))+L-1) - ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 - if( ntods.ne.0 ) then - q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dum(i,j,nloc(qloc(1,nv))+L-1) & - * dum(i,j,nloc(qloc(2,nv))+L-1) - ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 - endif - endif - enddo - enddo - endif - enddo - endif - enddo - call t_prof%stop('QUAD') - - if( first ) then - nymd0 = nymd - nhms0 = nhms - first = .false. - endif - -! Update Date and Time for Strict Test -! ------------------------------------ - call tick (nymdp,nhmsp,ndt) - yearp = nymdp/10000 - monthp = mod(nymdp,10000)/100 - - endif ! End ntod Test - enddo ! End ntime Loop within file - - call MPI_BARRIER(comm,status) - enddo - - do k=0,ntods - if( k.eq.0 ) then - nc = ntcrit - else - nc = max( 1,ntcrit/ntods ) - endif - do n=1,nmax - do j=1,jm - do i=1,im - if( ntimes(i,j,n,k).lt.nc ) then - q(i,j,n,k) = undef - else - q(i,j,n,k) = q(i,j,n,k)/ntimes(i,j,n,k) - endif - enddo - enddo - enddo - enddo - -! ********************************************************************** -! **** Write HDF Monthly Output File **** -! ********************************************************************** - -call t_prof%start('Write_AVE') - -! Check for Correct Last Dataset -! ------------------------------ - if( strict .and. ( year.eq.yearp .and. month.eq.monthp ) ) then - if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct Last Time Period!' - _FAIL("Error processing dataset") - endif - - write(date0,4000) nymd0/100 - write(time0,2000) nhms0/10000 - - hdfile = trim(output) // "." // trim(date0) // "." // trim(ext) - -1000 format(i8.8) -2000 format(i2.2) -4000 format(i6.6) - - timeinc = 060000 - -! Primary Fields -! -------------- - if( root ) print * - do n=1,nvars2 - call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) - if( kmvar2(n).eq.0 ) then - kbeg = 0 - kend = 1 - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = q(:,:,nloc(n),0) - else - kbeg = 1 - kend = kmvar2(n) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,0) - endif - if( root ) write(6,3001) trim(vname2(n)),nloc(n),trim(hdfile) -3001 format(1x,'Writing ',a,' at location ',i6,' into File: ',a) - dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,0) - enddo - -! Quadratics -! ---------- - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - if( root ) write(6,3001) trim(vname2(mv)),nloc(mv),trim(hdfile) - call ESMF_FieldBundleGet(final_bundle,trim(vname2(mv)),field=field,_RC) - - if( kmvar2(qloc(1,nv)).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(qloc(1,nv)) - endif - loc1 = nloc( qloc(1,nv) ) - loc2 = nloc( qloc(2,nv) ) - if( .not.lzstar(nv) ) then - where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - q(:,:,loc1:loc1+kend-1,0) & - * q(:,:,loc2:loc2+kend-1,0) - elsewhere - dum(:,:,1:kend) = undef - endwhere - else - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - endif - if( kmvar2(qloc(1,nv)).eq.0 ) then - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = dum(:,:,1) - else - kend = kmvar2(qloc(1,nv)) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = dum(:,:,1:kend) - endif - endif - enddo - - if( root ) then - print * - print *, 'Created: ',trim(hdfile) - print * - endif - call t_prof%stop('Write_AVE') - etime = local_esmf_timeset(nymd0,nhms0,_RC) - call ESMF_ClockSet(clock,currTime=etime, _RC) - call standard_writer%create_from_bundle(final_bundle,clock,n_steps=1,time_interval=timeinc,vertical_data=vertical_data,_RC) - call standard_writer%start_new_file(trim(hdfile),_RC) - call standard_writer%write_to_file(_RC) - -! ********************************************************************** -! **** Write HDF Monthly Diurnal Output File **** -! ********************************************************************** - - if( ntods.ne.0 ) then - call t_prof%start('Write_Diurnal') - timeinc = compute_nhmsf( 86400/ntods ) - - do k=1,ntods - - if( k.eq.1 .or. mdiurnal ) then - - write(date0,4000) nymd0/100 - write(time0,2000) nhms0/10000 - - if( diurnal ) hdfile = trim(doutput) // "." // trim(date0) // "." // trim(ext) - if( mdiurnal ) hdfile = trim(doutput) // "." // trim(date0) // "_" // trim(time0) // "z." // trim(ext) - - if( ldquad ) then - ndvars = mvars ! Include Quadratics in Diurnal Files - if (k==1) then - call copy_bundle_to_bundle(final_bundle,diurnal_bundle,_RC) - end if - else - ndvars = nvars2 ! Only Include Primary Fields in Diurnal Files (Default) - if (k==1) then - do n=1,nvars - call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) - call MAPL_FieldBundleAdd(diurnal_bundle,field,_RC) - enddo - endif - endif - endif - -! Primary Fields -! -------------- - do n=1,nvars2 - call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(n)),field=field,_RC) - if( kmvar2(n).eq.0 ) then - kbeg = 0 - kend = 1 - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = q(:,:,nloc(n),k) - else - kbeg = 1 - kend = kmvar2(n) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,k) - endif - dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,k) - enddo - -! Quadratics -! ---------- - if( ndvars.eq.mvars ) then - mv= nvars2 - do nv=1,nquad - if( qloc(1,nv)*qloc(2,nv).ne.0 ) then - mv=mv+1 - call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(mv)),field=field,_RC) - if( kmvar2(qloc(1,nv)).eq.0 ) then - kbeg = 0 - kend = 1 - else - kbeg = 1 - kend = kmvar2(qloc(1,nv)) - endif - loc1 = nloc( qloc(1,nv) ) - loc2 = nloc( qloc(2,nv) ) - if( .not.lzstar(nv) ) then - where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - q(:,:,loc1:loc1+kend-1,k) & - * q(:,:,loc2:loc2+kend-1,k) - elsewhere - dum(:,:,1:kend) = undef - endwhere - else - dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - endif - if( kmvar2(qloc(1,nv)).eq.0 ) then - call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) - ptr2d = dum(:,:,1) - else - kend = kmvar2(qloc(1,nv)) - call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) - ptr3d = dum(:,:,1:kend) - endif - endif - enddo - endif - - - etime = local_esmf_timeset(nymd0,nhms0,_RC) - call ESMF_ClockSet(clock,currTime=etime, _RC) - if (k==1 .or. mdiurnal) then - if (mdiurnal) then - n_times = 1 - else - n_times = ntods - end if - if (k==1) then - call diurnal_writer%create_from_bundle(diurnal_bundle,clock,n_steps=n_times,time_interval=timeinc,vertical_data=vertical_data) - end if - call diurnal_writer%start_new_file(trim(hdfile),_RC) - end if - call diurnal_writer%write_to_file(_RC) - if( root .and. mdiurnal ) then - print *, 'Created: ',trim(hdfile) - endif - call tick (nymd0,nhms0,ndt) - enddo - - if( root .and. diurnal ) then - print *, 'Created: ',trim(hdfile) - endif - if( root ) print * - - call t_prof%stop('Write_Diurnal') - endif - -! ********************************************************************** -! **** Write Min/Max Information **** -! ********************************************************************** - - if( root ) print * - do n=1,nvars2 - do L=1,max(1,kmvar2(n)) - if( kmvar2(n).eq.0 ) then - plev = 0 - else - plev = lev(L) - endif - - call mpi_reduce( qmin(nloc(n)+L-1),qming,1,mpi_real,mpi_min,0,comm,ierror ) - call mpi_reduce( qmax(nloc(n)+L-1),qmaxg,1,mpi_real,mpi_max,0,comm,ierror ) - if( root ) then - if(L.eq.1) then - write(6,3101) trim(vname2(n)),plev,qming,qmaxg - else - write(6,3102) trim(vname2(n)),plev,qming,qmaxg - endif - endif -3101 format(1x,'Primary Field: ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) -3102 format(1x,' ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) - enddo - call MPI_BARRIER(comm,status) - if( root ) print * - enddo - if( root ) print * - -! ********************************************************************** -! **** Timing Information **** -! ********************************************************************** - - call io_server%finalize() - call t_prof%stop() - call t_prof%reduce() - call t_prof%finalize() - call generate_report() - call MAPL_Finalize() - call MPI_Finalize(status) - stop - -contains - - function create_output_grid(grid_name,lm,rc) result(new_grid) - type(ESMF_Grid) :: new_grid - character(len=*), intent(inout) :: grid_name - integer, intent(in) :: lm - integer, optional, intent(out) :: rc - - type(ESMF_Config) :: cf - integer :: nn,im_world,jm_world,nx, ny - character(len=5) :: imsz,jmsz - character(len=2) :: pole,dateline - - nn = len_trim(grid_name) - imsz = grid_name(3:index(grid_name,'x')-1) - jmsz = grid_name(index(grid_name,'x')+1:nn-3) - pole = grid_name(1:2) - dateline = grid_name(nn-1:nn) - read(IMSZ,*) im_world - read(JMSZ,*) jm_world - - cf = MAPL_ConfigCreate(_RC) - call MAPL_ConfigSetAttribute(cf,value=lm, label=trim(grid_name)//".LM:",_RC) - if (dateline=='CF') then - call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) - call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) - call MAPL_ConfigSetAttribute(cf,value="Cubed-Sphere", label=trim(grid_name)//".GRID_TYPE:",_RC) - call MAPL_ConfigSetAttribute(cf,value=6, label=trim(grid_name)//".NF:",_RC) - call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) - call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) - else if (dateline=='TM') then - _FAIL("Tripolar not yet implemented for outpout") - else - call MAPL_MakeDecomposition(nx,ny,_RC) - call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) - call MAPL_ConfigSetAttribute(cf,value="LatLon", label=trim(grid_name)//".GRID_TYPE:",_RC) - call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) - call MAPL_ConfigSetAttribute(cf,value=jm_world,label=trim(grid_name)//".JM_WORLD:",_RC) - call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) - call MAPL_ConfigSetAttribute(cf,value=pole, label=trim(grid_name)//".POLE:",_RC) - call MAPL_ConfigSetAttribute(cf,value=dateline, label=trim(grid_name)//".DATELINE:",_RC) - if (pole=='XY' .and. dateline=='XY') then - _FAIL("regional lat-lon output not supported") - end if - end if - - new_grid = grid_manager%make_grid(cf,prefix=trim(grid_name)//".",_RC) - if (present(rc)) then - rc=_SUCCESS - end if - end function create_output_grid - - subroutine get_file_levels(filename,vertical_data,rc) - character(len=*), intent(in) :: filename - type(VerticalData), intent(inout) :: vertical_data - integer, intent(out), optional :: rc - - integer :: status - type(NetCDF4_fileFormatter) :: formatter - type(FileMetadata) :: basic_metadata - type(FileMetadataUtils) :: metadata - character(len=:), allocatable :: lev_name - character(len=ESMF_MAXSTR) :: long_name - character(len=ESMF_MAXSTR) :: standard_name - character(len=ESMF_MAXSTR) :: vcoord - character(len=ESMF_MAXSTR) :: lev_units - real, allocatable, target :: levs(:) - real, pointer :: plevs(:) - - call formatter%open(trim(filename),pFIO_Read,_RC) - basic_metadata=formatter%read(_RC) - call metadata%create(basic_metadata,trim(filename)) - lev_name = metadata%get_level_name(_RC) - if (lev_name /= '') then - call metadata%get_coordinate_info(lev_name,coords=levs,coordUnits=lev_units,long_name=long_name,& - standard_name=standard_name,coordinate_attr=vcoord,_RC) - plevs => levs - vertical_data = VerticalData(levels=plevs,vunit=lev_units,vcoord=vcoord,standard_name=standard_name,long_name=long_name, & - force_no_regrid=.true.,_RC) - nullify(plevs) - end if - - if (present(rc)) then - rc=_SUCCESS - end if - - end subroutine get_file_levels - - function has_level(grid,rc) result(grid_has_level) - logical :: grid_has_level - type(ESMF_Grid), intent(in) :: grid - integer, intent(out), optional :: rc - integer :: status, global_dims(3) - call MAPL_GridGet(grid,globalCellCountPerDim=global_dims,_RC) - grid_has_level = (global_dims(3)>1) - if (present(rc)) then - RC=_SUCCESS - end if - end function has_level - - subroutine copy_bundle_to_bundle(input_bundle,output_bundle,rc) - type(ESMF_FieldBundle), intent(inout) :: input_bundle - type(ESMF_FieldBundle), intent(inout) :: output_bundle - integer, intent(out), optional :: rc - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: i,num_fields - call ESMF_FieldBundleGet(input_bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - call ESMF_FieldBundleGet(input_bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(input_bundle,field_list(i),field=field,_RC) - call MAPL_FieldBundleAdd(output_bundle,field,_RC) - enddo - if (present(rc)) then - RC=_SUCCESS - end if - end subroutine copy_bundle_to_bundle - - subroutine add_new_field_to_bundle(bundle,grid,lm,field_name,long_name,units,rc) - type(ESMF_FieldBundle), intent(inout) :: bundle - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: lm - character(len=*), intent(in) :: field_name - character(len=*), intent(in) :: long_name - character(len=*), intent(in) :: units - integer, intent(out), optional :: rc - - integer :: status - type(ESMF_Field) :: field - - if (lm == 0) then - field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4,_RC) - else if (lm > 0) then - field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4, & - ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - end if - call ESMF_AttributeSet(field,name='LONG_NAME',value=trim(long_name),_RC) - call ESMF_AttributeSet(field,name='UNITS',value=trim(units),_RC) - if (lm == 0) then - call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzOnly,_RC) - call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationNone,_RC) - else if (lm > 0) then - call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzVert,_RC) - call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationCenter,_RC) - end if - call MAPL_FieldBundleAdd(bundle,field,_RC) - if (present(rc)) then - RC=_SUCCESS - end if - end subroutine add_new_field_to_bundle - - subroutine get_file_times(file_metadata,num_times,time_series,time_interval,yymmdd,hhmmss,rc) - type(FileMetadataUtils), intent(inout) :: file_metadata - integer, intent(out) :: num_times - type(ESMF_Time), allocatable, intent(inout) :: time_series(:) - integer, intent(inout), allocatable :: yymmdd(:) - integer, intent(inout), allocatable :: hhmmss(:) - integer, intent(out) :: time_interval - integer, intent(out), optional :: rc - - integer :: status - type(ESMF_TimeInterval) :: esmf_time_interval - integer :: hour, minute, second, year, month, day, i - - num_times = file_metadata%get_dimension('time',_RC) - call file_metadata%get_time_info(timeVector=time_series,_RC) - if (num_times == 1) then - time_interval = file_metadata%get_var_attr_int32('time','time_increment',_RC) - else if (num_times > 1) then - esmf_time_interval = time_series(2)-time_series(1) - call ESMF_TimeIntervalGet(esmf_time_interval,h=hour,m=minute,s=second,_RC) - time_interval = hour*10000+minute*100+second - end if - - allocate(yymmdd(num_times),hhmmss(num_times)) - do i = 1,num_times - call ESMF_TimeGet(time_series(i),yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) - yymmdd(i)=year*10000+month*100+day - hhmmss(i)=hour*10000+minute*100+second - enddo - if (present(rc)) then - rc=_SUCCESS - end if - end subroutine get_file_times - - function get_level_info(bundle,rc) result(kmvar) - integer, allocatable :: kmvar(:) - type(ESMF_FieldBundle), intent(in) :: bundle - integer, optional, intent(out) :: rc - - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: rank,i,num_fields,lb(1),ub(1) - call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - allocate(kmvar(num_fields)) - call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) - call ESMF_FieldGet(field,rank=rank,_RC) - if (rank==2) then - kmvar(i)=0 - else if (rank==3) then - call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - kmvar(i)=ub(1)-lb(1)+1 - else - _FAIL("Unsupported rank") - end if - end do - if (present(rc)) then - RC=_SUCCESS - end if - end function get_level_info - - function get_long_names(bundle,rc) result(long_names) - character(len=ESMF_MAXSTR), allocatable :: long_names(:) - type(ESMF_FieldBundle), intent(in) :: bundle - integer, optional, intent(out) :: rc - - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: i,num_fields - - call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - allocate(long_names(num_fields)) - call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) - call ESMF_AttributeGet(field,name='LONG_NAME',value=long_names(i),_RC) - enddo - if (present(rc)) then - RC=_SUCCESS - end if - end function get_long_names - - function get_units(bundle,rc) result(units) - character(len=ESMF_MAXSTR), allocatable :: units(:) - type(ESMF_FieldBundle), intent(in) :: bundle - integer, optional, intent(out) :: rc - - integer :: status - character(len=ESMF_MAXSTR), allocatable :: field_list(:) - type(ESMF_Field) :: field - integer :: i,num_fields - - call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) - allocate(field_list(num_fields)) - allocate(units(num_fields)) - call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) - do i=1,num_fields - call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) - call ESMF_AttributeGet(field,name='UNITS',value=units(i),_RC) - enddo - if (present(rc)) then - RC=_SUCCESS - end if - end function get_units - - function local_esmf_timeset(yymmdd,hhmmss,rc) result(etime) - type(ESMF_Time) :: etime - integer, intent(in) :: yymmdd - integer, intent(in) :: hhmmss - integer, intent(out), optional :: rc - - integer :: year,month,day,hour,minute,second,status - year = yymmdd/10000 - month = mod(yymmdd/100,100) - day = mod(yymmdd,100) - - hour = hhmmss/10000 - minute = mod(hhmmss/100,100) - second = mod(hhmmss,100) - - call ESMF_TimeSet(etime,yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) - if (present(rc)) then - rc=_SUCCESS - endif - end function local_esmf_timeset - - function defined ( q,undef ) - implicit none - logical defined - real q,undef - defined = q /= undef - end function defined - - subroutine latlon_zstar (q,qp,undef,grid,rc) - real, intent(inout) :: q(:,:) - real, intent(out) :: qp(:,:) - real, intent(in) :: undef - type (ESMF_Grid), intent(inout) :: grid - integer, optional, intent(out) :: rc - - integer :: local_dims(3) - integer im,jm,i,j,status - real, allocatable :: qz(:) - - call MAPL_GridGet(grid,localCellCountPerDim=local_dims,_RC) - im = local_dims(1) - jm = local_dims(2) - allocate(qz(jm)) - - call latlon_zmean ( q,qz,undef,grid ) - do j=1,jm - if( qz(j).eq. undef ) then - qp(:,j) = undef - else - do i=1,im - if( defined( q(i,j),undef) ) then - qp(i,j) = q(i,j) - qz(j) - else - qp(i,j) = undef - endif - enddo - endif - enddo - if (present(rc)) then - rc=_SUCCESS - endif - end subroutine latlon_zstar - - subroutine latlon_zmean ( q,qz,undef,grid,rc) - real, intent(inout) :: q(:,:) - real, intent(inout) :: qz(:) - real, intent(in) :: undef - type(ESMF_Grid), intent(inout) :: grid - integer, optional, intent(out) :: rc - - integer :: im,jm,im_global,jm_global,local_dims(3),global_dims(3),status,nx,ny - real, allocatable :: qg(:,:) - real, allocatable :: buf(:,:) - real :: qsum - integer :: mpistatus(mpi_status_size) - integer, allocatable :: ims(:),jms(:) - integer j,n,peid,peid0,i1,j1,in,jn,mypet,i_start,i_end,isum - type(ESMF_VM) :: vm - - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm,localPet=mypet,_RC) - call MAPL_GridGet(grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) - im = local_dims(1) - jm = local_dims(2) - im_global = global_dims(1) - jm_global = global_dims(2) - call get_esmf_grid_layout(grid,nx,ny,ims,jms,_RC) - call mapl_grid_interior(grid,i1,in,j1,jn) - - qz = 0.0 - allocate( qg(im_global,jm) ) - peid0 = (mypet/nx)*ny - if (i1==1) then - i_start = 1 - i_end = ims(1) - qg(i_start:i_end,:)=q - do n=1,nx-1 - allocate(buf(ims(n+1),jm)) - peid = mypet + n - call mpi_recv(buf,ims(n+1)*jm,MPI_FLOAT,peid,peid,MPI_COMM_WORLD,mpistatus,status) - _VERIFY(status) - i_start=i_end+1 - i_end = i_start+ims(n)-1 - qg(i_start:i_end,:)=buf - deallocate(buf) - enddo - else - call mpi_send(q,im*jm,MPI_FLOAT,peid0,mypet,MPI_COMM_WORLD,status) - _VERIFY(status) - end if - -! compute zonal mean - if (i1 == 1) then - do j=1,jm - isum = count(qg(:,j) /= undef) - qsum = sum(qg(:,j),mask=qg(:,j)/=undef) - if (isum == 0) then - qz(j)=undef - else - qz(j)=qsum/real(isum) - end if - enddo - -! send mean back to other ranks - do n=1,nx-1 - peid = peid0+n - call mpi_send(qz,jm,MPI_FLOAT,peid,peid0,MPI_COMM_WORLD,status) - _VERIFY(status) - enddo - else - call mpi_recv(qz,jm,MPI_FLOAT,peid0,peid0,MPI_COMM_WORLD,mpistatus,status) - _VERIFY(status) - end if - - if (present(rc)) then - rc=_SUCCESS - endif - - end subroutine latlon_zmean - - subroutine get_esmf_grid_layout(grid,nx,ny,ims_out,jms_out,rc) - type(ESMF_Grid), intent(inout) :: grid - integer, intent(out) :: nx - integer, intent(out) :: ny - integer, intent(inout), allocatable :: ims_out(:) - integer, intent(inout), allocatable :: jms_out(:) - integer, optional, intent(out) :: rc - - type(ESMF_VM) :: vm - integer :: status - type(ESMF_DistGrid) :: dist_grid - integer, allocatable :: minindex(:,:),maxindex(:,:) - integer :: dim_count, ndes - integer, pointer :: ims(:),jms(:) - - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm,petCount=ndes,_RC) - call ESMF_GridGet(grid,distgrid=dist_grid,dimCOunt=dim_count,_RC) - allocate(minindex(dim_count,ndes),maxindex(dim_count,ndes)) - call MAPL_DistGridGet(dist_grid,minIndex=minindex,maxIndex=maxindex,_RC) - call MAPL_GetImsJms(minindex(1,:),maxindex(1,:),minindex(2,:),maxindex(2,:),ims,jms,_RC) - nx = size(ims) - ny = size(jms) - allocate(ims_out(nx),jms_out(ny)) - ims_out = ims - jms_out = jms - - if (present(rc)) then - rc=_SUCCESS - endif - - end subroutine get_esmf_grid_layout - - subroutine check_quad ( quad,vname,nvars,aliases,nalias,qloc ) - integer :: nvars, nalias - character(len=ESMF_MAXSTR) quad(2), aliases(2,nalias), vname(nvars) - integer qloc(2) - integer m,n - -! Initialize Location of Quadratics -! --------------------------------- - qloc = 0 - -! Check Quadratic Name against HDF Variable Names -! ----------------------------------------------- - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(1)) ) qloc(1) = n - if( trim(vname(n)).eq.trim(quad(2)) ) qloc(2) = n - enddo - -! Check Quadratic Name against Aliases -! ------------------------------------ - do m=1,nalias - if( trim(quad(1)).eq.trim(aliases(1,m)) ) then - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(1)) .or. & - trim(vname(n)).eq.trim(aliases(2,m)) ) then - qloc(1) = n - exit - endif - enddo - endif - if( trim(quad(2)).eq.trim(aliases(1,m)) ) then - do n=1,nvars - if( trim(vname(n)).eq.trim(quad(2)) .or. & - trim(vname(n)).eq.trim(aliases(2,m)) ) then - qloc(2) = n - exit - endif - enddo - endif - enddo - - end subroutine check_quad - - function compute_nsecf (nhms) result(seconds) - integer :: seconds - integer, intent(in) :: nhms - seconds = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) - end function compute_nsecf - - function compute_nhmsf (nsec) result(nhmsf) - integer :: nhmsf - integer, intent(in) :: nsec - nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) - end function compute_nhmsf - - subroutine tick (nymd,nhms,ndt) - integer, intent(inout) :: nymd - integer, intent(inout) :: nhms - integer, intent(in) :: ndt - - integer :: nsec - - if(ndt.ne.0) then - nsec = compute_nsecf(nhms) + ndt - - if (nsec.gt.86400) then - do while (nsec.gt.86400) - nsec = nsec - 86400 - nymd = compute_incymd (nymd,1) - enddo - endif - - if (nsec.eq.86400) then - nsec = 0 - nymd = compute_incymd (nymd,1) - endif - - if (nsec.lt.00000) then - do while (nsec.lt.0) - nsec = 86400 + nsec - nymd = compute_incymd (nymd,-1) - enddo - endif - - nhms = compute_nhmsf (nsec) - endif - - end subroutine tick - - function compute_incymd (nymd,m) result(incymd) - integer :: incymd - integer, intent(in) :: nymd - integer, intent(in) :: m -!*********************************************************************** -! purpose -! incymd: nymd changed by one day -! modymd: nymd converted to julian date -! description of parameters -! nymd current date in yymmdd format -! m +/- 1 (day adjustment) -! -!*********************************************************************** -!* goddard laboratory for atmospheres * -!*********************************************************************** - - integer ndpm(12) - data ndpm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - integer :: ny,nm,nd -!*********************************************************************** -! - ny = nymd / 10000 - nm = mod(nymd,10000) / 100 - nd = mod(nymd,100) + m - - if (nd.eq.0) then - nm = nm - 1 - if (nm.eq.0) then - nm = 12 - ny = ny - 1 - endif - nd = ndpm(nm) - if (nm.eq.2 .and. is_leap_year(ny)) nd = 29 - endif - - if (nd.eq.29 .and. nm.eq.2 .and. is_leap_year(ny)) go to 20 - - if (nd.gt.ndpm(nm)) then - nd = 1 - nm = nm + 1 - if (nm.gt.12) then - nm = 1 - ny = ny + 1 - endif - endif - -20 continue - incymd = ny*10000 + nm*100 + nd - return - - end function compute_incymd - - logical function is_leap_year(year) - integer, intent(in) :: year - is_leap_year = (mod(year,4) == 0) .and. (mod(year,100) == 0 .or. mod(year,400) == 0) - end function is_leap_year - - subroutine usage(root) - logical, intent(in) :: root - integer :: status,errorcode - if(root) then - write(6,100) -100 format( "usage: ",/,/ & - " time_ave.x -hdf filenames (in hdf format)",/ & - " <-template template>" ,/ & - " <-tag tag>" ,/ & - " <-rc rcfile>" ,/ & - " <-ntod ntod>" ,/ & - " <-ntmin ntmin>" ,/ & - " <-strict strict>" ,/ & - " <-d>" ,/ & - " <-md>" ,/,/ & - "where:",/,/ & - " -hdf filenames: filenames (in hdf format) to average",/ & - " -template template: filename to use as template if hdf files differ (default: 1st filename)",/ & - " -begdate yyyymmdd: optional parameter for date to begin averaging",/ & - " -begtime hhmmss: optional parameter for time to begin averaging",/ & - " -enddate yyyymmdd: optional parameter for date to end averaging",/ & - " -endtime hhmmss: optional parameter for time to end averaging",/ & - " -tag tag: optional tag for output file (default: monthly_ave)",/ & - " -rc rcfile: optional resource filename for quadratics (default: no quadratics)",/ & - " -ntod ntod: optional time-of-day (hhmmss) to average (default: all time periods)",/ & - " -ntmin ntmin: optional parameter for required min. timeperiods (default: 10 days equiv)",/ & - " -strict strict: optional logical parameter for strict time testing (default: .true.)",/ & - " -d dtag: optional parameter to create & tag monthly mean diurnal file ", & - "(all times included)",/ & - " -md dtag: optional parameter to create & tag multiple monthly mean diurnal files ", & - "(one time per file)",/ & - " -dv dtag: like -d but includes diurnal variances",/ & - " -mdv dtag: like -md but includes diurnal variances",/ & - ) - endif - call MPI_Abort(MPI_COMM_WORLD,errorcode,status) - end subroutine usage - - subroutine generate_report() - - character(:), allocatable :: report_lines(:) - integer :: i - character(1) :: empty(0) - - reporter = ProfileReporter(empty) - call reporter%add_column(NameColumn(20)) - call reporter%add_column(FormattedTextColumn('Inclusive','(f9.6)', 9, InclusiveColumn('MEAN'))) - call reporter%add_column(FormattedTextColumn('% Incl','(f6.2)', 6, PercentageColumn(InclusiveColumn('MEAN'),'MAX'))) - call reporter%add_column(FormattedTextColumn('Exclusive','(f9.6)', 9, ExclusiveColumn('MEAN'))) - call reporter%add_column(FormattedTextColumn('% Excl','(f6.2)', 6, PercentageColumn(ExclusiveColumn('MEAN')))) - call reporter%add_column(FormattedTextColumn(' Max Excl)','(f9.6)', 9, ExclusiveColumn('MAX'))) - call reporter%add_column(FormattedTextColumn(' Min Excl)','(f9.6)', 9, ExclusiveColumn('MIN'))) - call reporter%add_column(FormattedTextColumn('Max PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MAX_PE'))) - call reporter%add_column(FormattedTextColumn('Min PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MIN_PE'))) - report_lines = reporter%generate_report(t_prof) - if (mapl_am_I_root()) then - write(*,'(a)')'Final profile' - write(*,'(a)')'=============' - do i = 1, size(report_lines) - write(*,'(a)') report_lines(i) - end do - write(*,'(a)') '' - end if - end subroutine generate_report - - -end program time_ave + + fn='/Users/yyu11/ModelData/Data_geosrun_2023/GOES-16-ABI/OR_ABI-L1b-RadF-M6C04_G16_s20192340800216_e20192340809524_c20192340809552.nc' + + kx='x' + ky='y' + call get_ncfile_dimension(fn, nlon=nx, nlat=ny, key_lon=kx, key_lat=ky, _RC) + write(6,121) 'nx, ny', nx, ny + + allocate(x(nx)) + allocate(y(ny)) + call get_v1d_netcdf_R8_complete (fn, kx, x, _RC) + call get_v1d_netcdf_R8_complete (fn, ky, y, _RC) + write(6, 101) 'x=', x + write(6, 101) 'y=', y + + var_name_proj='goes_imager_projection' + att_name_proj='longitude_of_projection_origin' + call get_att1d_netcdf( fn, var_name_proj, att_name_proj, lambda0_deg, _RC) + lambda0 = lambda0_deg/180.d0*4.d0*atan(1.d0) + + write(6, 101) 'lambda0=', lambda0 + + include '/Users/yyu11/sftp/myformat.inc' + end program ABI_fixed_coord diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 96ada969b733..6db18e22d880 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -11,7 +11,14 @@ module MAPL_ObsUtilMod use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none integer, parameter :: mx_ngeoval = 60 -!! private + ! GRS80 by Moritz + real(REAL64) :: a=6378137.d0 + real(REAL64) :: b=6356752.31414d0 + real(REAL64) :: H=42164160.d0 + ! GOES-R + real(REAL64) :: lambda0_SatE=-1.308996939d0 ! -75 deg Satellite East + real(REAL64) :: lambda0_SatW=-2.39110107523d0 ! -137 deg Satellite West + real(REAL64) :: lambda0_SatT=-1.56206968053d0 ! -89.5 deg Satellite Test public :: obs_unit type :: obs_unit @@ -723,4 +730,62 @@ function union_platform(a, b, rc) end function union_platform + ! From GOES-R SERIES PRODUCT DEFINITION AND USERS’ GUIDE + ! + subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, outRange) + implicit none + real(REAL64), intent(in) :: x, y + real(REAL64), intent(in) :: lambda0 + real(REAL64), intent(out):: lon, lat + integer,intent(out):: outRange + real(REAL64) :: a0, b0, c0, rs, Sx, Sy, Sz, t + + a0 = sin(x)*sin(x) + cos(x)*cos(x)*( cos(y)*cos(y) + (a/b)*(a/b)*sin(y)*sin(y) ) + b0 = -2.d0 * H * cos(x) * cos(y) + c0 = H*H - a*a + rs = ( -b0 - sqrt(b0*b0 - 4.d0*a0*c0) ) / (2.d0*a0) + Sx = rs * cos(x) * cos(y) + Sy = -rs * sin(x) + Sz = rs * cos(x) * sin(y) + lon = lambda0 - atan (Sy/(H - Sx)) + lat = atan ( (a/b)**2.d0 * Sz / sqrt ((H -Sx)**2.d0 + Sy*Sy) ) + + t = H*(H-Sx) - ( Sy*Sy + (a/b)**2.d0 *Sz*Sz ) + if (t < 0) then + outRange = 1 + else + outRange = 0 + end if + + end subroutine ABI_XY_2_lonlat + + + subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, outRange) + implicit none + real(REAL64), intent(in) :: lon, lat + real(REAL64), intent(in) :: lambda0 + real(REAL64), intent(out):: x, y + integer,intent(out):: outRange + real(REAL64) :: theta_c + real(REAL64) :: e2, rc, Sx, Sy, Sz, t + + theta_c = atan( (b/a)**2.d0 * tan(lat) ) + e2 = 1.d0 - (b/a)**2.d0 ! (a^2-b^2)/a^2 + rc = b / sqrt( 1.d0 - e2 * cos(theta_c)**2.d0 ) + Sx = H - rc * cos(theta_c) * cos( lon - lambda0 ) + Sy = - rc * cos(theta_c) * sin( lon - lambda0 ) + Sz = rc * sin(theta_c) + x = - asin ( Sy / sqrt (Sx*Sx + Sy*Sy + Sz*Sz) ) + y = atan ( Sz / Sx ) + + t = H*(H-Sx) - ( Sy*Sy + (a/b)**2.d0 *Sz*Sz ) + if (t < 0) then + outRange = 1 + else + outRange = 0 + end if + + end subroutine lonlat_2_ABI_XY + + end module MAPL_ObsUtilMod diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index 503c4678ae1a..0d3f02276231 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -238,32 +238,77 @@ subroutine get_v1d_netcdf_R8(filename, name, array, Xdim, group_name, rc) end subroutine get_v1d_netcdf_R8 - subroutine get_v1d_netcdf_R8_w_offset(filename, name, array, Xdim, group_name, rc) + subroutine get_v1d_netcdf_R8_complete(filename, varname, array, att_name, att_value, group_name, rc) use netcdf implicit none - character(len=*), intent(in) :: name, filename - character(len=*), optional, intent(in) :: group_name - integer, intent(in) :: Xdim - real(REAL64), dimension(Xdim), intent(out) :: array + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + real(REAL64), intent(inout) :: array(:) + character(len=*), optional, intent(in) :: att_name + real(REAL64), optional, intent(out) :: att_value + character(len=*), optional, intent(out) :: group_name integer, optional, intent(out) :: rc - integer :: status - integer :: ncid, varid, ncid2 + integer :: status, iret + integer :: ncid, ncid_grp, ncid_sv + integer :: varid + real(REAL32) :: scale_factor, add_offset + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid if(present(group_name)) then - ncid2= ncid - call check_nc_status(nf90_inq_ncid(ncid2, group_name, ncid), _RC) + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! mod + ncid = ncid_grp end if - call check_nc_status(nf90_inq_varid(ncid, name, varid), _RC) + call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) call check_nc_status(nf90_get_var(ncid, varid, array), _RC) + + iret = nf90_get_att(ncid, varid, 'scale_factor', scale_factor) + if(iret .eq. 0) array = array * scale_factor + ! + iret = nf90_get_att(ncid, varid, 'add_offset', add_offset) + if(iret .eq. 0) array = array + add_offset + + if(present(att_name)) then + call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) + end if + + call check_nc_status(nf90_close(ncid_sv), _RC) + + _RETURN(_SUCCESS) + + end subroutine get_v1d_netcdf_R8_complete + + + subroutine get_att1d_netcdf(filename, varname, att_name, att_value, group_name, rc) + use netcdf + implicit none + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(REAL64), intent(out) :: att_value + character(len=*), optional, intent(out) :: group_name + integer, optional, intent(out) :: rc + integer :: status + integer :: ncid, ncid_grp, ncid_sv + integer :: varid + + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid if(present(group_name)) then - call check_nc_status(nf90_close(ncid2), _RC) - else - call check_nc_status(nf90_close(ncid), _RC) + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! overwrite + ncid = ncid_grp end if + call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) + call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) + call check_nc_status(nf90_close(ncid_sv), _RC) + _RETURN(_SUCCESS) - end subroutine + end subroutine get_att1d_netcdf + subroutine check_nc_status(status, rc) use netcdf From 0f6834c3ded35e9174ccb668ea26c632c7538233 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Tue, 16 Jan 2024 09:19:52 -0500 Subject: [PATCH 38/86] Update base/MAPL_XYGridFactory.F90 Co-authored-by: Tom Clune --- base/MAPL_XYGridFactory.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 31b8860276c9..533b2c6e7896 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -914,9 +914,7 @@ subroutine add_mask(this,grid,rc) if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) - if (has_undef == 0) then - _RETURN(_SUCCESS) - end if +_RETURN_IF(has_undef == 0) call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK,_RC) call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & From 44ee5089ebd97e25d84ef2f59d5717ea45c36f2c Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Tue, 16 Jan 2024 09:20:00 -0500 Subject: [PATCH 39/86] Update base/MAPL_XYGridFactory.F90 Co-authored-by: Tom Clune --- base/MAPL_XYGridFactory.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 533b2c6e7896..69a002316d60 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -909,7 +909,7 @@ subroutine add_mask(this,grid,rc) call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, rc=status) + farrayPtr=fptr, _RC) local_has_undef = 0 if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 call ESMF_VMGetCurrent(vm,_RC) From 1aa5ab1afac7a342fd33ab1e06f8c4e3411159a2 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 16 Jan 2024 11:01:56 -0500 Subject: [PATCH 40/86] Explicitly use iso_c_binding types This PR adds two explicit `use` of two `iso_c_binding` types that currently are brought in (inadvertently) via `use ESMF`. This has been fixed in ESMF upstream (`develop` at least), so this fix is in anticipation of ESMF 8.7 testing. --- CHANGELOG.md | 3 +++ base/Plain_netCDF_Time.F90 | 5 +++-- field_utils/FieldPointerUtilities.F90 | 12 ++++++------ 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c50ea8f9ef5f..e91fbd76dc26 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Explictly `use` some `iso_c_binding` types previously pulled in through ESMF. This is fixed in future ESMF versions (8.7+) and so + we anticipate this here + ### Removed ### Deprecated diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index be20b3d76bb1..8bc269aa391e 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -25,6 +25,7 @@ module Plain_netCDF_Time ! use MAPL_CommsMod use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_c_binding, only: C_INT implicit none public @@ -451,7 +452,7 @@ subroutine bisect_find_LB_R8_I8(xa, x, n, n_LB, n_UB, rc) if(present(n_LB)) LB=max(LB, n_LB) if(present(n_UB)) UB=min(UB, n_UB) klo=LB; khi=UB; dk=1 - + if ( xa(LB ) > xa(UB) ) then klo= UB khi= LB @@ -673,7 +674,7 @@ function matches( string, substring ) RETURN end function matches - + subroutine split_string_by_space (string_in, length_mx, & mxseg, nseg, str_piece, jstatus) integer, intent (in) :: length_mx diff --git a/field_utils/FieldPointerUtilities.F90 b/field_utils/FieldPointerUtilities.F90 index b1a22258fcc8..8773ccd83436 100644 --- a/field_utils/FieldPointerUtilities.F90 +++ b/field_utils/FieldPointerUtilities.F90 @@ -3,7 +3,7 @@ module MAPL_FieldPointerUtilities use ESMF use MAPL_ExceptionHandling - use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer + use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_loc implicit none private @@ -483,14 +483,14 @@ logical function are_broadcast_conformable(x, y, rc) result(conformable) integer, dimension(:), allocatable :: count_x, count_y integer :: status logical :: normal_conformable - + conformable = .false. ! this should really used the geom and ungridded dims ! for now we will do this until we have a geom agnostic stuff worked out... ! the ideal algorithm would be if geom == geom and input does not have ungridded ! and thing we are copying to does, then we are "conformable" normal_conformable = FIeldsAreConformable(x,y,_RC) - + if (normal_conformable) then conformable = .true. _RETURN(_SUCCESS) @@ -842,7 +842,7 @@ subroutine MAPL_FieldGetLocalElementCount(field,local_count,rc) else _FAIL("Unsupported rank") end if - else + else _FAIL("Unsupported type") end if _RETURN(_SUCCESS) @@ -871,7 +871,7 @@ subroutine GetFieldsUndef_r4(fields,undef_values,rc) integer :: status, i logical :: isPresent - + allocate(undef_values(size(fields))) do i =1,size(fields) call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) @@ -888,7 +888,7 @@ subroutine GetFieldsUndef_r8(fields,undef_values,rc) integer :: status, i logical :: isPresent - + allocate(undef_values(size(fields))) do i =1,size(fields) call ESMF_AttributeGet(fields(i),name="missing_value",isPresent=isPresent,_RC) From 35d161fcd22c052645dbbc6c88f9b3de5c2d23ff Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 16 Jan 2024 15:16:43 -0700 Subject: [PATCH 41/86] WIP --- base/MAPL_SwathGridFactory.F90 | 3 + base/MAPL_XYGridFactory.F90 | 162 +++++++++++++++++++++++++-------- base/Plain_netCDF_Time.F90 | 34 ++++++- 3 files changed, 156 insertions(+), 43 deletions(-) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 7ce23e8ab65f..cc659a862b1c 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -480,6 +480,9 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%epoch, label=prefix//'Epoch:', default=300, _RC) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'Epoch_init:', default='2006', _RC) + write(6,'(2x,a,100i10)') 'nail 2, nx,ny,im,jm,lm',& + this%nx,this%ny,this%im_world,this%jm_world,this%lm + call lgr%debug(' %a %a', 'CurrTime =', trim(tmp)) if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 31b8860276c9..ddf656760e4b 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -13,6 +13,8 @@ module MAPL_XYGridFactoryMod use ESMF use pFIO use NetCDF + ! use Plain_netCDF_Time, only : get_ncfile_dimension + use Plain_netCDF_Time use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -38,6 +40,14 @@ module MAPL_XYGridFactoryMod logical :: has_corners logical :: initialized_from_metadata = .false. + + character(len=ESMF_MAXSTR) :: index_name_x + character(len=ESMF_MAXSTR) :: index_name_y + character(len=ESMF_MAXSTR) :: var_name_x + character(len=ESMF_MAXSTR) :: var_name_y + character(len=ESMF_MAXSTR) :: var_name_proj + character(len=ESMF_MAXSTR) :: att_name_proj + contains procedure :: make_new_grid procedure :: create_basic_grid @@ -45,7 +55,6 @@ module MAPL_XYGridFactoryMod procedure :: init_halo procedure :: halo - procedure :: initialize_from_file_metadata procedure :: initialize_from_config_with_prefix procedure :: initialize_from_esmf_distGrid @@ -104,7 +113,6 @@ function XYGridFactory_from_parameters(unusable, grid_file_name, grid_name, & integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'XYGridFactory_from_parameters' - if (present(unusable)) print*,shape(unusable) call set_with_default(factory%grid_name, grid_name, MAPL_GRID_NAME_DEFAULT) @@ -116,12 +124,8 @@ function XYGridFactory_from_parameters(unusable, grid_file_name, grid_name, & call set_with_default(factory%jm_world, jm_world, MAPL_UNDEFINED_INTEGER) call set_with_default(factory%lm, lm, MAPL_UNDEFINED_INTEGER) - - - call factory%check_and_fill_consistency(rc=status) _VERIFY(status) - _RETURN(_SUCCESS) end function XYGridFactory_from_parameters @@ -138,12 +142,16 @@ function make_new_grid(this, unusable, rc) result(grid) _UNUSED_DUMMY(unusable) - grid = this%create_basic_grid(rc=status) - _VERIFY(status) - + write(6,'(2x,a)') 'bf create_basic_grid' + grid = this%create_basic_grid(_RC) + write(6,'(2x,a)') 'bf add_horz_coordinates_from_file' call this%add_horz_coordinates_from_file(grid, _RC) - call this%add_mask(grid,_RC) + write(6,'(2x,a)') 'bf add_mask' + _FAIL('nail -2') + + call this%add_mask(grid,_RC) + write(6,'(2x,a)') 'af add_mask' _RETURN(_SUCCESS) end function make_new_grid @@ -170,8 +178,7 @@ function create_basic_grid(this, unusable, rc) result(grid) gridEdgeUWidth=[0,1], & coordDep1=[1,2], & coordDep2=[1,2], & - coordSys=ESMF_COORDSYS_SPH_RAD, rc=status) - _VERIFY(status) + coordSys=ESMF_COORDSYS_SPH_RAD, _RC) ! Allocate coords at default stagger location call ESMF_GridAddCoord(grid, rc=status) @@ -183,13 +190,12 @@ function create_basic_grid(this, unusable, rc) result(grid) _VERIFY(status) if (this%lm /= MAPL_UNDEFINED_INTEGER) then - call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, rc=status) - _VERIFY(status) + call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, _RC) end if - call ESMF_AttributeSet(grid, 'GridType', 'XY', rc=status) - _VERIFY(status) - +!! why? Ben +!! call ESMF_AttributeSet(grid, 'GridType', 'XY', _RC) + call ESMF_AttributeSet(grid, 'GridType', 'latlon', _RC) _RETURN(_SUCCESS) end function create_basic_grid @@ -208,26 +214,36 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) integer :: i_1,i_n,j_1,j_n, ncid, varid integer :: ic_1,ic_n,jc_1,jc_n ! regional corner bounds - real, pointer :: centers(:,:), corners(:,:) + real, pointer :: centers(:,:), corners(:,:) + real(REAL64), allocatable :: arr_lon(:,:) + real(REAL64), allocatable :: arr_lat(:,:) + real(REAL64), allocatable :: x(:,:) + real(REAL64), allocatable :: y(:,:) + real(REAL64) :: lambda0_deg, lambda0 + real(ESMF_KIND_R8), pointer :: fptr(:,:) integer :: IM, JM integer :: IM_WORLD, JM_WORLD integer :: COUNTS(3), DIMS(3) + integer :: npoints character(len=:), allocatable :: lon_center_name, lat_center_name, lon_corner_name, lat_corner_name + character(len=ESMF_MAXSTR) :: fn + character(len=ESMF_MAXSTR) :: key_x, key_y, key_p, key_p_att, unit _UNUSED_DUMMY(unusable) - lon_center_name = "lons" - lat_center_name = "lats" - lon_corner_name = "corner_lons" - lat_corner_name = "corner_lats" - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, RC=STATUS) - _VERIFY(STATUS) + lon_center_name = this%var_name_x + lat_center_name = this%var_name_y + lon_corner_name = "corner_"//trim(lon_center_name) + lat_corner_name = "corner_"//trim(lat_center_name) + + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, _RC) IM = COUNTS(1) JM = COUNTS(2) IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) + npoints = IM_WORLD * JM_WORLD call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) ic_1=i_1 @@ -240,6 +256,46 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) jc_n=j_n end if + !- read lon/lat + ! + call MAPL_AllocateShared(arr_lon,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) + call MAPL_SyncSharedMemory(_RC) + write(6,*) 'grid_name', trim(adjustl(this%grid_name)) + + fn = this%grid_file_name + key_x = this%var_name_x + key_y = this%var_name_y + key_p = this%var_name_proj + key_p_att = this%att_name_proj + if (mapl_am_i_root()) then + call get_v1d_netcdf_R8_complete (fn, key_x, arr_lon, _RC) + call get_v1d_netcdf_R8_complete (fn, key_y, arr_lat, _RC) + call get_att_char_netcdf( fn, key_x, 'units', unit, _RC) + if ( index(unit, 'rad') == 0 ) then + arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 + arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 + end if + write(6, 101) 'arr_lon=', arr_lon + write(6, 101) 'arr_lat=', arr_lat + + ! + ! add mask + ! + if ( index(trim(adjustl(this%grid_name)), 'ABI') > 0 ) then + write(6,*) 'in ABI' + call get_att_real_netcdf( fn, key_p, key_p_att, lambda0_deg, _RC) + lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + end if + + ! ... + + ! write(6,*) 'in root' + ! write(6,'(11x,100f10.1)') arr_lon(::5,189) + end if + call MAPL_SyncSharedMemory(_RC) + + if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then status = nf90_open(this%grid_file_name,NF90_NOWRITE,ncid) _VERIFY(status) @@ -263,6 +319,8 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=fptr, rc=status) fptr=centers(i_1:i_n,j_1:j_n) + + ! do latitudes call MAPL_SyncSharedMemory(_RC) @@ -286,6 +344,8 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) else deallocate(centers) end if + + !! now repeat for corners if (this%has_corners) then call MAPL_AllocateShared(corners,[im_world+1,jm_world+1],transroot=.true.,_RC) @@ -337,6 +397,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) end if _RETURN(_SUCCESS) + include '/Users/yyu11/sftp/myformat.inc' end subroutine add_horz_coordinates_from_file @@ -391,27 +452,52 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer :: status character(len=*), parameter :: Iam = MOD_NAME//'make_geos_grid_from_config' character(len=ESMF_MAXSTR) :: tmp - + integer :: n1, n2 + integer :: arr(2) + type(ESMF_VM) :: vm + if (present(unusable)) print*,shape(unusable) - call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT) + call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT, _RC) this%grid_name = trim(tmp) - - call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDSPEC:', rc=status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRID_FILENAME:', default='', _RC) this%grid_file_name = trim(tmp) - call ESMF_ConfigGetAttribute(config, this%nx, label=prefix//'NX:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%ny, label=prefix//'NY:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%im_world, label=prefix//'IM_WORLD:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%jm_world, label=prefix//'JM_WORLD:', default=MAPL_UNDEFINED_INTEGER) - call ESMF_ConfigGetAttribute(config, this%lm, label=prefix//'LM:', default=MAPL_UNDEFINED_INTEGER) + call ESMF_ConfigGetAttribute(config, this%nx, label=prefix//'NX:', default=MAPL_UNDEFINED_INTEGER, _RC) + call ESMF_ConfigGetAttribute(config, this%ny, label=prefix//'NY:', default=MAPL_UNDEFINED_INTEGER, _RC) + call ESMF_ConfigGetAttribute(config, this%lm, label=prefix//'LM:', default=MAPL_UNDEFINED_INTEGER, _RC) + call ESMF_ConfigGetAttribute(config, this%index_name_x, label=prefix//'index_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, this%index_name_y, label=prefix//'index_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_x, label=prefix//'var_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_y, label=prefix//'var_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_proj,label=prefix//'var_name_proj:', default="", _RC) + call ESMF_ConfigGetAttribute(config, this%att_name_proj,label=prefix//'att_name_proj:', default="", _RC) + + if (mapl_am_i_root()) then + call get_ncfile_dimension(this%grid_file_name, nlon=n1, nlat=n2, & + key_lon=this%index_name_x, key_lat=this%index_name_y, _RC) + arr(1)=n1 + arr(2)=n2 + end if + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMBroadcast (vm, arr, 2, 0, _RC) + this%im_world = arr(1) + this%jm_world = arr(2) + + write(6,'(2x,a,100i10)') 'nail 2, nx,ny,im,jm,lm',& + this%nx,this%ny,this%im_world,this%jm_world,this%lm + write(6,'(2x,a,10(2x,a))') 'var_name_proj, var_name_proj', & + trim(this%var_name_proj), trim(this%att_name_proj) + + call this%check_and_fill_consistency(rc=status) _RETURN(_SUCCESS) - contains + include '/Users/yyu11/sftp/myformat.inc' + + contains subroutine get_multi_integer(values, label, rc) integer, allocatable, intent(out) :: values(:) @@ -485,8 +571,8 @@ subroutine check_and_fill_consistency(this, unusable, rc) this%grid_name = MAPL_GRID_NAME_DEFAULT end if ! local extents - call verify(this%nx, this%im_world, this%ims, rc=status) - call verify(this%ny, this%jm_world, this%jms, rc=status) + call verify(this%nx, this%im_world, this%ims, _RC) + call verify(this%ny, this%jm_world, this%jms, _RC) call this%file_has_corners(_RC) _RETURN(_SUCCESS) @@ -517,13 +603,11 @@ subroutine verify(n, m_world, ms, rc) end if else - _ASSERT(n /= MAPL_UNDEFINED_INTEGER,"needs message") _ASSERT(m_world /= MAPL_UNDEFINED_INTEGER,"needs message") allocate(ms(n), stat=status) _VERIFY(status) call MAPL_DecomposeDim(m_world, ms, n) - end if _RETURN(_SUCCESS) diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index 0d3f02276231..9429800cb6c8 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -28,8 +28,6 @@ module Plain_netCDF_Time implicit none public - integer, parameter :: NUM_DIM = 2 - interface convert_time_nc2esmf procedure :: time_nc_int_2_esmf end interface convert_time_nc2esmf @@ -281,7 +279,7 @@ subroutine get_v1d_netcdf_R8_complete(filename, varname, array, att_name, att_va end subroutine get_v1d_netcdf_R8_complete - subroutine get_att1d_netcdf(filename, varname, att_name, att_value, group_name, rc) + subroutine get_att_real_netcdf(filename, varname, att_name, att_value, group_name, rc) use netcdf implicit none character(len=*), intent(in) :: filename @@ -307,7 +305,35 @@ subroutine get_att1d_netcdf(filename, varname, att_name, att_value, group_name, _RETURN(_SUCCESS) - end subroutine get_att1d_netcdf + end subroutine get_att_real_netcdf + + subroutine get_att_char_netcdf(filename, varname, att_name, att_value, group_name, rc) + use netcdf + implicit none + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + character(len=*), intent(out) :: att_value + character(len=*), optional, intent(out) :: group_name + integer, optional, intent(out) :: rc + integer :: status + integer :: ncid, ncid_grp, ncid_sv + integer :: varid + + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) + ncid_sv = ncid + if(present(group_name)) then + call check_nc_status(nf90_inq_ncid(ncid, group_name, ncid_grp), _RC) + ! overwrite + ncid = ncid_grp + end if + call check_nc_status(nf90_inq_varid(ncid, varname, varid), _RC) + call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) + call check_nc_status(nf90_close(ncid_sv), _RC) + + _RETURN(_SUCCESS) + + end subroutine get_att_char_netcdf subroutine check_nc_status(status, rc) From b6bf541a4ce3e072148710ab41b19786e748eaa5 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 16 Jan 2024 16:47:15 -0700 Subject: [PATCH 42/86] I attempted to add to MAPL_XYGridFactory.F90 a new subroutine add_horz_coordinates_from_ABIfile. Compilation error: ADD_HORZ_COORDINATES_FROM_ABIFILE is not a component of THIS. --- base/MAPL_XYGridFactory.F90 | 227 +++++++++++++++++++++++++----------- 1 file changed, 161 insertions(+), 66 deletions(-) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index ddf656760e4b..8f526fb5f27b 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -145,12 +145,17 @@ function make_new_grid(this, unusable, rc) result(grid) write(6,'(2x,a)') 'bf create_basic_grid' grid = this%create_basic_grid(_RC) write(6,'(2x,a)') 'bf add_horz_coordinates_from_file' - call this%add_horz_coordinates_from_file(grid, _RC) - write(6,'(2x,a)') 'bf add_mask' - _FAIL('nail -2') + if ( index(trim(adjustl(this%grid_name)), 'ABI') == 0 ) then + call this%add_horz_coordinates_from_file(grid, _RC) + call this%add_mask(grid,_RC) + else + call this%add_horz_coordinates_from_ABIfile(grid, _RC) + end if + - call this%add_mask(grid,_RC) + _FAIL('nail -2') + write(6,'(2x,a)') 'af add_mask' _RETURN(_SUCCESS) @@ -199,6 +204,7 @@ function create_basic_grid(this, unusable, rc) result(grid) _RETURN(_SUCCESS) end function create_basic_grid + subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) use MAPL_BaseMod, only: MAPL_grid_interior, MAPL_gridget use MAPL_CommsMod @@ -214,36 +220,26 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) integer :: i_1,i_n,j_1,j_n, ncid, varid integer :: ic_1,ic_n,jc_1,jc_n ! regional corner bounds - real, pointer :: centers(:,:), corners(:,:) - real(REAL64), allocatable :: arr_lon(:,:) - real(REAL64), allocatable :: arr_lat(:,:) - real(REAL64), allocatable :: x(:,:) - real(REAL64), allocatable :: y(:,:) - real(REAL64) :: lambda0_deg, lambda0 - + real, pointer :: centers(:,:), corners(:,:) real(ESMF_KIND_R8), pointer :: fptr(:,:) integer :: IM, JM integer :: IM_WORLD, JM_WORLD integer :: COUNTS(3), DIMS(3) - integer :: npoints character(len=:), allocatable :: lon_center_name, lat_center_name, lon_corner_name, lat_corner_name - character(len=ESMF_MAXSTR) :: fn - character(len=ESMF_MAXSTR) :: key_x, key_y, key_p, key_p_att, unit _UNUSED_DUMMY(unusable) - lon_center_name = this%var_name_x - lat_center_name = this%var_name_y - lon_corner_name = "corner_"//trim(lon_center_name) - lat_corner_name = "corner_"//trim(lat_center_name) - - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, _RC) + lon_center_name = "lons" + lat_center_name = "lats" + lon_corner_name = "corner_lons" + lat_corner_name = "corner_lats" + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, RC=STATUS) + _VERIFY(STATUS) IM = COUNTS(1) JM = COUNTS(2) IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) - npoints = IM_WORLD * JM_WORLD call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) ic_1=i_1 @@ -256,46 +252,6 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) jc_n=j_n end if - !- read lon/lat - ! - call MAPL_AllocateShared(arr_lon,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) - call MAPL_AllocateShared(arr_lat,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) - call MAPL_SyncSharedMemory(_RC) - write(6,*) 'grid_name', trim(adjustl(this%grid_name)) - - fn = this%grid_file_name - key_x = this%var_name_x - key_y = this%var_name_y - key_p = this%var_name_proj - key_p_att = this%att_name_proj - if (mapl_am_i_root()) then - call get_v1d_netcdf_R8_complete (fn, key_x, arr_lon, _RC) - call get_v1d_netcdf_R8_complete (fn, key_y, arr_lat, _RC) - call get_att_char_netcdf( fn, key_x, 'units', unit, _RC) - if ( index(unit, 'rad') == 0 ) then - arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 - arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 - end if - write(6, 101) 'arr_lon=', arr_lon - write(6, 101) 'arr_lat=', arr_lat - - ! - ! add mask - ! - if ( index(trim(adjustl(this%grid_name)), 'ABI') > 0 ) then - write(6,*) 'in ABI' - call get_att_real_netcdf( fn, key_p, key_p_att, lambda0_deg, _RC) - lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 - end if - - ! ... - - ! write(6,*) 'in root' - ! write(6,'(11x,100f10.1)') arr_lon(::5,189) - end if - call MAPL_SyncSharedMemory(_RC) - - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then status = nf90_open(this%grid_file_name,NF90_NOWRITE,ncid) _VERIFY(status) @@ -319,8 +275,6 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=fptr, rc=status) fptr=centers(i_1:i_n,j_1:j_n) - - ! do latitudes call MAPL_SyncSharedMemory(_RC) @@ -344,8 +298,6 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) else deallocate(centers) end if - - !! now repeat for corners if (this%has_corners) then call MAPL_AllocateShared(corners,[im_world+1,jm_world+1],transroot=.true.,_RC) @@ -397,9 +349,151 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) end if _RETURN(_SUCCESS) - include '/Users/yyu11/sftp/myformat.inc' end subroutine add_horz_coordinates_from_file + + + subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) + use MAPL_BaseMod, only: MAPL_grid_interior, MAPL_gridget + use MAPL_CommsMod + use MAPL_IOMod + use MAPL_Constants + class (XYGridFactory), intent(in) :: this + type (ESMF_Grid), intent(inout) :: grid + class (KeywordEnforcer), optional, intent(in) :: unusable + integer, optional, intent(out) :: rc + + integer :: status + character(len=*), parameter :: Iam = MOD_NAME // 'add_horz_coordinates' + + integer :: i_1,i_n,j_1,j_n, ncid, varid + integer :: ic_1,ic_n,jc_1,jc_n ! regional corner bounds + real, pointer :: centers(:,:), corners(:,:) + real(REAL64), pointer :: arr_lon(:,:) + real(REAL64), pointer :: arr_lat(:,:) + real(REAL64), allocatable :: x(:) + real(REAL64), allocatable :: y(:) + real(REAL64) :: lambda0_deg, lambda0 + + real(ESMF_KIND_R8), pointer :: fptr(:,:) + + integer :: COUNTS(3), DIMS(3) + integer :: Xdim, Ydim, npoints + character(len=:), allocatable :: lon_center_name, lat_center_name, lon_corner_name, lat_corner_name + character(len=ESMF_MAXSTR) :: fn + character(len=ESMF_MAXSTR) :: key_x, key_y, key_p, key_p_att, unit + + _UNUSED_DUMMY(unusable) + + lon_center_name = this%var_name_x + lat_center_name = this%var_name_y + lon_corner_name = "corner_"//trim(lon_center_name) + lat_corner_name = "corner_"//trim(lat_center_name) + + call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, _RC) + Xdim = DIMS(1) + Ydim = DIMS(2) + npoints = Xdim * Ydim + + + !- read lon/lat + ! + call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) + call MAPL_AllocateShared(arr_lon,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) + call MAPL_SyncSharedMemory(_RC) + write(6,*) 'grid_name', trim(adjustl(this%grid_name)) + + fn = this%grid_file_name + key_x = this%var_name_x + key_y = this%var_name_y + key_p = this%var_name_proj + key_p_att = this%att_name_proj + if (mapl_am_i_root()) then + allocate (x(Xdim)) + allocate (y(Ydim)) + call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) + call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) + call get_att_char_netcdf( fn, key_x, 'units', unit, _RC) + if ( index(unit, 'rad') == 0 ) then + arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 + arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 + end if + write(6, 101) 'x=', x + write(6, 101) 'y=', y + + ! + ! add mask + ! + + write(6,*) 'in ABI' + call get_att_real_netcdf( fn, key_p, key_p_att, lambda0_deg, _RC) + lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + + + ! ... + + ! write(6,*) 'in root' + ! write(6,'(11x,100f10.1)') arr_lon(::5,189) + end if + call MAPL_SyncSharedMemory(_RC) + + + if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then + status = nf90_open(this%grid_file_name,NF90_NOWRITE,ncid) + _VERIFY(status) + end if + + call MAPL_AllocateShared(centers,[im_world,jm_world],transroot=.true.,_RC) + + call MAPL_SyncSharedMemory(_RC) + + ! do longitudes + if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then + status = nf90_inq_varid(ncid,lon_center_name,varid) + _VERIFY(status) + status = nf90_get_var(ncid,varid,centers) + _VERIFY(status) + where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 + end if + call MAPL_SyncSharedMemory(_RC) + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=fptr, rc=status) + fptr=centers(i_1:i_n,j_1:j_n) + + + ! do latitudes + + call MAPL_SyncSharedMemory(_RC) + if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then + status = nf90_inq_varid(ncid,lat_center_name,varid) + _VERIFY(status) + status = nf90_get_var(ncid,varid,centers) + _VERIFY(status) + where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 + end if + call MAPL_SyncSharedMemory(_RC) + + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=fptr, rc=status) + fptr=centers(i_1:i_n,j_1:j_n) + + call MAPL_SyncSharedMemory(_RC) + if(MAPL_ShmInitialized) then + call MAPL_DeAllocNodeArray(centers,_RC) + else + deallocate(centers) + end if + + + _RETURN(_SUCCESS) + include '/Users/yyu11/sftp/myformat.inc' + + end subroutine add_horz_coordinates_from_ABIfile + subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_file_coordinates, rc) use MAPL_KeywordEnforcerMod @@ -1012,4 +1106,5 @@ subroutine add_mask(this,grid,rc) _RETURN(_SUCCESS) end subroutine + end module MAPL_XYGridFactoryMod From 20e95cb29deae77ad9bc502de13aaf4ff43195da Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 16 Jan 2024 21:53:13 -0700 Subject: [PATCH 43/86] update --- Apps/abi_fixed_coord.F90 | 2 +- base/MAPL_XYGridFactory.F90 | 90 ++++++++----------------------------- 2 files changed, 20 insertions(+), 72 deletions(-) diff --git a/Apps/abi_fixed_coord.F90 b/Apps/abi_fixed_coord.F90 index 08f0a56a8087..485c7cf48595 100644 --- a/Apps/abi_fixed_coord.F90 +++ b/Apps/abi_fixed_coord.F90 @@ -38,7 +38,7 @@ program ABI_fixed_coord var_name_proj='goes_imager_projection' att_name_proj='longitude_of_projection_origin' - call get_att1d_netcdf( fn, var_name_proj, att_name_proj, lambda0_deg, _RC) + call get_att_real_netcdf( fn, var_name_proj, att_name_proj, lambda0_deg, _RC) lambda0 = lambda0_deg/180.d0*4.d0*atan(1.d0) write(6, 101) 'lambda0=', lambda0 diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 8f526fb5f27b..e166164a59ed 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -52,6 +52,7 @@ module MAPL_XYGridFactoryMod procedure :: make_new_grid procedure :: create_basic_grid procedure :: add_horz_coordinates_from_file + procedure :: add_horz_coordinates_from_ABIfile procedure :: init_halo procedure :: halo @@ -362,13 +363,9 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) type (ESMF_Grid), intent(inout) :: grid class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: status - character(len=*), parameter :: Iam = MOD_NAME // 'add_horz_coordinates' integer :: i_1,i_n,j_1,j_n, ncid, varid - integer :: ic_1,ic_n,jc_1,jc_n ! regional corner bounds - real, pointer :: centers(:,:), corners(:,:) real(REAL64), pointer :: arr_lon(:,:) real(REAL64), pointer :: arr_lat(:,:) real(REAL64), allocatable :: x(:) @@ -380,27 +377,25 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) integer :: COUNTS(3), DIMS(3) integer :: Xdim, Ydim, npoints character(len=:), allocatable :: lon_center_name, lat_center_name, lon_corner_name, lat_corner_name - character(len=ESMF_MAXSTR) :: fn - character(len=ESMF_MAXSTR) :: key_x, key_y, key_p, key_p_att, unit + character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att, unit + type(ESMF_VM) :: vm _UNUSED_DUMMY(unusable) lon_center_name = this%var_name_x lat_center_name = this%var_name_y - lon_corner_name = "corner_"//trim(lon_center_name) - lat_corner_name = "corner_"//trim(lat_center_name) call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, _RC) Xdim = DIMS(1) Ydim = DIMS(2) npoints = Xdim * Ydim - + ! !- read lon/lat ! call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(arr_lon,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) - call MAPL_AllocateShared(arr_lat,[IM_WORLD,JM_WORLD],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lon,[Xdim, Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) write(6,*) 'grid_name', trim(adjustl(this%grid_name)) @@ -420,77 +415,30 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 end if write(6, 101) 'x=', x - write(6, 101) 'y=', y + write(6, 101) 'y=', y + call get_att_real_netcdf(fn, key_p, key_p_att, lambda0_deg, _RC) + lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + write(6, 101) 'lambda0=', lambda0 + + + ! ... + ! ! add mask ! - write(6,*) 'in ABI' - call get_att_real_netcdf( fn, key_p, key_p_att, lambda0_deg, _RC) - lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 - - - ! ... - ! write(6,*) 'in root' ! write(6,'(11x,100f10.1)') arr_lon(::5,189) end if call MAPL_SyncSharedMemory(_RC) + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMbarrier(vm, _RC) - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - status = nf90_open(this%grid_file_name,NF90_NOWRITE,ncid) - _VERIFY(status) - end if - - call MAPL_AllocateShared(centers,[im_world,jm_world],transroot=.true.,_RC) - - call MAPL_SyncSharedMemory(_RC) - - ! do longitudes - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - status = nf90_inq_varid(ncid,lon_center_name,varid) - _VERIFY(status) - status = nf90_get_var(ncid,varid,centers) - _VERIFY(status) - where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 - end if - call MAPL_SyncSharedMemory(_RC) - - call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, rc=status) - fptr=centers(i_1:i_n,j_1:j_n) - - - ! do latitudes - - call MAPL_SyncSharedMemory(_RC) - if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then - status = nf90_inq_varid(ncid,lat_center_name,varid) - _VERIFY(status) - status = nf90_get_var(ncid,varid,centers) - _VERIFY(status) - where(centers /= MAPL_UNDEF) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 - end if - call MAPL_SyncSharedMemory(_RC) - - call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, rc=status) - fptr=centers(i_1:i_n,j_1:j_n) - - call MAPL_SyncSharedMemory(_RC) - if(MAPL_ShmInitialized) then - call MAPL_DeAllocNodeArray(centers,_RC) - else - deallocate(centers) - end if - - - _RETURN(_SUCCESS) - include '/Users/yyu11/sftp/myformat.inc' + + _RETURN(_SUCCESS) + include '/Users/yyu11/sftp/myformat.inc' end subroutine add_horz_coordinates_from_ABIfile From ff0a2051b2e4b0d94bf96edd542844c4f6273cdd Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 17 Jan 2024 06:24:08 -0700 Subject: [PATCH 44/86] . --- base/MAPL_XYGridFactory.F90 | 11 ++++++++++- shared/Shmem/Shmem.F90 | 11 ++++++++++- 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index a92cd6d545c8..d6971481c8bc 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -366,8 +366,10 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) integer :: status integer :: i_1,i_n,j_1,j_n, ncid, varid + integer :: i, j real(REAL64), pointer :: arr_lon(:,:) real(REAL64), pointer :: arr_lat(:,:) + integer, pointer :: mask(:,:) real(REAL64), allocatable :: x(:) real(REAL64), allocatable :: y(:) real(REAL64) :: lambda0_deg, lambda0 @@ -396,6 +398,7 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) call MAPL_AllocateShared(arr_lon,[Xdim, Ydim],transroot=.true.,_RC) call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(mask, [Xdim, Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) write(6,*) 'grid_name', trim(adjustl(this%grid_name)) @@ -420,7 +423,13 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 write(6, 101) 'lambda0=', lambda0 - + do i = 1, Xdim + do j= 1, Ydim + call ABI_XY_2_lonlat (x(i), y(j), lambda0, arr_lon(i,j), arr_lat(i,j), mask(i,j)) + write(6,101) 'x,y,lon,lat', x(i), y(j), arr_lon(i,j), arr_lat(i,j) + write(6,121) 'mask ', mask(i,j) + end do + end do ! ... diff --git a/shared/Shmem/Shmem.F90 b/shared/Shmem/Shmem.F90 index 8ef1644ce301..dfc70f51497c 100644 --- a/shared/Shmem/Shmem.F90 +++ b/shared/Shmem/Shmem.F90 @@ -155,6 +155,7 @@ end function shmctl module procedure MAPL_AllocateShared_1DI4 module procedure MAPL_AllocateShared_1DR4 module procedure MAPL_AllocateShared_1DR8 + module procedure MAPL_AllocateShared_2DI4 module procedure MAPL_AllocateShared_2DR4 module procedure MAPL_AllocateShared_2DR8 end interface MAPL_AllocateShared @@ -394,6 +395,14 @@ module subroutine MAPL_AllocateShared_1DR8(Ptr, Shp, lbd, TransRoot, rc) integer, optional, intent( OUT) :: rc end subroutine MAPL_AllocateShared_1DR8 + module subroutine MAPL_AllocateShared_2DI4(Ptr, Shp, lbd, TransRoot, rc) + integer, pointer, intent(INOUT) :: Ptr(:,:) + integer, intent(IN ) :: Shp(2) + integer, optional, intent(IN ) :: lbd(2) + logical, intent(IN ) :: TransRoot + integer, optional, intent( OUT) :: rc + end subroutine MAPL_AllocateShared_2DI4 + module subroutine MAPL_AllocateShared_2DR4(Ptr, Shp, lbd, TransRoot, rc) real, pointer, intent(INOUT) :: Ptr(:,:) integer, intent(IN ) :: Shp(2) @@ -401,7 +410,7 @@ module subroutine MAPL_AllocateShared_2DR4(Ptr, Shp, lbd, TransRoot, rc) logical, intent(IN ) :: TransRoot integer, optional, intent( OUT) :: rc end subroutine MAPL_AllocateShared_2DR4 - + module subroutine MAPL_AllocateShared_2DR8(Ptr, Shp, lbd, TransRoot, rc) real(KIND=REAL64), pointer, intent(INOUT) :: Ptr(:,:) integer, intent(IN ) :: Shp(2) From e19a1301c4c8fa93e79d18ef03d90074c03d4569 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 17 Jan 2024 10:25:54 -0500 Subject: [PATCH 45/86] Refactor CircleCI workflows --- .circleci/config.yml | 95 +++++++++++++++++++++++--------------------- CHANGELOG.md | 1 + 2 files changed, 50 insertions(+), 46 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 5e2b3871ce9d..b4dee0c83db0 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -24,9 +24,8 @@ orbs: ci: geos-esm/circleci-tools@2 workflows: - build-and-test: + build-and-test-MAPL: jobs: - # Builds MAPL in a "default" way - Intel - ci/build: name: build-and-test-MAPL-on-<< matrix.compiler >>-using-<< matrix.cmake_generator >> @@ -86,29 +85,37 @@ workflows: run_unit_tests: true ctest_options: "-LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" - # Build GEOSgcm -- ifort - - ci/build: - name: build-GEOSgcm-on-<< matrix.compiler >> + # Run MAPL Tutorials + - ci/run_mapl_tutorial: + name: run-<< matrix.tutorial_name >>-Tutorial-with-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: + #compiler: [gfortran, ifort] compiler: [ifort] + tutorial_name: + - hello_world + - parent_no_children + - parent_one_child_import_via_extdata + - parent_one_child_no_imports + - parent_two_siblings_connect_import_export + # We will only run the tutorials with GNU make. No need to double up + # as Ninja is a build test only + requires: + - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles baselibs_version: *baselibs_version - repo: GEOSgcm - checkout_fixture: true - mepodevelop: true - checkout_mapl_branch: true - persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day - # Build GEOSgcm -- GCC + build-and-run-GEOSgcm: + jobs: + # Build GEOSgcm -- ifort - ci/build: name: build-GEOSgcm-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: - compiler: [gfortran] + compiler: [ifort] baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true @@ -116,35 +123,20 @@ workflows: checkout_mapl_branch: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day - # Build GEOSldas on ifort - - ci/build: - name: build-GEOSldas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - baselibs_version: *baselibs_version - repo: GEOSldas - mepodevelop: false - checkout_fixture: true - fixture_branch: develop - checkout_mapl_branch: true - - # Build GEOSldas on gfortran + # Build GEOSgcm -- GCC - ci/build: - name: build-GEOSldas-on-<< matrix.compiler >> + name: build-GEOSgcm-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: compiler: [gfortran] baselibs_version: *baselibs_version - repo: GEOSldas - mepodevelop: false + repo: GEOSgcm checkout_fixture: true - fixture_branch: develop + mepodevelop: true checkout_mapl_branch: true + persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day # Run GCM (1 hour, no ExtData) - ci/run_gcm: @@ -176,26 +168,37 @@ workflows: gcm_ocean_type: MOM6 change_layout: false - # Run MAPL Tutorials - - ci/run_mapl_tutorial: - name: run-<< matrix.tutorial_name >>-Tutorial-with-<< matrix.compiler >> + build-GEOSldas: + jobs: + # Build GEOSldas on ifort + - ci/build: + name: build-GEOSldas-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: - #compiler: [gfortran, ifort] compiler: [ifort] - tutorial_name: - - hello_world - - parent_no_children - - parent_one_child_import_via_extdata - - parent_one_child_no_imports - - parent_two_siblings_connect_import_export - # We will only run the tutorials with GNU make. No need to double up - # as Ninja is a build test only - requires: - - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles baselibs_version: *baselibs_version + repo: GEOSldas + mepodevelop: false + checkout_fixture: true + fixture_branch: develop + checkout_mapl_branch: true + + # Build GEOSldas on gfortran + - ci/build: + name: build-GEOSldas-on-<< matrix.compiler >> + context: + - docker-hub-creds + matrix: + parameters: + compiler: [gfortran] + baselibs_version: *baselibs_version + repo: GEOSldas + mepodevelop: false + checkout_fixture: true + fixture_branch: develop + checkout_mapl_branch: true build-GEOSadas: jobs: diff --git a/CHANGELOG.md b/CHANGELOG.md index c50ea8f9ef5f..0402ffa62150 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. - Updated CI to use Open MPI 5.0.0 for GNU - Enable Ninja for CI builds of MAPL +- Refactor the CircleCI workflows for more flexibility ### Fixed From 7258afff12cdd1ffedc71a336d30a846c749cdb7 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 17 Jan 2024 11:02:38 -0500 Subject: [PATCH 46/86] Fixes for ninja build race condition --- CHANGELOG.md | 1 + benchmarks/io/checkpoint_simulator/CMakeLists.txt | 4 +++- benchmarks/io/combo/CMakeLists.txt | 2 ++ benchmarks/io/gatherv/CMakeLists.txt | 3 +++ benchmarks/io/raw_bw/CMakeLists.txt | 3 +++ 5 files changed, 12 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e91fbd76dc26..000355edd51e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Explictly `use` some `iso_c_binding` types previously pulled in through ESMF. This is fixed in future ESMF versions (8.7+) and so we anticipate this here +- Add explicit `Fortran_MODULE_DIRECTORY` to `CMakeLists.txt` in benchmarks to avoid race condition in Ninja builds ### Removed diff --git a/benchmarks/io/checkpoint_simulator/CMakeLists.txt b/benchmarks/io/checkpoint_simulator/CMakeLists.txt index 718d3b706d4e..fedd46d5f3f4 100644 --- a/benchmarks/io/checkpoint_simulator/CMakeLists.txt +++ b/benchmarks/io/checkpoint_simulator/CMakeLists.txt @@ -1,12 +1,14 @@ set(exe checkpoint_simulator.x) +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/checkpoint_simulator) ecbuild_add_executable ( TARGET ${exe} - SOURCES checkpoint_simulator.F90 + SOURCES checkpoint_simulator.F90 DEFINITIONS USE_MPI) target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse esmf ) target_include_directories (${exe} PUBLIC $) +set_target_properties (${exe} PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/benchmarks/io/combo/CMakeLists.txt b/benchmarks/io/combo/CMakeLists.txt index c0d2aa99a884..99a92e1b46a6 100644 --- a/benchmarks/io/combo/CMakeLists.txt +++ b/benchmarks/io/combo/CMakeLists.txt @@ -1,4 +1,5 @@ set(exe combo.x) +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/combo) ecbuild_add_executable ( TARGET ${exe} @@ -7,6 +8,7 @@ ecbuild_add_executable ( target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse) target_include_directories (${exe} PUBLIC $) +set_target_properties (${exe} PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/benchmarks/io/gatherv/CMakeLists.txt b/benchmarks/io/gatherv/CMakeLists.txt index 5510ff1c3b33..d6072fb82823 100644 --- a/benchmarks/io/gatherv/CMakeLists.txt +++ b/benchmarks/io/gatherv/CMakeLists.txt @@ -1,3 +1,5 @@ +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/gatherv) + ecbuild_add_executable ( TARGET gatherv.x SOURCES GathervKernel.F90 GathervSpec.F90 driver.F90 @@ -5,6 +7,7 @@ ecbuild_add_executable ( target_link_libraries (gatherv.x PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse) target_include_directories (gatherv.x PUBLIC $) +set_target_properties (gatherv.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/benchmarks/io/raw_bw/CMakeLists.txt b/benchmarks/io/raw_bw/CMakeLists.txt index 911a836a7ea5..7477ddf6e43f 100644 --- a/benchmarks/io/raw_bw/CMakeLists.txt +++ b/benchmarks/io/raw_bw/CMakeLists.txt @@ -1,3 +1,5 @@ +set(MODULE_DIRECTORY ${esma_include}/benchmarks/io/raw_bw) + ecbuild_add_executable ( TARGET raw_bw.x SOURCES BW_Benchmark.F90 BW_BenchmarkSpec.F90 driver.F90 @@ -5,6 +7,7 @@ ecbuild_add_executable ( target_link_libraries (raw_bw.x PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse) target_include_directories (raw_bw.x PUBLIC $) +set_target_properties (raw_bw.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") From 4048c45c30083c7d2aa8ce82cb8ac116dd96bc0f Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 17 Jan 2024 11:23:32 -0500 Subject: [PATCH 47/86] Feature branch to fix issue 2530 for field utils --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index c50ea8f9ef5f..cf72d49b5973 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,6 +19,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. - Updated CI to use Open MPI 5.0.0 for GNU - Enable Ninja for CI builds of MAPL +- Fix field utils issue - tests request pe's explicitly ### Fixed From 592573d81b7728f6fb75745686911264d6572a42 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 17 Jan 2024 15:51:09 -0500 Subject: [PATCH 48/86] Add npes argument to @Test decorator. --- field_utils/tests/Test_FieldArithmetic.pf | 37 ++++++++++++------ field_utils/tests/Test_FieldBLAS.pf | 36 +++++++++--------- field_utils/tests/field_utils_setup.F90 | 46 +++++++++++++++++++++++ 3 files changed, 90 insertions(+), 29 deletions(-) diff --git a/field_utils/tests/Test_FieldArithmetic.pf b/field_utils/tests/Test_FieldArithmetic.pf index 6830413e7bbb..89a0e72f0aaf 100644 --- a/field_utils/tests/Test_FieldArithmetic.pf +++ b/field_utils/tests/Test_FieldArithmetic.pf @@ -13,8 +13,13 @@ module Test_FieldArithmetic implicit none + real(kind=ESMF_KIND_R4), parameter :: ADD_R4 = 100.0 + real(kind=ESMF_KIND_R8), parameter :: ADD_R8 = 100.0 + contains + ! Making the fields should be done in the tests themselves so because + ! of the npes argument. @Before subroutine set_up_data() implicit none @@ -45,16 +50,20 @@ contains end subroutine set_up_data - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldAddR4() type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) integer :: status, rc + real(kind=ESMF_KIND_R4), allocatable :: y4array(:,:) - x = XR4 - y = YR4 + allocate(y4array, source=R4_ARRAY_DEFAULT) + x = mk_r4field(R4_ARRAY_DEFAULT, 'XR4', _RC) + y = mk_r4field(y4array, 'YR4', _RC) +! x = mk_r4field(R4_ARRAY_DEFAULT, 'XR4', _RC) +! y = mk_r4field(y4array, 'YR4', _RC) call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) @@ -64,9 +73,13 @@ contains result_array = 5.0 call FieldAdd(y, x, y, _RC) @assertEqual(y_ptr, result_array) + end subroutine test_FieldAddR4 - @Test + ! Rather than use the fields created in setup, make the fields + ! in this subroutine to make sure that the npes match the + ! regDecomp. + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldAddR4_missing type(ESMF_Field) :: x type(ESMF_Field) :: y @@ -87,16 +100,18 @@ contains @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4_missing - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldAddR8() type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:), y_ptr(:,:) real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) integer :: status, rc + real(kind=ESMF_KIND_R8), allocatable :: y8array(:,:) - x = XR8 - y = YR8 + allocate(y8array, source=R8_ARRAY_DEFAULT) + x = mk_r8field(R8_ARRAY_DEFAULT, 'XR8', _RC) + y = mk_r8field(y8array, 'YR8', _RC) call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) @@ -108,7 +123,7 @@ contains @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldPowR4() type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) @@ -127,7 +142,7 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR4 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldPowR8() type(ESMF_Field) :: x real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:) @@ -146,7 +161,7 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldSinR4() type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) @@ -163,7 +178,7 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldSinR4 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldNegR4() type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) diff --git a/field_utils/tests/Test_FieldBLAS.pf b/field_utils/tests/Test_FieldBLAS.pf index d289d2e0970c..f7359eb07d7a 100644 --- a/field_utils/tests/Test_FieldBLAS.pf +++ b/field_utils/tests/Test_FieldBLAS.pf @@ -43,7 +43,7 @@ contains end subroutine set_up_data - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Basic test of FieldCOPY subroutine (REAL32) subroutine test_FieldCOPY_R4() type(ESMF_Field) :: x @@ -61,7 +61,7 @@ contains end subroutine test_FieldCOPY_R4 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Basic test of FieldCOPY subroutine (REAL64) subroutine test_FieldCOPY_R8() type(ESMF_Field) :: x @@ -79,7 +79,7 @@ contains end subroutine test_FieldCOPY_R8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Basic test of FieldCOPY subroutine (REAL32 -> REAL64) subroutine test_FieldCOPY_R4R8() type(ESMF_Field) :: x @@ -97,7 +97,7 @@ contains end subroutine test_FieldCOPY_R4R8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Basic test of FieldCOPY subroutine (REAL64 -> REAL32) subroutine test_FieldCOPY_R8R4() type(ESMF_Field) :: x @@ -117,7 +117,7 @@ contains end subroutine test_FieldCOPY_R8R4 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Basic test of FieldSCAL subroutine (REAL32) subroutine test_FieldSCAL_R4() real(kind=ESMF_KIND_R4), parameter :: a = 2.0 @@ -135,7 +135,7 @@ contains end subroutine test_FieldSCAL_R4 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Basic test of FieldSCAL subroutine (REAL64) subroutine test_FieldSCAL_R8() real(kind=ESMF_KIND_R8), parameter :: a = 2.0 @@ -153,7 +153,7 @@ contains end subroutine test_FieldSCAL_R8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! subroutine test_FieldAXPY_R4() real(kind=ESMF_KIND_R4), parameter :: a = 2.0 @@ -178,7 +178,7 @@ contains end subroutine test_FieldAXPY_R4 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! subroutine test_FieldAXPY_R8() real(kind=ESMF_KIND_R8), parameter :: a = 2.0 @@ -203,7 +203,7 @@ contains end subroutine test_FieldAXPY_R8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldGetLocalElementCount() type(ESMF_Field) :: x integer :: rank @@ -221,7 +221,7 @@ contains end subroutine test_FieldGetLocalElementCount - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! subroutine test_FieldGetLocalSize() type(ESMF_Field) :: x @@ -242,7 +242,7 @@ contains end subroutine test_FieldGetLocalSize - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! Test getting the c_ptr for a field !wdb fixme Should test more extensively for different ranks !wdb fixme Should test for ESMF_KIND_I4 and ESMF_KIND_I8 @@ -260,7 +260,7 @@ contains end subroutine test_FieldGetCptr - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) !wdb fixme Probably should test for non-conformable fields subroutine test_FieldsAreConformableR4() type(ESMF_Field) :: x, y @@ -276,7 +276,7 @@ contains end subroutine test_FieldsAreConformableR4 !wdb fixme Probably should test for non-conformable fields - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldsAreConformableR8() type(ESMF_Field) :: x, y integer :: status, rc @@ -290,7 +290,7 @@ contains end subroutine test_FieldsAreConformableR8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) ! subroutine test_FieldsAreSameTypeKind() type(ESMF_Field) :: x, y @@ -318,7 +318,7 @@ contains end subroutine test_FieldsAreSameTypeKind !wdb fixme Enable assertEqual - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldConvertPrec_R4R8() integer, parameter :: NROWS = 4 integer, parameter :: NCOLS = NROWS @@ -344,7 +344,7 @@ contains end subroutine test_FieldConvertPrec_R4R8 - @Test + @Test(npes=product(REG_DECOMP_DEFAULT)) subroutine test_FieldClone3D() type(ESMF_Field) :: x, y integer :: status, rc @@ -406,7 +406,7 @@ contains end subroutine test_almost_equal_array end module Test_FieldBLAS -! @Test +! @Test(npes=product(REG_DECOMP_DEFAULT)) ! ! ! subroutine test_FieldGEMV_R4() ! real(kind=ESMF_KIND_R4), parameter :: alpha = 3.0 @@ -446,7 +446,7 @@ end module Test_FieldBLAS ! ! end subroutine test_FieldGEMV_R4 -! @Test +! @Test(npes=product(REG_DECOMP_DEFAULT)) ! ! ! subroutine test_FieldSpread() ! end subroutine test_FieldSpread diff --git a/field_utils/tests/field_utils_setup.F90 b/field_utils/tests/field_utils_setup.F90 index 7ac898fd3d19..437a3d107631 100644 --- a/field_utils/tests/field_utils_setup.F90 +++ b/field_utils/tests/field_utils_setup.F90 @@ -183,4 +183,50 @@ subroutine initialize_array_R8(x, xmin, xrange) end subroutine initialize_array_R8 + function mk_r4field(r4array, field_name, rc) result(r4field) + type(ESMF_Field) :: r4field + real(kind=ESMF_KIND_R4), intent(in) :: r4array(:,:) + character(len=*), intent(in) :: field_name + integer, optional, intent(out) :: rc + + integer :: status + + r4field = mk_field(r4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, & + maxIndex=MAX_INDEX_DEFAULT, indexflag=INDEX_FLAG_DEFAULT, name = field_name, _RC) + + _RETURN(_SUCCESS) + + end function mk_r4field + + function mk_r8field(r8array, field_name, rc) result(r8field) + type(ESMF_Field) :: r8field + real(kind=ESMF_KIND_R8), intent(in) :: r8array(:,:) + character(len=*), intent(in) :: field_name + integer, optional, intent(out) :: rc + + integer :: status + + r8field = mk_field(r8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, & + maxIndex=MAX_INDEX_DEFAULT, indexflag=INDEX_FLAG_DEFAULT, name = field_name, _RC) + + _RETURN(_SUCCESS) + + end function mk_r8field + + function mk_r4ungrid_field(field_name, lbound, ubound, rc) result(r4field) + type(ESMF_Field) :: r4field + character(len=*), intent(in) :: field_name + integer, intent(in) :: lbound + integer, intent(in) :: ubound + integer, optional, intent(out) :: rc + + integer :: status + + r4field = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & + indexflag=INDEX_FLAG_DEFAULT, name = field_name, ungriddedLBound=[lbound],ungriddedUBound=[ubound],_RC) + + _RETURN(_SUCCESS) + + end function mk_r4ungrid_field + end module field_utils_setup From 3fb73c5502c35edb984bd1e9f6bf3fca9eb95a95 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 17 Jan 2024 15:58:55 -0500 Subject: [PATCH 49/86] Update CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index cf72d49b5973..28883d39b7fc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,7 +19,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Replaced RC=STATUS plus `_VERIFY(RC)` in `Base_Base_implementation.F90` with just `_RC` in line with our new convention. - Updated CI to use Open MPI 5.0.0 for GNU - Enable Ninja for CI builds of MAPL -- Fix field utils issue - tests request pe's explicitly +- Fix field utils issue - add npes argument to test subroutine decorators. ### Fixed From 67d27ee5e65f759806ff6c5d5d11547c91075c60 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 17 Jan 2024 15:04:59 -0700 Subject: [PATCH 50/86] update with Ben on using add_mask --- base/MAPL_Comms.F90 | 25 ++++++ base/MAPL_ObsUtil.F90 | 78 +++++++++++++++---- base/MAPL_SwathGridFactory.F90 | 2 +- base/MAPL_XYGridFactory.F90 | 107 +++++++++++++++++--------- shared/Shmem/Shmem_implementation.F90 | 21 +++++ 5 files changed, 183 insertions(+), 50 deletions(-) diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 12053ea06722..4bb204decc3d 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -115,6 +115,7 @@ module MAPL_CommsMod interface MAPL_BcastShared module procedure MAPL_BcastShared_1DR4 + module procedure MAPL_BcastShared_2DI4 module procedure MAPL_BcastShared_2DR4 module procedure MAPL_BcastShared_2DR8 end interface @@ -1142,6 +1143,30 @@ subroutine MAPL_BcastShared_2DR8(VM, Data, N, Root, RootOnly, rc) _RETURN(ESMF_SUCCESS) end subroutine MAPL_BcastShared_2DR8 + + subroutine MAPL_BcastShared_2DI4(VM, Data, N, Root, RootOnly, rc) + type(ESMF_VM) :: VM + integer, pointer, intent(INOUT) :: Data(:,:) + integer, intent(IN ) :: N + integer, optional, intent(IN ) :: Root + logical, intent(IN ) :: RootOnly + integer, optional, intent( OUT) :: rc + integer :: status + + if(.not.MAPL_ShmInitialized) then + if (RootOnly) then + _RETURN(ESMF_SUCCESS) + end if + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, _RC) + else + call MAPL_SyncSharedMemory(_RC) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, _RC) + call MAPL_SyncSharedMemory(_RC) + endif + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_BcastShared_2DI4 ! Rank 0 !--------------------------- diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 6db18e22d880..94462c50f363 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -5,6 +5,7 @@ module MAPL_ObsUtilMod use ESMF use Plain_netCDF_Time use netCDF + use MAPL_BaseMod, only: MAPL_UNDEF use MAPL_CommsMod, only : MAPL_AM_I_ROOT use pFIO_FileMetadataMod, only : FileMetadata use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter @@ -12,9 +13,9 @@ module MAPL_ObsUtilMod implicit none integer, parameter :: mx_ngeoval = 60 ! GRS80 by Moritz - real(REAL64) :: a=6378137.d0 - real(REAL64) :: b=6356752.31414d0 - real(REAL64) :: H=42164160.d0 + real(REAL64) :: r_eq=6378137.d0 + real(REAL64) :: r_pol=6356752.31414d0 + real(REAL64) :: H_sat=42164160.d0 ! GOES-R real(REAL64) :: lambda0_SatE=-1.308996939d0 ! -75 deg Satellite East real(REAL64) :: lambda0_SatW=-2.39110107523d0 ! -137 deg Satellite West @@ -732,42 +733,61 @@ end function union_platform ! From GOES-R SERIES PRODUCT DEFINITION AND USERS’ GUIDE ! - subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, outRange) + subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, mask) implicit none real(REAL64), intent(in) :: x, y real(REAL64), intent(in) :: lambda0 real(REAL64), intent(out):: lon, lat - integer,intent(out):: outRange + integer, optional, intent(out):: mask real(REAL64) :: a0, b0, c0, rs, Sx, Sy, Sz, t + real(REAL64) :: a, b, H + real(REAL64) :: delta + + a=r_eq; b=r_pol; H=H_sat + if (present(mask)) mask=0 a0 = sin(x)*sin(x) + cos(x)*cos(x)*( cos(y)*cos(y) + (a/b)*(a/b)*sin(y)*sin(y) ) b0 = -2.d0 * H * cos(x) * cos(y) c0 = H*H - a*a + delta = b0*b0 - 4.d0*a0*c0 + if (delta < 0.d0) then + ! lon = -999.d0 + ! lat = -999.d0 + lon = MAPL_UNDEF + lat = MAPL_UNDEF + return + end if rs = ( -b0 - sqrt(b0*b0 - 4.d0*a0*c0) ) / (2.d0*a0) Sx = rs * cos(x) * cos(y) Sy = -rs * sin(x) - Sz = rs * cos(x) * sin(y) + Sz = rs * cos(x) * sin(y) lon = lambda0 - atan (Sy/(H - Sx)) lat = atan ( (a/b)**2.d0 * Sz / sqrt ((H -Sx)**2.d0 + Sy*Sy) ) t = H*(H-Sx) - ( Sy*Sy + (a/b)**2.d0 *Sz*Sz ) if (t < 0) then - outRange = 1 + lon = MAPL_UNDEF + lat = MAPL_UNDEF + if (present(mask)) mask=0 else - outRange = 0 + if (present(mask)) mask=1 end if end subroutine ABI_XY_2_lonlat - - subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, outRange) + + subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, mask) implicit none real(REAL64), intent(in) :: lon, lat real(REAL64), intent(in) :: lambda0 real(REAL64), intent(out):: x, y - integer,intent(out):: outRange + integer, intent(out):: mask real(REAL64) :: theta_c real(REAL64) :: e2, rc, Sx, Sy, Sz, t + real(REAL64) :: a, b, H + real*8 :: delta + + a=r_eq; b=r_pol; H=H_sat theta_c = atan( (b/a)**2.d0 * tan(lat) ) e2 = 1.d0 - (b/a)**2.d0 ! (a^2-b^2)/a^2 @@ -780,12 +800,44 @@ subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, outRange) t = H*(H-Sx) - ( Sy*Sy + (a/b)**2.d0 *Sz*Sz ) if (t < 0) then - outRange = 1 + mask = 1 else - outRange = 0 + mask = 0 end if end subroutine lonlat_2_ABI_XY + subroutine test_conversion + implicit none + real*8 :: x0 = -0.024052d0 + real*8 :: y0 = 0.095340d0 + real*8 :: lam, the + real*8 :: lon, lat + integer :: mask + real*8 :: xnew, ynew + + lam = -1.478135612d0 + the = 0.590726971d0 + + call ABI_XY_2_lonlat (x0, y0, lambda0_SatE, lon, lat, mask) + write(6, 111) 'x,y 2 ll' + write(6, 111) 'x,y=', x0, y0 + write(6, 111) 'lon,lat=', lon, lat + write(6, 121) 'mask=', mask + write(6, 111) 'errror lon,lat=', lon - lam, lat-the + + call lonlat_2_ABI_XY (lam, the, lambda0_SatE, xnew, ynew, mask) + write(6, 111) 'll 2 xy' + write(6, 111) 'lon,lat=', lam, the + write(6, 111) 'x,y=', xnew, ynew + write(6, 121) 'mask=', mask + write(6, 111) 'errror lon,lat=', xnew -x0, ynew-y0 + +101 format (2x, a,10(2x,f15.8)) +111 format (2x, a,20(2x,f25.11)) +121 format (2x, a,10(2x,i8)) + + end subroutine test_conversion + end module MAPL_ObsUtilMod diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index cc659a862b1c..eb847d369bb6 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -246,7 +246,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _UNUSED_DUMMY(unusable) -!! call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGetCurrent(vm,_RC) !! call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) Xdim=this%im_world diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index d6971481c8bc..80b26ff1e5ad 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -14,7 +14,8 @@ module MAPL_XYGridFactoryMod use pFIO use NetCDF ! use Plain_netCDF_Time, only : get_ncfile_dimension - use Plain_netCDF_Time + use Plain_netCDF_Time + use MAPL_ObsUtilMod, only : ABI_XY_2_lonlat, test_conversion use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -48,6 +49,9 @@ module MAPL_XYGridFactoryMod character(len=ESMF_MAXSTR) :: var_name_proj character(len=ESMF_MAXSTR) :: att_name_proj + integer :: xdim_true + integer :: ydim_true + integer :: factor contains procedure :: make_new_grid procedure :: create_basic_grid @@ -149,15 +153,14 @@ function make_new_grid(this, unusable, rc) result(grid) if ( index(trim(adjustl(this%grid_name)), 'ABI') == 0 ) then call this%add_horz_coordinates_from_file(grid, _RC) - call this%add_mask(grid,_RC) else call this%add_horz_coordinates_from_ABIfile(grid, _RC) end if - - - _FAIL('nail -2') + call this%add_mask(grid,_RC) write(6,'(2x,a)') 'af add_mask' + + _RETURN(_SUCCESS) end function make_new_grid @@ -199,9 +202,8 @@ function create_basic_grid(this, unusable, rc) result(grid) call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, _RC) end if -!! why? Ben -!! call ESMF_AttributeSet(grid, 'GridType', 'XY', _RC) - call ESMF_AttributeSet(grid, 'GridType', 'latlon', _RC) + call ESMF_AttributeSet(grid, 'GridType', 'XY', _RC) + _RETURN(_SUCCESS) end function create_basic_grid @@ -369,10 +371,13 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) integer :: i, j real(REAL64), pointer :: arr_lon(:,:) real(REAL64), pointer :: arr_lat(:,:) - integer, pointer :: mask(:,:) + integer, pointer :: mask2d(:,:) + integer, pointer :: mask(:,:) real(REAL64), allocatable :: x(:) real(REAL64), allocatable :: y(:) real(REAL64) :: lambda0_deg, lambda0 + real(REAL64) :: x0, y0, lon, lat + integer :: outRange real(ESMF_KIND_R8), pointer :: fptr(:,:) @@ -397,8 +402,8 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) ! call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) call MAPL_AllocateShared(arr_lon,[Xdim, Ydim],transroot=.true.,_RC) - call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) - call MAPL_AllocateShared(mask, [Xdim, Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) +!! call MAPL_AllocateShared(mask, [Xdim, Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) write(6,*) 'grid_name', trim(adjustl(this%grid_name)) @@ -412,38 +417,57 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) allocate (y(Ydim)) call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) - call get_att_char_netcdf( fn, key_x, 'units', unit, _RC) - if ( index(unit, 'rad') == 0 ) then - arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 - arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 - end if - write(6, 101) 'x=', x - write(6, 101) 'y=', y + !write(6, 101) 'x=', x(::100) + !write(6, 101) 'y=', y(::100) call get_att_real_netcdf(fn, key_p, key_p_att, lambda0_deg, _RC) lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 - write(6, 101) 'lambda0=', lambda0 - + !write(6, 101) 'lambda0=', lambda0 + !call test_conversion + do i = 1, Xdim do j= 1, Ydim - call ABI_XY_2_lonlat (x(i), y(j), lambda0, arr_lon(i,j), arr_lat(i,j), mask(i,j)) - write(6,101) 'x,y,lon,lat', x(i), y(j), arr_lon(i,j), arr_lat(i,j) - write(6,121) 'mask ', mask(i,j) + !call ABI_XY_2_lonlat (x(i), y(j), lambda0, arr_lon(i,j), arr_lat(i,j), mask(i,j)) + call ABI_XY_2_lonlat (x(i), y(j), lambda0, arr_lon(i,j), arr_lat(i,j)) + if ( mod(i,200)==1 .AND. mod(j,200)==1) then + write(6,111) 'x,y,lon,lat', x(i), y(j), arr_lon(i,j), arr_lat(i,j) + !! write(6,121) 'mask ', mask(i,j) + end if end do end do - - ! ... - - ! - ! add mask - ! - - ! write(6,*) 'in root' - ! write(6,'(11x,100f10.1)') arr_lon(::5,189) end if call MAPL_SyncSharedMemory(_RC) call ESMF_VMGetCurrent(vm, _RC) - call ESMF_VMbarrier(vm, _RC) + call MAPL_BcastShared (VM, data=arr_lon, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (VM, data=arr_lat, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) + !!call MAPL_BcastShared (VM, data=mask, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) + fptr = arr_lon(i_1:i_n,j_1:j_n) + call MAPL_SyncSharedMemory(_RC) + + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=fptr, rc=status) + fptr = arr_lat(i_1:i_n,j_1:j_n) + + !!call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK,_RC) + !!call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & + !! itemflag=ESMF_GRIDITEM_MASK,farrayPtr=mask2d,_RC) + !!mask2d = mask(i_1:i_n,j_1:j_n) + + + if(MAPL_ShmInitialized) then + call MAPL_DeAllocNodeArray(arr_lon,_RC) + call MAPL_DeAllocNodeArray(arr_lat,_RC) +! call MAPL_DeAllocNodeArray(mask,_RC) + else + deallocate(arr_lon) + deallocate(arr_lat) +! deallocate(mask) + end if + _RETURN(_SUCCESS) @@ -533,8 +557,12 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc end if call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMBroadcast (vm, arr, 2, 0, _RC) - this%im_world = arr(1) - this%jm_world = arr(2) + this%xdim_true = arr(1) + this%ydim_true = arr(1) + this%factor = 100 + + this%im_world = arr(1) / this%factor + this%jm_world = arr(2) / this%factor write(6,'(2x,a,100i10)') 'nail 2, nx,ny,im,jm,lm',& this%nx,this%ny,this%im_world,this%jm_world,this%lm @@ -1047,6 +1075,13 @@ subroutine add_mask(this,grid,rc) farrayPtr=fptr, _RC) local_has_undef = 0 if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 + +! call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & +! staggerloc=ESMF_STAGGERLOC_CENTER, & +! farrayPtr=fptr, _RC) +! local_has_undef = 0 +! if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 + call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) _RETURN_IF(has_undef == 0) @@ -1059,7 +1094,7 @@ subroutine add_mask(this,grid,rc) where(fptr==MAPL_UNDEF) mask = MAPL_MASK_OUT _RETURN(_SUCCESS) - end subroutine + end subroutine add_mask end module MAPL_XYGridFactoryMod diff --git a/shared/Shmem/Shmem_implementation.F90 b/shared/Shmem/Shmem_implementation.F90 index 0e3f8b1550de..fdda07755951 100644 --- a/shared/Shmem/Shmem_implementation.F90 +++ b/shared/Shmem/Shmem_implementation.F90 @@ -796,6 +796,27 @@ end subroutine perror end procedure MAPL_AllocateShared_1DR8 + module procedure MAPL_AllocateShared_2DI4 + + + integer :: status + + if(MAPL_ShmInitialized) then + call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS) + _VERIFY(STATUS) + else + if (TransRoot) then + allocate(Ptr(Shp(1),Shp(2)),stat=status) + else + allocate(Ptr(0,0),stat=status) + end if + _VERIFY(STATUS) + endif + + _RETURN(STATUS) + + end procedure MAPL_AllocateShared_2DI4 + module procedure MAPL_AllocateShared_2DR4 From 029461b16d70890b85dc38ab573a52b5616da0f6 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 17 Jan 2024 16:19:16 -0700 Subject: [PATCH 51/86] Add this%factor == data reduce factor to base/MAPL_XYGridFactory.F90 --- base/MAPL_SwathGridFactory.F90 | 2 +- base/MAPL_XYGridFactory.F90 | 32 +++++++++----------------------- 2 files changed, 10 insertions(+), 24 deletions(-) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index eb847d369bb6..0a403792e9d6 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -204,7 +204,7 @@ function create_basic_grid(this, unusable, rc) result(grid) if (this%lm /= MAPL_UNDEFINED_INTEGER) then call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, _RC) end if - call ESMF_AttributeSet(grid, 'GridType', 'LatLon', _RC) + call ESMF_AttributeSet(grid, 'GridType', 'Swath', _RC) call ESMF_AttributeSet(grid, 'Global', .false., _RC) _RETURN(_SUCCESS) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 80b26ff1e5ad..c901d650840a 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -51,7 +51,7 @@ module MAPL_XYGridFactoryMod integer :: xdim_true integer :: ydim_true - integer :: factor + integer :: factor = 10 contains procedure :: make_new_grid procedure :: create_basic_grid @@ -371,8 +371,6 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) integer :: i, j real(REAL64), pointer :: arr_lon(:,:) real(REAL64), pointer :: arr_lat(:,:) - integer, pointer :: mask2d(:,:) - integer, pointer :: mask(:,:) real(REAL64), allocatable :: x(:) real(REAL64), allocatable :: y(:) real(REAL64) :: lambda0_deg, lambda0 @@ -403,7 +401,6 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) call MAPL_AllocateShared(arr_lon,[Xdim, Ydim],transroot=.true.,_RC) call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) -!! call MAPL_AllocateShared(mask, [Xdim, Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) write(6,*) 'grid_name', trim(adjustl(this%grid_name)) @@ -413,8 +410,8 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) key_p = this%var_name_proj key_p_att = this%att_name_proj if (mapl_am_i_root()) then - allocate (x(Xdim)) - allocate (y(Ydim)) + allocate (x(this%Xdim_true)) + allocate (y(this%Ydim_true)) call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) !write(6, 101) 'x=', x(::100) @@ -426,8 +423,9 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) do i = 1, Xdim do j= 1, Ydim - !call ABI_XY_2_lonlat (x(i), y(j), lambda0, arr_lon(i,j), arr_lat(i,j), mask(i,j)) - call ABI_XY_2_lonlat (x(i), y(j), lambda0, arr_lon(i,j), arr_lat(i,j)) + x0 = x( i * this%factor ) + y0 = y( j * this%factor ) + call ABI_XY_2_lonlat (x0, y0, lambda0, arr_lon(i,j), arr_lat(i,j)) if ( mod(i,200)==1 .AND. mod(j,200)==1) then write(6,111) 'x,y,lon,lat', x(i), y(j), arr_lon(i,j), arr_lat(i,j) !! write(6,121) 'mask ', mask(i,j) @@ -440,7 +438,6 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) call ESMF_VMGetCurrent(vm, _RC) call MAPL_BcastShared (VM, data=arr_lon, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) call MAPL_BcastShared (VM, data=arr_lat, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) - !!call MAPL_BcastShared (VM, data=mask, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) @@ -448,27 +445,16 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) call MAPL_SyncSharedMemory(_RC) call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, rc=status) + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) fptr = arr_lat(i_1:i_n,j_1:j_n) - !!call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK,_RC) - !!call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & - !! itemflag=ESMF_GRIDITEM_MASK,farrayPtr=mask2d,_RC) - !!mask2d = mask(i_1:i_n,j_1:j_n) - - if(MAPL_ShmInitialized) then call MAPL_DeAllocNodeArray(arr_lon,_RC) call MAPL_DeAllocNodeArray(arr_lat,_RC) -! call MAPL_DeAllocNodeArray(mask,_RC) else deallocate(arr_lon) deallocate(arr_lat) -! deallocate(mask) end if - - _RETURN(_SUCCESS) include '/Users/yyu11/sftp/myformat.inc' @@ -557,9 +543,10 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc end if call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMBroadcast (vm, arr, 2, 0, _RC) + + ! thin obs data manually this%xdim_true = arr(1) this%ydim_true = arr(1) - this%factor = 100 this%im_world = arr(1) / this%factor this%jm_world = arr(2) / this%factor @@ -568,7 +555,6 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%nx,this%ny,this%im_world,this%jm_world,this%lm write(6,'(2x,a,10(2x,a))') 'var_name_proj, var_name_proj', & trim(this%var_name_proj), trim(this%att_name_proj) - call this%check_and_fill_consistency(rc=status) From a3057a670d3f3e07e1230945136f8021f67c362f Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 17 Jan 2024 16:55:21 -0700 Subject: [PATCH 52/86] . --- base/MAPL_XYGridFactory.F90 | 70 ++++++++++++------------------------- 1 file changed, 22 insertions(+), 48 deletions(-) diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index c901d650840a..9f01fe6ba296 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -51,7 +51,7 @@ module MAPL_XYGridFactoryMod integer :: xdim_true integer :: ydim_true - integer :: factor = 10 + integer :: thin_factor contains procedure :: make_new_grid procedure :: create_basic_grid @@ -147,10 +147,7 @@ function make_new_grid(this, unusable, rc) result(grid) _UNUSED_DUMMY(unusable) - write(6,'(2x,a)') 'bf create_basic_grid' grid = this%create_basic_grid(_RC) - write(6,'(2x,a)') 'bf add_horz_coordinates_from_file' - if ( index(trim(adjustl(this%grid_name)), 'ABI') == 0 ) then call this%add_horz_coordinates_from_file(grid, _RC) else @@ -158,9 +155,6 @@ function make_new_grid(this, unusable, rc) result(grid) end if call this%add_mask(grid,_RC) - write(6,'(2x,a)') 'af add_mask' - - _RETURN(_SUCCESS) end function make_new_grid @@ -395,14 +389,10 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) Ydim = DIMS(2) npoints = Xdim * Ydim - ! - !- read lon/lat - ! call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) call MAPL_AllocateShared(arr_lon,[Xdim, Ydim],transroot=.true.,_RC) call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) - write(6,*) 'grid_name', trim(adjustl(this%grid_name)) fn = this%grid_file_name key_x = this%var_name_x @@ -414,30 +404,25 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) allocate (y(this%Ydim_true)) call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) - !write(6, 101) 'x=', x(::100) - !write(6, 101) 'y=', y(::100) call get_att_real_netcdf(fn, key_p, key_p_att, lambda0_deg, _RC) lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + !write(6, 101) 'x=', x(::100) + !write(6, 101) 'y=', y(::100) !write(6, 101) 'lambda0=', lambda0 - !call test_conversion do i = 1, Xdim do j= 1, Ydim - x0 = x( i * this%factor ) - y0 = y( j * this%factor ) + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) call ABI_XY_2_lonlat (x0, y0, lambda0, arr_lon(i,j), arr_lat(i,j)) - if ( mod(i,200)==1 .AND. mod(j,200)==1) then - write(6,111) 'x,y,lon,lat', x(i), y(j), arr_lon(i,j), arr_lat(i,j) - !! write(6,121) 'mask ', mask(i,j) - end if end do end do end if call MAPL_SyncSharedMemory(_RC) call ESMF_VMGetCurrent(vm, _RC) - call MAPL_BcastShared (VM, data=arr_lon, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) - call MAPL_BcastShared (VM, data=arr_lat, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (vm, data=arr_lon, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (vm, data=arr_lat, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) @@ -457,7 +442,6 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) end if _RETURN(_SUCCESS) - include '/Users/yyu11/sftp/myformat.inc' end subroutine add_horz_coordinates_from_ABIfile @@ -532,8 +516,9 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%index_name_y, label=prefix//'index_name_y:', default="y", _RC) call ESMF_ConfigGetAttribute(config, this%var_name_x, label=prefix//'var_name_x:', default="x", _RC) call ESMF_ConfigGetAttribute(config, this%var_name_y, label=prefix//'var_name_y:', default="y", _RC) - call ESMF_ConfigGetAttribute(config, this%var_name_proj,label=prefix//'var_name_proj:', default="", _RC) - call ESMF_ConfigGetAttribute(config, this%att_name_proj,label=prefix//'att_name_proj:', default="", _RC) + call ESMF_ConfigGetAttribute(config, this%var_name_proj,label=prefix//'var_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, this%att_name_proj,label=prefix//'att_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, this%thin_factor, label=prefix//'thin_factor:', default=1, _RC) if (mapl_am_i_root()) then call get_ncfile_dimension(this%grid_file_name, nlon=n1, nlat=n2, & @@ -543,25 +528,18 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc end if call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMBroadcast (vm, arr, 2, 0, _RC) - - ! thin obs data manually + ! + ! use thin_factor to reduce regridding matrix size + ! this%xdim_true = arr(1) - this%ydim_true = arr(1) - - this%im_world = arr(1) / this%factor - this%jm_world = arr(2) / this%factor - - write(6,'(2x,a,100i10)') 'nail 2, nx,ny,im,jm,lm',& - this%nx,this%ny,this%im_world,this%jm_world,this%lm - write(6,'(2x,a,10(2x,a))') 'var_name_proj, var_name_proj', & - trim(this%var_name_proj), trim(this%att_name_proj) + this%ydim_true = arr(2) + this%im_world = arr(1) / this%thin_factor + this%jm_world = arr(2) / this%thin_factor call this%check_and_fill_consistency(rc=status) _RETURN(_SUCCESS) - include '/Users/yyu11/sftp/myformat.inc' - contains subroutine get_multi_integer(values, label, rc) @@ -1057,22 +1035,19 @@ subroutine add_mask(this,grid,rc) integer :: has_undef, local_has_undef call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=fptr, _RC) + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) local_has_undef = 0 if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 -! call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & -! staggerloc=ESMF_STAGGERLOC_CENTER, & -! farrayPtr=fptr, _RC) -! local_has_undef = 0 -! if (any(fptr == MAPL_UNDEF)) local_has_undef = 1 + call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) + if (any(fptr == MAPL_UNDEF)) local_has_undef = local_has_undef + 1 call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) -_RETURN_IF(has_undef == 0) + _RETURN_IF(has_undef == 0) - call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK,_RC) + call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER,itemflag=ESMF_GRIDITEM_MASK,_RC) call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & itemflag=ESMF_GRIDITEM_MASK,farrayPtr=mask,_RC) @@ -1082,5 +1057,4 @@ subroutine add_mask(this,grid,rc) _RETURN(_SUCCESS) end subroutine add_mask - end module MAPL_XYGridFactoryMod From 734f29127bc044462640057b007f5c92c4428021 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 17 Jan 2024 20:22:51 -0700 Subject: [PATCH 53/86] . --- Apps/abi_fixed_coord.F90 | 47 - Apps/time_ave_util.F90 | 1744 +++++++++++++++++++++++++++++++++++++- CHANGELOG.md | 1 + 3 files changed, 1744 insertions(+), 48 deletions(-) delete mode 100644 Apps/abi_fixed_coord.F90 mode change 120000 => 100644 Apps/time_ave_util.F90 diff --git a/Apps/abi_fixed_coord.F90 b/Apps/abi_fixed_coord.F90 deleted file mode 100644 index 485c7cf48595..000000000000 --- a/Apps/abi_fixed_coord.F90 +++ /dev/null @@ -1,47 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program ABI_fixed_coord - - use ESMF - use MAPL - use MAPL_FileMetadataUtilsMod - use gFTL_StringVector - use MPI - use, intrinsic :: iso_fortran_env, only: int32, int64, real32, real64 - use ieee_arithmetic, only: isnan => ieee_is_nan - use Plain_netCDF_Time - implicit none - - - character*150 :: fn, kx, ky - character*150 :: var_name_proj, att_name_proj - integer :: nx, ny - real(REAL64), allocatable :: x(:), y(:) - real(REAL64) :: lambda0, lambda0_deg - - integer :: status - - fn='/Users/yyu11/ModelData/Data_geosrun_2023/GOES-16-ABI/OR_ABI-L1b-RadF-M6C04_G16_s20192340800216_e20192340809524_c20192340809552.nc' - - kx='x' - ky='y' - call get_ncfile_dimension(fn, nlon=nx, nlat=ny, key_lon=kx, key_lat=ky, _RC) - write(6,121) 'nx, ny', nx, ny - - allocate(x(nx)) - allocate(y(ny)) - call get_v1d_netcdf_R8_complete (fn, kx, x, _RC) - call get_v1d_netcdf_R8_complete (fn, ky, y, _RC) - write(6, 101) 'x=', x - write(6, 101) 'y=', y - - var_name_proj='goes_imager_projection' - att_name_proj='longitude_of_projection_origin' - call get_att_real_netcdf( fn, var_name_proj, att_name_proj, lambda0_deg, _RC) - lambda0 = lambda0_deg/180.d0*4.d0*atan(1.d0) - - write(6, 101) 'lambda0=', lambda0 - - include '/Users/yyu11/sftp/myformat.inc' - end program ABI_fixed_coord diff --git a/Apps/time_ave_util.F90 b/Apps/time_ave_util.F90 deleted file mode 120000 index 66f59afe2b3a..000000000000 --- a/Apps/time_ave_util.F90 +++ /dev/null @@ -1 +0,0 @@ -abi_fixed_coord.F90 \ No newline at end of file diff --git a/Apps/time_ave_util.F90 b/Apps/time_ave_util.F90 new file mode 100644 index 000000000000..7f0190788d30 --- /dev/null +++ b/Apps/time_ave_util.F90 @@ -0,0 +1,1743 @@ +#define I_AM_MAIN +#include "MAPL_Generic.h" + +program time_ave + + use ESMF + use MAPL + use MAPL_FileMetadataUtilsMod + use gFTL_StringVector + use MPI + use, intrinsic :: iso_fortran_env, only: int32, int64, int16, real32, real64 + use ieee_arithmetic, only: isnan => ieee_is_nan + + implicit none + + integer comm,myid,npes,ierror + integer imglobal + integer jmglobal + logical root + +! ********************************************************************** +! ********************************************************************** +! **** **** +! **** Program to create time-averaged HDF files **** +! **** **** +! ********************************************************************** +! ********************************************************************** + + integer im,jm,lm + + integer nymd, nhms + integer nymd0,nhms0 + integer nymdp,nhmsp + integer nymdm,nhmsm + integer ntod, ndt, ntods + integer month, year + integer monthp, yearp + integer monthm, yearm + integer begdate, begtime + integer enddate, endtime + + integer id,rc,timeinc,timeid + integer ntime,nvars,ncvid,nvars2 + + character(len=ESMF_MAXSTR), allocatable :: fname(:) + character(len=ESMF_MAXSTR) template + character(len=ESMF_MAXSTR) name + character(len=ESMF_MAXSTR) ext + character(len=ESMF_MAXSTR) output, doutput, hdfile, rcfile + character(len=8) date0 + character(len=2) time0 + character(len=1) char + data output /'monthly_ave'/ + data rcfile /'NULL'/ + data doutput /'NULL'/ + data template/'NULL'/ + + integer n,m,nargs,L,nfiles,nv,km,mvars,mv,ndvars + + real plev,qming,qmaxg + real previous_undef,undef + real, allocatable :: lev(:) + integer, allocatable :: kmvar(:) , kmvar2(:) + integer, allocatable :: yymmdd(:) + integer, allocatable :: hhmmss(:) + integer, allocatable :: nloc(:) + integer, allocatable :: iloc(:) + + character(len=ESMF_MAXSTR), allocatable :: vname(:), vname2(:) + character(len=ESMF_MAXSTR), allocatable :: vtitle(:), vtitle2(:) + character(len=ESMF_MAXSTR), allocatable :: vunits(:), vunits2(:) + + real, allocatable :: qmin(:) + real, allocatable :: qmax(:) + real, allocatable :: dumz1(:,:) + real, allocatable :: dumz2(:,:) + real, allocatable :: dum(:,:,:) + real(REAL64), allocatable :: q(:,:,:,:) + integer, allocatable :: ntimes(:,:,:,:) + + integer timinc,i,j,k,nmax,kbeg,kend,loc1,loc2 + integer nstar + logical tend, first, strict, diurnal, mdiurnal, lquad, ldquad + logical ignore_nan + data first /.true./ + data strict /.true./ + + type(ESMF_Config) :: config + + integer, allocatable :: qloc(:,:) + character(len=ESMF_MAXSTR), allocatable :: quadratics(:,:) + character(len=ESMF_MAXSTR), allocatable :: quadtmp(:,:) + character(len=ESMF_MAXSTR), allocatable :: aliases(:,:) + character(len=ESMF_MAXSTR), allocatable :: aliastmp(:,:) + character(len=ESMF_MAXSTR) name1, name2, name3, dummy + integer nquad + integer nalias + logical, allocatable :: lzstar(:) + + integer ntmin, ntcrit, nc + + type(FileMetadata) :: basic_metadata + type(FileMetadataUtils) :: file_metadata + type(NetCDF4_FileFormatter) :: file_handle + integer :: status + class(AbstractGridfactory), allocatable :: factory + type(ESMF_Grid) :: output_grid,input_grid + character(len=:), allocatable :: output_grid_name + integer :: global_dims(3), local_dims(3) + type(ESMF_Time), allocatable :: time_series(:) + type(ESMF_TIme) :: etime + type(ESMF_Clock) :: clock + type(ESMF_TimeInterval) :: time_interval + type(ESMF_FieldBundle) :: primary_bundle,final_bundle,diurnal_bundle + type(ESMF_Field) :: field + type(ServerManager) :: io_server + type(FieldBundleWriter) :: standard_writer, diurnal_writer + real(ESMF_KIND_R4), pointer :: ptr2d(:,:),ptr3d(:,:,:) + character(len=ESMF_MAXSTR) :: grid_type + logical :: allow_zonal_means + character(len=ESMF_MAXPATHLEN) :: arg_str + character(len=:), allocatable :: lev_name + character(len=ESMF_MAXSTR) :: lev_units + integer :: n_times + type(verticalData) :: vertical_data + logical :: file_has_lev + type(DistributedProfiler), target :: t_prof + type(ProfileReporter) :: reporter + +! ********************************************************************** +! **** Initialization **** +! ********************************************************************** + +!call timebeg ('main') + + call mpi_init ( ierror ) ; comm = mpi_comm_world + call mpi_comm_rank ( comm,myid,ierror ) + call mpi_comm_size ( comm,npes,ierror ) + call ESMF_Initialize(logKindFlag=ESMF_LOGKIND_NONE,mpiCommunicator=MPI_COMM_WORLD, _RC) + call MAPL_Initialize(_RC) + t_prof = DistributedProfiler('time_ave_util',MpiTImerGauge(),MPI_COMM_WORLD) + call t_prof%start(_RC) + call io_server%initialize(MPI_COMM_WORLD,_RC) + root = myid.eq.0 + call ESMF_CalendarSetDefault(ESMF_CALKIND_GREGORIAN,_RC) + +! Read Command Line Arguments +! --------------------------- + begdate = -999 + begtime = -999 + enddate = -999 + endtime = -999 + ndt = -999 + ntod = -999 + ntmin = -999 + nargs = command_argument_count() + if( nargs.eq.0 ) then + call usage(root) + else + lquad = .TRUE. + ldquad = .FALSE. + diurnal = .FALSE. + mdiurnal = .FALSE. + ignore_nan = .FALSE. + do n=1,nargs + call get_command_argument(n,arg_str) + select case(trim(arg_str)) + case('-template') + call get_command_argument(n+1,template) + case('-tag') + call get_command_argument(n+1,output) + case('-rc') + call get_command_argument(n+1,rcfile) + case('-begdate') + call get_command_argument(n+1,arg_str) + read(arg_str,*)begdate + case('-begtime') + call get_command_argument(n+1,arg_str) + read(arg_str,*)begtime + case('-enddate') + call get_command_argument(n+1,arg_str) + read(arg_str,*)enddate + case('-endtime') + call get_command_argument(n+1,arg_str) + read(arg_str,*)endtime + case('-ntmin') + call get_command_argument(n+1,arg_str) + read(arg_str,*)ntmin + case('-ntod') + call get_command_argument(n+1,arg_str) + read(arg_str,*)ntod + case('-ndt') + call get_command_argument(n+1,arg_str) + read(arg_str,*)ndt + case('-strict') + call get_command_argument(n+1,arg_str) + read(arg_str,*)strict + case('-ogrid') + call get_command_argument(n+1,arg_str) + output_grid_name = trim(arg_str) + case('-noquad') + lquad = .FALSE. + case('-ignore_nan') + ignore_nan = .TRUE. + case('-d') + diurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-md') + mdiurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-dv') + ldquad = .true. + diurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-mdv') + ldquad = .true. + mdiurnal = .true. + if (n+1 .le. nargs) then + call get_command_argument(n+1,arg_str) + read(arg_str,fmt='(a1)') char + if (char.ne.'-') doutput=arg_str + end if + case('-eta') + nfiles = 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + do while (char .ne. '-' .and. n+nfiles.ne.nargs) + nfiles = nfiles + 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + enddo + if (char.eq.'-') nfiles = nfiles-1 + allocate(fname(nfiles)) + do m=1,nfiles + call get_command_argument(n+m,fname(m)) + enddo + case('-hdf') + nfiles = 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + do while (char .ne. '-' .and. n+nfiles.ne.nargs) + nfiles = nfiles + 1 + call get_command_argument(n+nfiles,arg_str) + read(arg_str,fmt='(a1)') char + enddo + if (char.eq.'-') nfiles = nfiles-1 + allocate(fname(nfiles)) + do m=1,nfiles + call get_command_argument(n+m,fname(m)) + enddo + end select + enddo + end if + + if( (diurnal.or.mdiurnal) .and. trim(doutput).eq.'NULL' ) then + doutput = trim(output) // "_diurnal" + if( mdiurnal ) diurnal = .FALSE. + endif + + if (root .and. ignore_nan) print *,' ignore nan is true' + + +! Read RC Quadratics +! ------------------ + if( trim(rcfile).eq.'NULL' ) then + nquad = 0 + nalias = 0 + else + config = ESMF_ConfigCreate ( rc=rc ) + call ESMF_ConfigLoadFile ( config, trim(rcfile), rc=rc ) + call ESMF_ConfigFindLabel ( config, 'QUADRATICS:', rc=rc ) + tend = .false. + m = 0 + do while (.not.tend) + m = m+1 + allocate( quadtmp(3,m) ) + call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=name3,default='XXX',rc=rc ) + call ESMF_ConfigNextLine ( config,tableEnd=tend, rc=rc ) + if( m==1 ) then + quadtmp(1,m) = name1 + quadtmp(2,m) = name2 + quadtmp(3,m) = name3 + allocate( quadratics(3,m) ) + quadratics = quadtmp + else + quadtmp(1,1:m-1) = quadratics(1,:) + quadtmp(2,1:m-1) = quadratics(2,:) + quadtmp(3,1:m-1) = quadratics(3,:) + quadtmp(1,m) = name1 + quadtmp(2,m) = name2 + quadtmp(3,m) = name3 + deallocate( quadratics ) + allocate( quadratics(3,m) ) + quadratics = quadtmp + endif + deallocate (quadtmp) + enddo + nquad = m + +! Read RC Aliases +! --------------- + call ESMF_ConfigFindLabel ( config, 'ALIASES:', rc=rc ) + tend = .false. + m = 0 + do while (.not.tend) + m = m+1 + allocate( aliastmp(2,m) ) + call ESMF_ConfigGetAttribute ( config,value=name1, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=dummy, rc=rc ) + call ESMF_ConfigGetAttribute ( config,value=name2, rc=rc ) + call ESMF_ConfigNextLine ( config,tableEnd=tend ,rc=rc ) + if( m==1 ) then + aliastmp(1,m) = name1 + aliastmp(2,m) = name2 + allocate( aliases(2,m) ) + aliases = aliastmp + else + aliastmp(1,1:m-1) = aliases(1,:) + aliastmp(2,1:m-1) = aliases(2,:) + aliastmp(1,m) = name1 + aliastmp(2,m) = name2 + deallocate( aliases ) + allocate( aliases(2,m) ) + aliases = aliastmp + endif + deallocate (aliastmp) + enddo + nalias = m + endif + if (.not. allocated(aliases)) allocate(aliases(0,0)) + +! ********************************************************************** +! **** Read HDF File **** +! ********************************************************************** + + call t_prof%start('initialize') + + if( trim(template).ne.'NULL' ) then + name = template + else + name = fname(1) + endif + + n = index(trim(name),'.',back=.true.) + ext = trim(name(n+1:)) + + call file_handle%open(trim(name),PFIO_READ,_RC) + basic_metadata = file_handle%read(_RC) + call file_handle%close(_RC) + + allocate(factory, source=grid_manager%make_factory(trim(name))) + input_grid = grid_manager%make_grid(factory) + file_has_lev = has_level(input_grid,_RC) + call MAPL_GridGet(input_grid,globalCellCountPerDim=global_dims,_RC) + lm = global_dims(3) + + if (file_has_lev) then + call get_file_levels(trim(name),vertical_data,_RC) + end if + + if (allocated(output_grid_name)) then + output_grid = create_output_grid(output_grid_name,lm,_RC) + else + output_grid = input_grid + end if + call ESMF_AttributeGet(output_grid,'GridType',grid_type,_RC) + allow_zonal_means = trim(grid_type) == 'LatLon' + if (trim(grid_type) == "Cubed-Sphere") then + _ASSERT(mod(npes,6)==0,"If input files are Cubed-Sphere, must be run on multiple of 6 proccessors") + end if + call MAPL_GridGet(output_grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) + im = local_dims(1) + jm = local_dims(2) + lm = local_dims(3) + imglobal = global_dims(1) + jmglobal = global_dims(2) + + call file_metadata%create(basic_metadata,trim(name)) + call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) + primary_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) + call ESMF_FieldBundleSet(primary_bundle,grid=output_grid,_RC) + call MAPL_Read_Bundle(primary_bundle,trim(name),time=time_series(1),_RC) + call ESMF_FieldBundleGet(primary_bundle,fieldCount=nvars,_RC) + allocate(vname(nvars)) + call ESMF_FieldBundleGet(primary_bundle,fieldNameList=vname,_RC) + kmvar = get_level_info(primary_bundle,_RC) + vtitle = get_long_names(primary_bundle,_RC) + vunits = get_units(primary_bundle,_RC) + + final_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) + call ESMF_FieldBundleSet(final_bundle,grid=output_grid,_RC) + diurnal_bundle = ESMF_FieldBundleCreate(name="first_file",_RC) + call ESMF_FieldBundleSet(diurnal_bundle,grid=output_grid,_RC) + call copy_bundle_to_bundle(primary_bundle,final_bundle,_RC) + + if (size(time_series)>1) then + time_interval = time_series(2) - time_series(1) + else if (size(time_series)==1) then + call ESMF_TimeIntervalSet(time_interval,h=6,_RC) + end if + clock = ESMF_ClockCreate(startTime=time_series(1),timeStep=time_interval,_RC) + + nvars2 = nvars + + if (file_has_lev) then + lev_name = file_metadata%get_level_name(_RC) + call file_metadata%get_coordinate_info(lev_name,coords=lev,coordUnits=lev_units,_RC) + end if + + previous_undef = file_metadata%var_get_missing_value(trim(vname(1)),_RC) + do i=2,size(vname) + undef = file_metadata%var_get_missing_value(trim(vname(i)),_RC) + _ASSERT(undef == previous_undef,"conflicting undefined values in your variables") + previous_undef = undef + enddo + undef = previous_undef + + +! Set NDT for Strict Time Testing +! ------------------------------- + if( ntod.ne.-999 ) ndt = 86400 + if( ndt .eq.-999 ) ndt = compute_nsecf (timinc) + if( timinc .eq. 0 ) then + timeId = ncvid (id, 'time', rc) + call ncagt (id, timeId, 'time_increment', timinc, rc) + if( timinc .eq. 0 ) then + if( root ) then + print * + print *, 'Warning, GFIO Inquire states TIMINC = ',timinc + print *, ' This will be reset to 060000 ' + print *, ' Use -ndt NNN (in seconds) to overide this' + endif + timinc = 060000 + endif + ndt = compute_nsecf (timinc) + endif + +! Determine Number of Time Periods within 1-Day +! --------------------------------------------- + ntods = 0 + if( diurnal .or. mdiurnal ) then + if( ndt.lt.86400 ) ntods = 86400/ndt + endif + +! Set Minimum Required Times for Time Average (Default: 10 Days for Monthly Mean) +! ------------------------------------------------------------------------------- + if( ntmin.eq.-999 ) then + if( ntod.eq.-999 ) then + ntcrit = 10 * ( 86400.0/real(compute_nsecf(timinc)) ) + else + ntcrit = 10 + endif + else + ntcrit = ntmin + endif + +! Determine Location Index for Each Variable in File +! -------------------------------------------------- + if( root ) print * + allocate ( nloc(nvars) ) + nloc(1) = 1 + if( root ) write(6,7000) 1,trim(vname(1)),nloc(1),trim(vtitle(1)),max(1,kmvar(1)) + do n=2,nvars + nloc(n) = nloc(n-1)+max(1,kmvar(n-1)) + if( root ) write(6,7000) n,trim(vname(n)),nloc(n),trim(vtitle(n)),max(1,kmvar(n)) +7000 format(1x,'Primary Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a40,2x,i2,3x,i2,3x,i2) + enddo + + nmax = nloc(nvars)+max(1,kmvar(nvars))-1 + allocate( dum (im,jm,nmax) ) + allocate( dumz1(im,jm) ) + allocate( dumz2(im,jm) ) + +! Append Default Quadratics to User-Supplied List +! ----------------------------------------------- + if( lquad ) then + if( nquad.eq.0 ) then + allocate( quadratics(3,nvars) ) + do n=1,nvars + quadratics(1,n) = trim( vname(n) ) + quadratics(2,n) = trim( vname(n) ) + quadratics(3,n) = 'XXX' + enddo + nquad = nvars + else + allocate( quadtmp(3,nquad+nvars) ) + quadtmp(1,1:nquad) = quadratics(1,:) + quadtmp(2,1:nquad) = quadratics(2,:) + quadtmp(3,1:nquad) = quadratics(3,:) + do n=1,nvars + quadtmp(1,nquad+n) = trim( vname(n) ) + quadtmp(2,nquad+n) = trim( vname(n) ) + quadtmp(3,nquad+n) = 'XXX' + enddo + nquad = nquad + nvars + deallocate( quadratics ) + allocate( quadratics(3,nquad) ) + quadratics = quadtmp + deallocate( quadtmp ) + endif + endif + + allocate ( qloc(2,nquad) ) + allocate ( lzstar(nquad) ) ; lzstar = .FALSE. + +! Determine Possible Quadratics +! ----------------------------- + km=kmvar(nvars) + m= nvars + do n=1,nquad + call check_quad ( quadratics(1,n),vname,nvars,aliases,nalias,qloc(1,n) ) + if( qloc(1,n)*qloc(2,n).ne.0 ) then + m=m+1 + allocate ( iloc(m) ) + iloc(1:m-1) = nloc + iloc(m) = iloc(m-1)+max(1,km) + deallocate ( nloc ) + allocate ( nloc(m) ) + nloc = iloc + deallocate ( iloc ) + km=kmvar( qloc(1,n) ) + endif + enddo + + mvars = m + nmax = nloc(m)+max(1,km)-1 + + allocate ( vname2( mvars) ) + allocate ( vtitle2( mvars) ) + allocate ( vunits2( mvars) ) + allocate ( kmvar2( mvars) ) + + vname2( 1:nvars) = vname + vtitle2( 1:nvars) = vtitle + vunits2( 1:nvars) = vunits + kmvar2( 1:nvars) = kmvar + + if( root .and. mvars.gt.nvars ) print * + mv= nvars + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv = mv+1 + + if( trim(quadratics(1,nv)).eq.trim(quadratics(2,nv)) ) then + vname2(mv) = "Var_" // trim(vname(qloc(1,nv))) + vtitle2(mv) = "Variance_of_" // trim(vname(qloc(1,nv))) + else + vname2(mv) = "Cov_" // trim(vname(qloc(1,nv))) // "_" // trim(vname(qloc(2,nv))) + vtitle2(mv) = "Covariance_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) + endif + + if( trim(quadratics(3,nv)).ne.'XXX' ) vname2(mv) = trim(quadratics(3,nv)) + + nstar = index( trim(quadratics(1,nv)),'star',back=.true. ) + if( nstar.ne.0 ) then + _ASSERT(allow_zonal_means,"grid is not lat-lon so cannot compute zonal means") + lzstar(nv) = .TRUE. + vtitle2(mv) = "Product_of_Zonal_Mean_Deviations_of_" // trim(vname(qloc(1,nv))) // "_and_" // trim(vname(qloc(2,nv))) + endif + + vunits2(mv) = trim(vunits(qloc(1,nv))) // " " // trim(vunits(qloc(2,nv))) + kmvar2(mv) = kmvar(qloc(1,nv)) + + call add_new_field_to_bundle(final_bundle,output_grid,kmvar(qloc(1,nv)),vname2(mv),vtitle2(mv),vunits2(mv),_RC) + + if( root ) write(6,7001) mv,trim(vname2(mv)),nloc(mv),trim(vtitle2(mv)),max(1,kmvar(qloc(1,nv))),qloc(1,nv),qloc(2,nv) +7001 format(1x,' Quad Field: ',i4,' Name: ',a12,' at location: ',i4,3x,a50,2x,i2,3x,i3,3x,i3) + endif + enddo + +!deallocate ( lev ) + deallocate ( yymmdd ) + deallocate ( hhmmss ) + deallocate ( vname ) + deallocate ( vtitle ) + deallocate ( vunits ) + deallocate ( kmvar ) + + allocate( qmin(nmax) ) + allocate( qmax(nmax) ) + allocate( q(im,jm,nmax,0:ntods) ) + allocate( ntimes(im,jm,nmax,0:ntods) ) + ntimes = 0 + q = 0 + qmin = abs(undef) + qmax = -abs(undef) + + if( root ) then + print * + write(6,7002) mvars,nmax,im,jm,nmax,ntods +7002 format(1x,'Total Number of Variables: ',i3,/ & + 1x,'Total Size: ',i5,/ & + 1x,'Allocating q(',i4,',',i3,',',i5,',0:',i2.2,')') + print * + print *, 'Files: ' + do n=1,nfiles + print *, n,trim(fname(n)) + enddo + print * + if( ntod.eq.-999 ) then + print *, 'Averging Time-Period NHMS: ',ntod,' (ALL Possible Time Periods Used)' + else + print *, 'Averging Time-Period NHMS: ',ntod + endif + if( begdate.ne.-999 .or. begtime.ne.-999 ) print *, 'Beginning Date for Averaging: ',begdate,begtime + if( enddate.ne.-999 .or. endtime.ne.-999 ) print *, ' Ending Date for Averaging: ',enddate,endtime + if( strict ) then + print *, 'Every Time Period Required for Averaging, STRICT = ',strict + else + print *, 'Only Averaging Time Periods Supplied, STRICT = ',strict + endif + write(6,7003) ntcrit +7003 format(1x,'Required Minimum Number of Defined Time Periods: ',i3,' (Otherwise, UNDEF)') + print * + endif + + call t_prof%stop('initialize') + +! ********************************************************************** +! **** Read HDF Files **** +! ********************************************************************** + + k = 0 + + do n=1,nfiles + + if (allocated(time_series)) deallocate(time_series) + if (allocated(yymmdd)) deallocate(yymmdd) + if (allocated(hhmmss)) deallocate(hhmmss) + call file_handle%open(trim(fname(n)),PFIO_READ,_RC) + basic_metadata = file_handle%read(_RC) + call file_handle%close(_RC) + call file_metadata%create(basic_metadata,trim(fname(n))) + call get_file_times(file_metadata,ntime,time_series,timinc,yymmdd,hhmmss,_RC) + + + do m=1,ntime + nymd = yymmdd(m) + nhms = hhmmss(m) + if( nhms<0 ) then + nhms = compute_nhmsf( compute_nsecf(nhms) + 86400 ) + call tick (nymd,nhms,-86400) + endif + + if( ( begdate.ne.-999 .and. begtime.ne.-999 ) .and. & + ( begdate.gt.nymd .or. & + ( begdate.eq.nymd.and.begtime.gt.nhms ) ) ) cycle + + if( ( enddate.ne.-999 .and. endtime.ne.-999 ) .and. & + ( enddate.lt.nymd .or. & + ( enddate.eq.nymd.and.endtime.lt.nhms ) ) ) cycle + + k = k+1 + if( k.gt.ntods ) k = 1 + if( ntod.eq.-999 .or. ntod.eq.nhms ) then + if( root ) write(6,3000) nymd,nhms,timinc,trim(fname(n)),k +3000 format(1x,'Reading nymd: ',i8.8,' nhms: ',i6.6,' TimInc: ',i6.6,' from File: ',a,' tod = ',i2) + year = nymd/10000 + month = mod(nymd,10000)/100 + +! Check for Correct First Dataset +! ------------------------------- + if( strict .and. first ) then + nymdm = nymd + nhmsm = nhms + call tick (nymdm,nhmsm,-ndt) + yearm = nymdm/10000 + monthm = mod(nymdm,10000)/100 + if( year.eq.yearm .and. month.eq.monthm ) then + if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct First Time Period!' + _FAIL("error processing dataset") + endif + endif + +! Check Date and Time for STRICT Time Testing +! ------------------------------------------- + if( strict .and. .not.first ) then + if( nymd.ne.nymdp .or. nhms.ne.nhmsp ) then + if( root ) print *, 'Date: ',nymdp,' Time: ',nhmsp,' not found!' + _FAIL("error processing dataset") + endif + endif + nymdp = nymd + nhmsp = nhms + +! Primary Fields +! -------------- + + etime = local_esmf_timeset(nymd,nhms,_RC) + call MAPL_Read_Bundle(primary_bundle,trim(fname(1)),time=etime,file_override=trim(fname(n)),_RC) + do nv=1,nvars2 + call ESMF_FieldBundleGet(primary_bundle,trim(vname2(nv)),field=field,_RC) + call t_prof%start('PRIME') + if( kmvar2(nv).eq.0 ) then + kbeg = 0 + kend = 1 + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + dum(:,:,nloc(nv))=ptr2d + else + kbeg = 1 + kend = kmvar2(nv) + + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + dum(:,:,nloc(nv):nloc(nv)+kmvar2(nv)-1) = ptr3d + endif + + rc = 0 + do L=1,max(1,kmvar2(nv)) + do j=1,jm + do i=1,im + if( isnan( dum(i,j,nloc(nv)+L-1) ) .or. ( dum(i,j,nloc(nv)+L-1).gt.HUGE(dum(i,j,nloc(nv)+L-1)) ) ) then +!print *, 'Warning! Nan or Infinity detected for ',trim(vname2(nv)),' at lat: ',lattice%jglobal(j),' lon: ',lattice%iglobal(i) + if( root .and. ignore_nan ) then + print *, 'Setting Nan or Infinity to UNDEF' + print * + else + rc = 1 + endif + dum(i,j,nloc(nv)+L-1) = undef + endif + if( defined(dum(i,j,nloc(nv)+L-1),undef) ) then + q(i,j,nloc(nv)+L-1,0) = q(i,j,nloc(nv)+L-1,0) + dum(i,j,nloc(nv)+L-1) + ntimes(i,j,nloc(nv)+L-1,0) = ntimes(i,j,nloc(nv)+L-1,0) + 1 + if( qmin(nloc(nv)+L-1).gt.dum(i,j,nloc(nv)+L-1) ) qmin(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) + if( qmax(nloc(nv)+L-1).lt.dum(i,j,nloc(nv)+L-1) ) qmax(nloc(nv)+L-1) = dum(i,j,nloc(nv)+L-1) + if( ntods.ne.0 ) then + q(i,j,nloc(nv)+L-1,k) = q(i,j,nloc(nv)+L-1,k) + dum(i,j,nloc(nv)+L-1) + ntimes(i,j,nloc(nv)+L-1,k) = ntimes(i,j,nloc(nv)+L-1,k) + 1 + endif + endif + enddo + enddo + enddo + call t_prof%stop('PRIME') + + enddo + +! Quadratics +! ---------- + call t_prof%start('QUAD') + mv= nvars2 + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv=mv+1 + do L=1,max(1,kmvar2(qloc(1,nv))) + if( lzstar(nv) ) then + call latlon_zstar (dum(:,:,nloc(qloc(1,nv))+L-1),dumz1,undef,output_grid,_RC) + call latlon_zstar (dum(:,:,nloc(qloc(2,nv))+L-1),dumz2,undef,output_grid,_RC) + do j=1,jm + do i=1,im + if( defined(dumz1(i,j),undef) .and. & + defined(dumz2(i,j),undef) ) then + q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dumz1(i,j)*dumz2(i,j) + ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 + if( ntods.ne.0 ) then + q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dumz1(i,j)*dumz2(i,j) + ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 + endif + endif + enddo + enddo + else + do j=1,jm + do i=1,im + if( defined(dum(i,j,nloc(qloc(1,nv))+L-1),undef) .and. & + defined(dum(i,j,nloc(qloc(2,nv))+L-1),undef) ) then + q(i,j,nloc(mv)+L-1,0) = q(i,j,nloc(mv)+L-1,0) + dum(i,j,nloc(qloc(1,nv))+L-1) & + * dum(i,j,nloc(qloc(2,nv))+L-1) + ntimes(i,j,nloc(mv)+L-1,0) = ntimes(i,j,nloc(mv)+L-1,0) + 1 + if( ntods.ne.0 ) then + q(i,j,nloc(mv)+L-1,k) = q(i,j,nloc(mv)+L-1,k) + dum(i,j,nloc(qloc(1,nv))+L-1) & + * dum(i,j,nloc(qloc(2,nv))+L-1) + ntimes(i,j,nloc(mv)+L-1,k) = ntimes(i,j,nloc(mv)+L-1,k) + 1 + endif + endif + enddo + enddo + endif + enddo + endif + enddo + call t_prof%stop('QUAD') + + if( first ) then + nymd0 = nymd + nhms0 = nhms + first = .false. + endif + +! Update Date and Time for Strict Test +! ------------------------------------ + call tick (nymdp,nhmsp,ndt) + yearp = nymdp/10000 + monthp = mod(nymdp,10000)/100 + + endif ! End ntod Test + enddo ! End ntime Loop within file + + call MPI_BARRIER(comm,status) + enddo + + do k=0,ntods + if( k.eq.0 ) then + nc = ntcrit + else + nc = max( 1,ntcrit/ntods ) + endif + do n=1,nmax + do j=1,jm + do i=1,im + if( ntimes(i,j,n,k).lt.nc ) then + q(i,j,n,k) = undef + else + q(i,j,n,k) = q(i,j,n,k)/ntimes(i,j,n,k) + endif + enddo + enddo + enddo + enddo + +! ********************************************************************** +! **** Write HDF Monthly Output File **** +! ********************************************************************** + +call t_prof%start('Write_AVE') + +! Check for Correct Last Dataset +! ------------------------------ + if( strict .and. ( year.eq.yearp .and. month.eq.monthp ) ) then + if( root ) print *, 'Date: ',nymd,' Time: ',nhms,' is NOT correct Last Time Period!' + _FAIL("Error processing dataset") + endif + + write(date0,4000) nymd0/100 + write(time0,2000) nhms0/10000 + + hdfile = trim(output) // "." // trim(date0) // "." // trim(ext) + +1000 format(i8.8) +2000 format(i2.2) +4000 format(i6.6) + + timeinc = 060000 + +! Primary Fields +! -------------- + if( root ) print * + do n=1,nvars2 + call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) + if( kmvar2(n).eq.0 ) then + kbeg = 0 + kend = 1 + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = q(:,:,nloc(n),0) + else + kbeg = 1 + kend = kmvar2(n) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,0) + endif + if( root ) write(6,3001) trim(vname2(n)),nloc(n),trim(hdfile) +3001 format(1x,'Writing ',a,' at location ',i6,' into File: ',a) + dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,0) + enddo + +! Quadratics +! ---------- + mv= nvars2 + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv=mv+1 + if( root ) write(6,3001) trim(vname2(mv)),nloc(mv),trim(hdfile) + call ESMF_FieldBundleGet(final_bundle,trim(vname2(mv)),field=field,_RC) + + if( kmvar2(qloc(1,nv)).eq.0 ) then + kbeg = 0 + kend = 1 + else + kbeg = 1 + kend = kmvar2(qloc(1,nv)) + endif + loc1 = nloc( qloc(1,nv) ) + loc2 = nloc( qloc(2,nv) ) + if( .not.lzstar(nv) ) then + where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) - q(:,:,loc1:loc1+kend-1,0) & + * q(:,:,loc2:loc2+kend-1,0) + elsewhere + dum(:,:,1:kend) = undef + endwhere + else + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,0) + endif + if( kmvar2(qloc(1,nv)).eq.0 ) then + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = dum(:,:,1) + else + kend = kmvar2(qloc(1,nv)) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = dum(:,:,1:kend) + endif + endif + enddo + + if( root ) then + print * + print *, 'Created: ',trim(hdfile) + print * + endif + call t_prof%stop('Write_AVE') + etime = local_esmf_timeset(nymd0,nhms0,_RC) + call ESMF_ClockSet(clock,currTime=etime, _RC) + call standard_writer%create_from_bundle(final_bundle,clock,n_steps=1,time_interval=timeinc,vertical_data=vertical_data,_RC) + call standard_writer%start_new_file(trim(hdfile),_RC) + call standard_writer%write_to_file(_RC) + +! ********************************************************************** +! **** Write HDF Monthly Diurnal Output File **** +! ********************************************************************** + + if( ntods.ne.0 ) then + call t_prof%start('Write_Diurnal') + timeinc = compute_nhmsf( 86400/ntods ) + + do k=1,ntods + + if( k.eq.1 .or. mdiurnal ) then + + write(date0,4000) nymd0/100 + write(time0,2000) nhms0/10000 + + if( diurnal ) hdfile = trim(doutput) // "." // trim(date0) // "." // trim(ext) + if( mdiurnal ) hdfile = trim(doutput) // "." // trim(date0) // "_" // trim(time0) // "z." // trim(ext) + + if( ldquad ) then + ndvars = mvars ! Include Quadratics in Diurnal Files + if (k==1) then + call copy_bundle_to_bundle(final_bundle,diurnal_bundle,_RC) + end if + else + ndvars = nvars2 ! Only Include Primary Fields in Diurnal Files (Default) + if (k==1) then + do n=1,nvars + call ESMF_FieldBundleGet(final_bundle,trim(vname2(n)),field=field,_RC) + call MAPL_FieldBundleAdd(diurnal_bundle,field,_RC) + enddo + endif + endif + endif + +! Primary Fields +! -------------- + do n=1,nvars2 + call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(n)),field=field,_RC) + if( kmvar2(n).eq.0 ) then + kbeg = 0 + kend = 1 + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = q(:,:,nloc(n),k) + else + kbeg = 1 + kend = kmvar2(n) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = q(:,:,nloc(n):nloc(n)+kend-1,k) + endif + dum(:,:,1:kend) = q(:,:,nloc(n):nloc(n)+kend-1,k) + enddo + +! Quadratics +! ---------- + if( ndvars.eq.mvars ) then + mv= nvars2 + do nv=1,nquad + if( qloc(1,nv)*qloc(2,nv).ne.0 ) then + mv=mv+1 + call ESMF_FieldBundleGet(diurnal_bundle,trim(vname2(mv)),field=field,_RC) + if( kmvar2(qloc(1,nv)).eq.0 ) then + kbeg = 0 + kend = 1 + else + kbeg = 1 + kend = kmvar2(qloc(1,nv)) + endif + loc1 = nloc( qloc(1,nv) ) + loc2 = nloc( qloc(2,nv) ) + if( .not.lzstar(nv) ) then + where( q(:,:,nloc(mv):nloc(mv)+kend-1,0).ne.undef ) + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) - q(:,:,loc1:loc1+kend-1,k) & + * q(:,:,loc2:loc2+kend-1,k) + elsewhere + dum(:,:,1:kend) = undef + endwhere + else + dum(:,:,1:kend) = q(:,:,nloc(mv):nloc(mv)+kend-1,k) + endif + if( kmvar2(qloc(1,nv)).eq.0 ) then + call ESMF_FieldGet(field,0,farrayPtr=ptr2d,_RC) + ptr2d = dum(:,:,1) + else + kend = kmvar2(qloc(1,nv)) + call ESMF_FieldGet(field,0,farrayPtr=ptr3d,_RC) + ptr3d = dum(:,:,1:kend) + endif + endif + enddo + endif + + + etime = local_esmf_timeset(nymd0,nhms0,_RC) + call ESMF_ClockSet(clock,currTime=etime, _RC) + if (k==1 .or. mdiurnal) then + if (mdiurnal) then + n_times = 1 + else + n_times = ntods + end if + if (k==1) then + call diurnal_writer%create_from_bundle(diurnal_bundle,clock,n_steps=n_times,time_interval=timeinc,vertical_data=vertical_data) + end if + call diurnal_writer%start_new_file(trim(hdfile),_RC) + end if + call diurnal_writer%write_to_file(_RC) + if( root .and. mdiurnal ) then + print *, 'Created: ',trim(hdfile) + endif + call tick (nymd0,nhms0,ndt) + enddo + + if( root .and. diurnal ) then + print *, 'Created: ',trim(hdfile) + endif + if( root ) print * + + call t_prof%stop('Write_Diurnal') + endif + +! ********************************************************************** +! **** Write Min/Max Information **** +! ********************************************************************** + + if( root ) print * + do n=1,nvars2 + do L=1,max(1,kmvar2(n)) + if( kmvar2(n).eq.0 ) then + plev = 0 + else + plev = lev(L) + endif + + call mpi_reduce( qmin(nloc(n)+L-1),qming,1,mpi_real,mpi_min,0,comm,ierror ) + call mpi_reduce( qmax(nloc(n)+L-1),qmaxg,1,mpi_real,mpi_max,0,comm,ierror ) + if( root ) then + if(L.eq.1) then + write(6,3101) trim(vname2(n)),plev,qming,qmaxg + else + write(6,3102) trim(vname2(n)),plev,qming,qmaxg + endif + endif +3101 format(1x,'Primary Field: ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) +3102 format(1x,' ',a20,' Level: ',f9.3,' Min: ',g15.8,' Max: ',g15.8) + enddo + call MPI_BARRIER(comm,status) + if( root ) print * + enddo + if( root ) print * + +! ********************************************************************** +! **** Timing Information **** +! ********************************************************************** + + call io_server%finalize() + call t_prof%stop() + call t_prof%reduce() + call t_prof%finalize() + call generate_report() + call MAPL_Finalize() + call MPI_Finalize(status) + stop + +contains + + function create_output_grid(grid_name,lm,rc) result(new_grid) + type(ESMF_Grid) :: new_grid + character(len=*), intent(inout) :: grid_name + integer, intent(in) :: lm + integer, optional, intent(out) :: rc + + type(ESMF_Config) :: cf + integer :: nn,im_world,jm_world,nx, ny + character(len=5) :: imsz,jmsz + character(len=2) :: pole,dateline + + nn = len_trim(grid_name) + imsz = grid_name(3:index(grid_name,'x')-1) + jmsz = grid_name(index(grid_name,'x')+1:nn-3) + pole = grid_name(1:2) + dateline = grid_name(nn-1:nn) + read(IMSZ,*) im_world + read(JMSZ,*) jm_world + + cf = MAPL_ConfigCreate(_RC) + call MAPL_ConfigSetAttribute(cf,value=lm, label=trim(grid_name)//".LM:",_RC) + if (dateline=='CF') then + call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) + call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) + call MAPL_ConfigSetAttribute(cf,value="Cubed-Sphere", label=trim(grid_name)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cf,value=6, label=trim(grid_name)//".NF:",_RC) + call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) + else if (dateline=='TM') then + _FAIL("Tripolar not yet implemented for outpout") + else + call MAPL_MakeDecomposition(nx,ny,_RC) + call MAPL_ConfigSetAttribute(cf,value=NX, label=trim(grid_name)//".NX:",_RC) + call MAPL_ConfigSetAttribute(cf,value="LatLon", label=trim(grid_name)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cf,value=im_world,label=trim(grid_name)//".IM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cf,value=jm_world,label=trim(grid_name)//".JM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cf,value=ny, label=trim(grid_name)//".NY:",_RC) + call MAPL_ConfigSetAttribute(cf,value=pole, label=trim(grid_name)//".POLE:",_RC) + call MAPL_ConfigSetAttribute(cf,value=dateline, label=trim(grid_name)//".DATELINE:",_RC) + if (pole=='XY' .and. dateline=='XY') then + _FAIL("regional lat-lon output not supported") + end if + end if + + new_grid = grid_manager%make_grid(cf,prefix=trim(grid_name)//".",_RC) + if (present(rc)) then + rc=_SUCCESS + end if + end function create_output_grid + + subroutine get_file_levels(filename,vertical_data,rc) + character(len=*), intent(in) :: filename + type(VerticalData), intent(inout) :: vertical_data + integer, intent(out), optional :: rc + + integer :: status + type(NetCDF4_fileFormatter) :: formatter + type(FileMetadata) :: basic_metadata + type(FileMetadataUtils) :: metadata + character(len=:), allocatable :: lev_name + character(len=ESMF_MAXSTR) :: long_name + character(len=ESMF_MAXSTR) :: standard_name + character(len=ESMF_MAXSTR) :: vcoord + character(len=ESMF_MAXSTR) :: lev_units + real, allocatable, target :: levs(:) + real, pointer :: plevs(:) + + call formatter%open(trim(filename),pFIO_Read,_RC) + basic_metadata=formatter%read(_RC) + call metadata%create(basic_metadata,trim(filename)) + lev_name = metadata%get_level_name(_RC) + if (lev_name /= '') then + call metadata%get_coordinate_info(lev_name,coords=levs,coordUnits=lev_units,long_name=long_name,& + standard_name=standard_name,coordinate_attr=vcoord,_RC) + plevs => levs + vertical_data = VerticalData(levels=plevs,vunit=lev_units,vcoord=vcoord,standard_name=standard_name,long_name=long_name, & + force_no_regrid=.true.,_RC) + nullify(plevs) + end if + + if (present(rc)) then + rc=_SUCCESS + end if + + end subroutine get_file_levels + + function has_level(grid,rc) result(grid_has_level) + logical :: grid_has_level + type(ESMF_Grid), intent(in) :: grid + integer, intent(out), optional :: rc + integer :: status, global_dims(3) + call MAPL_GridGet(grid,globalCellCountPerDim=global_dims,_RC) + grid_has_level = (global_dims(3)>1) + if (present(rc)) then + RC=_SUCCESS + end if + end function has_level + + subroutine copy_bundle_to_bundle(input_bundle,output_bundle,rc) + type(ESMF_FieldBundle), intent(inout) :: input_bundle + type(ESMF_FieldBundle), intent(inout) :: output_bundle + integer, intent(out), optional :: rc + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: i,num_fields + call ESMF_FieldBundleGet(input_bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + call ESMF_FieldBundleGet(input_bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(input_bundle,field_list(i),field=field,_RC) + call MAPL_FieldBundleAdd(output_bundle,field,_RC) + enddo + if (present(rc)) then + RC=_SUCCESS + end if + end subroutine copy_bundle_to_bundle + + subroutine add_new_field_to_bundle(bundle,grid,lm,field_name,long_name,units,rc) + type(ESMF_FieldBundle), intent(inout) :: bundle + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: lm + character(len=*), intent(in) :: field_name + character(len=*), intent(in) :: long_name + character(len=*), intent(in) :: units + integer, intent(out), optional :: rc + + integer :: status + type(ESMF_Field) :: field + + if (lm == 0) then + field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4,_RC) + else if (lm > 0) then + field = ESMF_FieldCreate(grid,name=trim(field_name),typekind=ESMF_TYPEKIND_R4, & + ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + end if + call ESMF_AttributeSet(field,name='LONG_NAME',value=trim(long_name),_RC) + call ESMF_AttributeSet(field,name='UNITS',value=trim(units),_RC) + if (lm == 0) then + call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzOnly,_RC) + call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationNone,_RC) + else if (lm > 0) then + call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzVert,_RC) + call ESMF_AttributeSet(field,name='VLOCATION',value=MAPL_VLocationCenter,_RC) + end if + call MAPL_FieldBundleAdd(bundle,field,_RC) + if (present(rc)) then + RC=_SUCCESS + end if + end subroutine add_new_field_to_bundle + + subroutine get_file_times(file_metadata,num_times,time_series,time_interval,yymmdd,hhmmss,rc) + type(FileMetadataUtils), intent(inout) :: file_metadata + integer, intent(out) :: num_times + type(ESMF_Time), allocatable, intent(inout) :: time_series(:) + integer, intent(inout), allocatable :: yymmdd(:) + integer, intent(inout), allocatable :: hhmmss(:) + integer, intent(out) :: time_interval + integer, intent(out), optional :: rc + + integer :: status + type(ESMF_TimeInterval) :: esmf_time_interval + integer :: hour, minute, second, year, month, day, i + + num_times = file_metadata%get_dimension('time',_RC) + call file_metadata%get_time_info(timeVector=time_series,_RC) + if (num_times == 1) then + time_interval = file_metadata%get_var_attr_int32('time','time_increment',_RC) + else if (num_times > 1) then + esmf_time_interval = time_series(2)-time_series(1) + call ESMF_TimeIntervalGet(esmf_time_interval,h=hour,m=minute,s=second,_RC) + time_interval = hour*10000+minute*100+second + end if + + allocate(yymmdd(num_times),hhmmss(num_times)) + do i = 1,num_times + call ESMF_TimeGet(time_series(i),yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) + yymmdd(i)=year*10000+month*100+day + hhmmss(i)=hour*10000+minute*100+second + enddo + if (present(rc)) then + rc=_SUCCESS + end if + end subroutine get_file_times + + function get_level_info(bundle,rc) result(kmvar) + integer, allocatable :: kmvar(:) + type(ESMF_FieldBundle), intent(in) :: bundle + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: rank,i,num_fields,lb(1),ub(1) + call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + allocate(kmvar(num_fields)) + call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) + call ESMF_FieldGet(field,rank=rank,_RC) + if (rank==2) then + kmvar(i)=0 + else if (rank==3) then + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + kmvar(i)=ub(1)-lb(1)+1 + else + _FAIL("Unsupported rank") + end if + end do + if (present(rc)) then + RC=_SUCCESS + end if + end function get_level_info + + function get_long_names(bundle,rc) result(long_names) + character(len=ESMF_MAXSTR), allocatable :: long_names(:) + type(ESMF_FieldBundle), intent(in) :: bundle + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: i,num_fields + + call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + allocate(long_names(num_fields)) + call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) + call ESMF_AttributeGet(field,name='LONG_NAME',value=long_names(i),_RC) + enddo + if (present(rc)) then + RC=_SUCCESS + end if + end function get_long_names + + function get_units(bundle,rc) result(units) + character(len=ESMF_MAXSTR), allocatable :: units(:) + type(ESMF_FieldBundle), intent(in) :: bundle + integer, optional, intent(out) :: rc + + integer :: status + character(len=ESMF_MAXSTR), allocatable :: field_list(:) + type(ESMF_Field) :: field + integer :: i,num_fields + + call ESMF_FieldBundleGet(bundle,fieldCount=num_fields,_RC) + allocate(field_list(num_fields)) + allocate(units(num_fields)) + call ESMF_FieldBundleGet(bundle,fieldNameList=field_list,_RC) + do i=1,num_fields + call ESMF_FieldBundleGet(bundle,field_list(i),field=field,_RC) + call ESMF_AttributeGet(field,name='UNITS',value=units(i),_RC) + enddo + if (present(rc)) then + RC=_SUCCESS + end if + end function get_units + + function local_esmf_timeset(yymmdd,hhmmss,rc) result(etime) + type(ESMF_Time) :: etime + integer, intent(in) :: yymmdd + integer, intent(in) :: hhmmss + integer, intent(out), optional :: rc + + integer :: year,month,day,hour,minute,second,status + year = yymmdd/10000 + month = mod(yymmdd/100,100) + day = mod(yymmdd,100) + + hour = hhmmss/10000 + minute = mod(hhmmss/100,100) + second = mod(hhmmss,100) + + call ESMF_TimeSet(etime,yy=year,mm=month,dd=day,h=hour,m=minute,s=second,_RC) + if (present(rc)) then + rc=_SUCCESS + endif + end function local_esmf_timeset + + function defined ( q,undef ) + implicit none + logical defined + real q,undef + defined = q /= undef + end function defined + + subroutine latlon_zstar (q,qp,undef,grid,rc) + real, intent(inout) :: q(:,:) + real, intent(out) :: qp(:,:) + real, intent(in) :: undef + type (ESMF_Grid), intent(inout) :: grid + integer, optional, intent(out) :: rc + + integer :: local_dims(3) + integer im,jm,i,j,status + real, allocatable :: qz(:) + + call MAPL_GridGet(grid,localCellCountPerDim=local_dims,_RC) + im = local_dims(1) + jm = local_dims(2) + allocate(qz(jm)) + + call latlon_zmean ( q,qz,undef,grid ) + do j=1,jm + if( qz(j).eq. undef ) then + qp(:,j) = undef + else + do i=1,im + if( defined( q(i,j),undef) ) then + qp(i,j) = q(i,j) - qz(j) + else + qp(i,j) = undef + endif + enddo + endif + enddo + if (present(rc)) then + rc=_SUCCESS + endif + end subroutine latlon_zstar + + subroutine latlon_zmean ( q,qz,undef,grid,rc) + real, intent(inout) :: q(:,:) + real, intent(inout) :: qz(:) + real, intent(in) :: undef + type(ESMF_Grid), intent(inout) :: grid + integer, optional, intent(out) :: rc + + integer :: im,jm,im_global,jm_global,local_dims(3),global_dims(3),status,nx,ny + real, allocatable :: qg(:,:) + real, allocatable :: buf(:,:) + real :: qsum + integer :: mpistatus(mpi_status_size) + integer, allocatable :: ims(:),jms(:) + integer j,n,peid,peid0,i1,j1,in,jn,mypet,i_start,i_end,isum + type(ESMF_VM) :: vm + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,localPet=mypet,_RC) + call MAPL_GridGet(grid,localCellCountPerDim=local_dims,globalCellCountPerDim=global_dims,_RC) + im = local_dims(1) + jm = local_dims(2) + im_global = global_dims(1) + jm_global = global_dims(2) + call get_esmf_grid_layout(grid,nx,ny,ims,jms,_RC) + call mapl_grid_interior(grid,i1,in,j1,jn) + + qz = 0.0 + allocate( qg(im_global,jm) ) + peid0 = (mypet/nx)*ny + if (i1==1) then + i_start = 1 + i_end = ims(1) + qg(i_start:i_end,:)=q + do n=1,nx-1 + allocate(buf(ims(n+1),jm)) + peid = mypet + n + call mpi_recv(buf,ims(n+1)*jm,MPI_FLOAT,peid,peid,MPI_COMM_WORLD,mpistatus,status) + _VERIFY(status) + i_start=i_end+1 + i_end = i_start+ims(n)-1 + qg(i_start:i_end,:)=buf + deallocate(buf) + enddo + else + call mpi_send(q,im*jm,MPI_FLOAT,peid0,mypet,MPI_COMM_WORLD,status) + _VERIFY(status) + end if + +! compute zonal mean + if (i1 == 1) then + do j=1,jm + isum = count(qg(:,j) /= undef) + qsum = sum(qg(:,j),mask=qg(:,j)/=undef) + if (isum == 0) then + qz(j)=undef + else + qz(j)=qsum/real(isum) + end if + enddo + +! send mean back to other ranks + do n=1,nx-1 + peid = peid0+n + call mpi_send(qz,jm,MPI_FLOAT,peid,peid0,MPI_COMM_WORLD,status) + _VERIFY(status) + enddo + else + call mpi_recv(qz,jm,MPI_FLOAT,peid0,peid0,MPI_COMM_WORLD,mpistatus,status) + _VERIFY(status) + end if + + if (present(rc)) then + rc=_SUCCESS + endif + + end subroutine latlon_zmean + + subroutine get_esmf_grid_layout(grid,nx,ny,ims_out,jms_out,rc) + type(ESMF_Grid), intent(inout) :: grid + integer, intent(out) :: nx + integer, intent(out) :: ny + integer, intent(inout), allocatable :: ims_out(:) + integer, intent(inout), allocatable :: jms_out(:) + integer, optional, intent(out) :: rc + + type(ESMF_VM) :: vm + integer :: status + type(ESMF_DistGrid) :: dist_grid + integer, allocatable :: minindex(:,:),maxindex(:,:) + integer :: dim_count, ndes + integer, pointer :: ims(:),jms(:) + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,petCount=ndes,_RC) + call ESMF_GridGet(grid,distgrid=dist_grid,dimCOunt=dim_count,_RC) + allocate(minindex(dim_count,ndes),maxindex(dim_count,ndes)) + call MAPL_DistGridGet(dist_grid,minIndex=minindex,maxIndex=maxindex,_RC) + call MAPL_GetImsJms(minindex(1,:),maxindex(1,:),minindex(2,:),maxindex(2,:),ims,jms,_RC) + nx = size(ims) + ny = size(jms) + allocate(ims_out(nx),jms_out(ny)) + ims_out = ims + jms_out = jms + + if (present(rc)) then + rc=_SUCCESS + endif + + end subroutine get_esmf_grid_layout + + subroutine check_quad ( quad,vname,nvars,aliases,nalias,qloc ) + integer :: nvars, nalias + character(len=ESMF_MAXSTR) quad(2), aliases(2,nalias), vname(nvars) + integer qloc(2) + integer m,n + +! Initialize Location of Quadratics +! --------------------------------- + qloc = 0 + +! Check Quadratic Name against HDF Variable Names +! ----------------------------------------------- + do n=1,nvars + if( trim(vname(n)).eq.trim(quad(1)) ) qloc(1) = n + if( trim(vname(n)).eq.trim(quad(2)) ) qloc(2) = n + enddo + +! Check Quadratic Name against Aliases +! ------------------------------------ + do m=1,nalias + if( trim(quad(1)).eq.trim(aliases(1,m)) ) then + do n=1,nvars + if( trim(vname(n)).eq.trim(quad(1)) .or. & + trim(vname(n)).eq.trim(aliases(2,m)) ) then + qloc(1) = n + exit + endif + enddo + endif + if( trim(quad(2)).eq.trim(aliases(1,m)) ) then + do n=1,nvars + if( trim(vname(n)).eq.trim(quad(2)) .or. & + trim(vname(n)).eq.trim(aliases(2,m)) ) then + qloc(2) = n + exit + endif + enddo + endif + enddo + + end subroutine check_quad + + function compute_nsecf (nhms) result(seconds) + integer :: seconds + integer, intent(in) :: nhms + seconds = nhms/10000*3600 + mod(nhms,10000)/100*60 + mod(nhms,100) + end function compute_nsecf + + function compute_nhmsf (nsec) result(nhmsf) + integer :: nhmsf + integer, intent(in) :: nsec + nhmsf = nsec/3600*10000 + mod(nsec,3600)/60*100 + mod(nsec,60) + end function compute_nhmsf + + subroutine tick (nymd,nhms,ndt) + integer, intent(inout) :: nymd + integer, intent(inout) :: nhms + integer, intent(in) :: ndt + + integer :: nsec + + if(ndt.ne.0) then + nsec = compute_nsecf(nhms) + ndt + + if (nsec.gt.86400) then + do while (nsec.gt.86400) + nsec = nsec - 86400 + nymd = compute_incymd (nymd,1) + enddo + endif + + if (nsec.eq.86400) then + nsec = 0 + nymd = compute_incymd (nymd,1) + endif + + if (nsec.lt.00000) then + do while (nsec.lt.0) + nsec = 86400 + nsec + nymd = compute_incymd (nymd,-1) + enddo + endif + + nhms = compute_nhmsf (nsec) + endif + + end subroutine tick + + function compute_incymd (nymd,m) result(incymd) + integer :: incymd + integer, intent(in) :: nymd + integer, intent(in) :: m +!*********************************************************************** +! purpose +! incymd: nymd changed by one day +! modymd: nymd converted to julian date +! description of parameters +! nymd current date in yymmdd format +! m +/- 1 (day adjustment) +! +!*********************************************************************** +!* goddard laboratory for atmospheres * +!*********************************************************************** + + integer ndpm(12) + data ndpm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ + integer :: ny,nm,nd +!*********************************************************************** +! + ny = nymd / 10000 + nm = mod(nymd,10000) / 100 + nd = mod(nymd,100) + m + + if (nd.eq.0) then + nm = nm - 1 + if (nm.eq.0) then + nm = 12 + ny = ny - 1 + endif + nd = ndpm(nm) + if (nm.eq.2 .and. is_leap_year(ny)) nd = 29 + endif + + if (nd.eq.29 .and. nm.eq.2 .and. is_leap_year(ny)) go to 20 + + if (nd.gt.ndpm(nm)) then + nd = 1 + nm = nm + 1 + if (nm.gt.12) then + nm = 1 + ny = ny + 1 + endif + endif + +20 continue + incymd = ny*10000 + nm*100 + nd + return + + end function compute_incymd + + logical function is_leap_year(year) + integer, intent(in) :: year + is_leap_year = (mod(year,4) == 0) .and. (mod(year,100) == 0 .or. mod(year,400) == 0) + end function is_leap_year + + subroutine usage(root) + logical, intent(in) :: root + integer :: status,errorcode + if(root) then + write(6,100) +100 format( "usage: ",/,/ & + " time_ave.x -hdf filenames (in hdf format)",/ & + " <-template template>" ,/ & + " <-tag tag>" ,/ & + " <-rc rcfile>" ,/ & + " <-ntod ntod>" ,/ & + " <-ntmin ntmin>" ,/ & + " <-strict strict>" ,/ & + " <-d>" ,/ & + " <-md>" ,/,/ & + "where:",/,/ & + " -hdf filenames: filenames (in hdf format) to average",/ & + " -template template: filename to use as template if hdf files differ (default: 1st filename)",/ & + " -begdate yyyymmdd: optional parameter for date to begin averaging",/ & + " -begtime hhmmss: optional parameter for time to begin averaging",/ & + " -enddate yyyymmdd: optional parameter for date to end averaging",/ & + " -endtime hhmmss: optional parameter for time to end averaging",/ & + " -tag tag: optional tag for output file (default: monthly_ave)",/ & + " -rc rcfile: optional resource filename for quadratics (default: no quadratics)",/ & + " -ntod ntod: optional time-of-day (hhmmss) to average (default: all time periods)",/ & + " -ntmin ntmin: optional parameter for required min. timeperiods (default: 10 days equiv)",/ & + " -strict strict: optional logical parameter for strict time testing (default: .true.)",/ & + " -d dtag: optional parameter to create & tag monthly mean diurnal file ", & + "(all times included)",/ & + " -md dtag: optional parameter to create & tag multiple monthly mean diurnal files ", & + "(one time per file)",/ & + " -dv dtag: like -d but includes diurnal variances",/ & + " -mdv dtag: like -md but includes diurnal variances",/ & + ) + endif + call MPI_Abort(MPI_COMM_WORLD,errorcode,status) + end subroutine usage + + subroutine generate_report() + + character(:), allocatable :: report_lines(:) + integer :: i + character(1) :: empty(0) + + reporter = ProfileReporter(empty) + call reporter%add_column(NameColumn(20)) + call reporter%add_column(FormattedTextColumn('Inclusive','(f9.6)', 9, InclusiveColumn('MEAN'))) + call reporter%add_column(FormattedTextColumn('% Incl','(f6.2)', 6, PercentageColumn(InclusiveColumn('MEAN'),'MAX'))) + call reporter%add_column(FormattedTextColumn('Exclusive','(f9.6)', 9, ExclusiveColumn('MEAN'))) + call reporter%add_column(FormattedTextColumn('% Excl','(f6.2)', 6, PercentageColumn(ExclusiveColumn('MEAN')))) + call reporter%add_column(FormattedTextColumn(' Max Excl)','(f9.6)', 9, ExclusiveColumn('MAX'))) + call reporter%add_column(FormattedTextColumn(' Min Excl)','(f9.6)', 9, ExclusiveColumn('MIN'))) + call reporter%add_column(FormattedTextColumn('Max PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MAX_PE'))) + call reporter%add_column(FormattedTextColumn('Min PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MIN_PE'))) + report_lines = reporter%generate_report(t_prof) + if (mapl_am_I_root()) then + write(*,'(a)')'Final profile' + write(*,'(a)')'=============' + do i = 1, size(report_lines) + write(*,'(a)') report_lines(i) + end do + write(*,'(a)') '' + end if + end subroutine generate_report + + +end program time_ave diff --git a/CHANGELOG.md b/CHANGELOG.md index 1b48460d61e4..a2c1c4a755fd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Convert from ABI Fixed Grid to lon/lat coordinates used in MAPL_XYGridFactory (supporting geostationary GOES-R series) - Modify trajectory sampler for a collection with multiple platforms: P3B (air craft) + FIREX - Modify swath sampler to handle two Epoch swath grids - Handle regrid accumulate for time step (1 sec) during which no obs exists From 691fee0e8b4aef0bc6ef6bf6f961af76556e91c1 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 17 Jan 2024 22:22:51 -0700 Subject: [PATCH 54/86] Add Tom's suggestion: if (has_mask) dstMaskValues = [MAPL_MASK_OUT] ! otherwise unallocated --- base/MAPL_EsmfRegridder.F90 | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 78e4dcd1cabd..1c3189fc6c60 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -1431,6 +1431,7 @@ subroutine create_route_handle(this, kind, rc) integer :: srcTermProcessing integer, pointer :: factorIndexList(:,:) + integer, allocatable :: dstMaskValues(:) real(ESMF_KIND_R8), pointer :: factorList(:) type(ESMF_RouteHandle) :: dummy_rh type(ESMF_UnmappedAction_Flag) :: unmappedaction @@ -1494,24 +1495,16 @@ subroutine create_route_handle(this, kind, rc) call ESMF_AttributeGet(spec%grid_in, name='Global',value=global,rc=status) if (.not.global) unmappedaction=ESMF_UNMAPPEDACTION_IGNORE end if + if (has_mask) dstMaskValues = [MAPL_MASK_OUT] ! otherwise unallocated select case (spec%regrid_method) case (REGRID_METHOD_BILINEAR, REGRID_METHOD_BILINEAR_MONOTONIC) - if (has_mask) then - call ESMF_FieldRegridStore(src_field, dst_field, & - & dstMaskValues = [MAPL_MASK_OUT], & - & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & - & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, _RC) - else - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & - & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, _RC) - end if + call ESMF_FieldRegridStore(src_field, dst_field, & + & dstMaskValues = dstMaskValues, & + & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & + & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, _RC) case (REGRID_METHOD_PATCH) _ASSERT(.not.has_mask, "destination masking with this regrid type is unsupported") From c02754d1227d87d2bc6ec5a4e43a526276d7cec3 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 19 Jan 2024 09:38:09 -0500 Subject: [PATCH 55/86] Update field_utils/tests/Test_FieldArithmetic.pf --- field_utils/tests/Test_FieldArithmetic.pf | 2 -- 1 file changed, 2 deletions(-) diff --git a/field_utils/tests/Test_FieldArithmetic.pf b/field_utils/tests/Test_FieldArithmetic.pf index 89a0e72f0aaf..cb21eda11296 100644 --- a/field_utils/tests/Test_FieldArithmetic.pf +++ b/field_utils/tests/Test_FieldArithmetic.pf @@ -62,8 +62,6 @@ contains allocate(y4array, source=R4_ARRAY_DEFAULT) x = mk_r4field(R4_ARRAY_DEFAULT, 'XR4', _RC) y = mk_r4field(y4array, 'YR4', _RC) -! x = mk_r4field(R4_ARRAY_DEFAULT, 'XR4', _RC) -! y = mk_r4field(y4array, 'YR4', _RC) call ESMF_FieldGet(x , farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) From 0a2c11c6a1584288e734c266682ddaecb93d0246 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 19 Jan 2024 11:15:59 -0700 Subject: [PATCH 56/86] Replace global arrays arr_lon(:,:) by using x(:) and y(:) from ABI fixed grid, as analytic function exists for mapping the two --- base/MAPL_Comms.F90 | 25 ++++++ base/MAPL_ObsUtil.F90 | 28 +++---- base/MAPL_XYGridFactory.F90 | 147 ++++++++++++++++-------------------- 3 files changed, 105 insertions(+), 95 deletions(-) diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 4bb204decc3d..58aab4a1f02c 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -115,6 +115,7 @@ module MAPL_CommsMod interface MAPL_BcastShared module procedure MAPL_BcastShared_1DR4 + module procedure MAPL_BcastShared_1DR8 module procedure MAPL_BcastShared_2DI4 module procedure MAPL_BcastShared_2DR4 module procedure MAPL_BcastShared_2DR8 @@ -1087,6 +1088,30 @@ subroutine MAPL_BcastShared_1DR4(VM, Data, N, Root, RootOnly, rc) end subroutine MAPL_BcastShared_1DR4 + subroutine MAPL_BcastShared_1DR8(VM, Data, N, Root, RootOnly, rc) + type(ESMF_VM) :: VM + real(kind=REAL64), pointer, intent(INOUT) :: Data(:) + integer, intent(IN ) :: N + integer, optional, intent(IN ) :: Root + logical, intent(IN ) :: RootOnly + integer, optional, intent( OUT) :: rc + integer :: status + + if(.not.MAPL_ShmInitialized) then + if (RootOnly) then + _RETURN(ESMF_SUCCESS) + end if + call MAPL_CommsBcast(vm, DATA=Data, N=N, ROOT=Root, _RC) + else + call MAPL_SyncSharedMemory(_RC) + call MAPL_BroadcastToNodes(Data, N=N, ROOT=Root, _RC) + call MAPL_SyncSharedMemory(_RC) + endif + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_BcastShared_1DR8 + subroutine MAPL_BcastShared_2DR4(VM, Data, N, Root, RootOnly, rc) type(ESMF_VM) :: VM real, pointer, intent(INOUT) :: Data(:,:) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 94462c50f363..0329e8e16311 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -301,7 +301,7 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & character(len=ESMF_MAXSTR), optional, intent(in) :: var_name_time real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: lon(:,:) real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: lat(:,:) - real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: time(:,:) + real(ESMF_KIND_R8), allocatable, optional, intent(inout) :: time(:,:) logical, optional, intent(in) :: Tfilter integer, optional, intent(out) :: rc @@ -447,7 +447,7 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & deallocate(lat) allocate (lat(Xdim, Ydim)) end if - + jx=0 do i = 1, M filename = filenames(i) @@ -741,8 +741,8 @@ subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, mask) integer, optional, intent(out):: mask real(REAL64) :: a0, b0, c0, rs, Sx, Sy, Sz, t real(REAL64) :: a, b, H - real(REAL64) :: delta - + real(REAL64) :: delta + a=r_eq; b=r_pol; H=H_sat if (present(mask)) mask=0 @@ -751,10 +751,9 @@ subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, mask) c0 = H*H - a*a delta = b0*b0 - 4.d0*a0*c0 if (delta < 0.d0) then - ! lon = -999.d0 - ! lat = -999.d0 lon = MAPL_UNDEF - lat = MAPL_UNDEF + lat = MAPL_UNDEF + if (present(mask)) mask=0 return end if rs = ( -b0 - sqrt(b0*b0 - 4.d0*a0*c0) ) / (2.d0*a0) @@ -775,7 +774,7 @@ subroutine ABI_XY_2_lonlat (x, y, lambda0, lon, lat, mask) end subroutine ABI_XY_2_lonlat - + subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, mask) implicit none real(REAL64), intent(in) :: lon, lat @@ -786,7 +785,7 @@ subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, mask) real(REAL64) :: e2, rc, Sx, Sy, Sz, t real(REAL64) :: a, b, H real*8 :: delta - + a=r_eq; b=r_pol; H=H_sat theta_c = atan( (b/a)**2.d0 * tan(lat) ) @@ -806,17 +805,20 @@ subroutine lonlat_2_ABI_XY (lon, lat, lambda0, x, y, mask) end if end subroutine lonlat_2_ABI_XY - + subroutine test_conversion implicit none - real*8 :: x0 = -0.024052d0 - real*8 :: y0 = 0.095340d0 + real*8 :: x0 + real*8 :: y0 real*8 :: lam, the real*8 :: lon, lat integer :: mask real*8 :: xnew, ynew + ! two points mapping: (x0, y0) <--> (lam, the) + x0 = -0.024052d0 + y0 = 0.095340d0 lam = -1.478135612d0 the = 0.590726971d0 @@ -838,6 +840,6 @@ subroutine test_conversion 111 format (2x, a,20(2x,f25.11)) 121 format (2x, a,10(2x,i8)) - end subroutine test_conversion + end subroutine test_conversion end module MAPL_ObsUtilMod diff --git a/base/MAPL_XYGridFactory.F90 b/base/MAPL_XYGridFactory.F90 index 9f01fe6ba296..1bcbc57ea3ce 100644 --- a/base/MAPL_XYGridFactory.F90 +++ b/base/MAPL_XYGridFactory.F90 @@ -15,7 +15,7 @@ module MAPL_XYGridFactoryMod use NetCDF ! use Plain_netCDF_Time, only : get_ncfile_dimension use Plain_netCDF_Time - use MAPL_ObsUtilMod, only : ABI_XY_2_lonlat, test_conversion + use MAPL_ObsUtilMod, only : ABI_XY_2_lonlat use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -47,7 +47,7 @@ module MAPL_XYGridFactoryMod character(len=ESMF_MAXSTR) :: var_name_x character(len=ESMF_MAXSTR) :: var_name_y character(len=ESMF_MAXSTR) :: var_name_proj - character(len=ESMF_MAXSTR) :: att_name_proj + character(len=ESMF_MAXSTR) :: att_name_proj integer :: xdim_true integer :: ydim_true @@ -56,7 +56,7 @@ module MAPL_XYGridFactoryMod procedure :: make_new_grid procedure :: create_basic_grid procedure :: add_horz_coordinates_from_file - procedure :: add_horz_coordinates_from_ABIfile + procedure :: add_horz_coordinates_from_ABIfile procedure :: init_halo procedure :: halo @@ -151,7 +151,7 @@ function make_new_grid(this, unusable, rc) result(grid) if ( index(trim(adjustl(this%grid_name)), 'ABI') == 0 ) then call this%add_horz_coordinates_from_file(grid, _RC) else - call this%add_horz_coordinates_from_ABIfile(grid, _RC) + call this%add_horz_coordinates_from_ABIfile(grid, _RC) end if call this%add_mask(grid,_RC) @@ -348,10 +348,9 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) _RETURN(_SUCCESS) end subroutine add_horz_coordinates_from_file - + subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) - use MAPL_BaseMod, only: MAPL_grid_interior, MAPL_gridget use MAPL_CommsMod use MAPL_IOMod use MAPL_Constants @@ -361,90 +360,74 @@ subroutine add_horz_coordinates_from_ABIfile(this, grid, unusable, rc) integer, optional, intent(out) :: rc integer :: status - integer :: i_1,i_n,j_1,j_n, ncid, varid + type(ESMF_VM) :: vm integer :: i, j - real(REAL64), pointer :: arr_lon(:,:) - real(REAL64), pointer :: arr_lat(:,:) - real(REAL64), allocatable :: x(:) - real(REAL64), allocatable :: y(:) - real(REAL64) :: lambda0_deg, lambda0 - real(REAL64) :: x0, y0, lon, lat - integer :: outRange - - real(ESMF_KIND_R8), pointer :: fptr(:,:) - - integer :: COUNTS(3), DIMS(3) - integer :: Xdim, Ydim, npoints - character(len=:), allocatable :: lon_center_name, lat_center_name, lon_corner_name, lat_corner_name - character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att, unit + integer :: ix, jx + integer :: i_1, i_n, j_1, j_n + real(REAL64), pointer :: fptr_x(:,:) ! lon + real(REAL64), pointer :: fptr_y(:,:) ! lat + real(REAL64), pointer :: x(:) + real(REAL64), pointer :: y(:) + real(REAL64), pointer :: lambda0(:) + real(REAL64) :: lambda0_deg + real(REAL64) :: x0, y0 + real(REAL64) :: lam_sat + character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att - type(ESMF_VM) :: vm _UNUSED_DUMMY(unusable) - lon_center_name = this%var_name_x - lat_center_name = this%var_name_y - - call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, _RC) - Xdim = DIMS(1) - Ydim = DIMS(2) - npoints = Xdim * Ydim - - call MAPL_Grid_Interior(grid, i_1, i_n, j_1, j_n) - call MAPL_AllocateShared(arr_lon,[Xdim, Ydim],transroot=.true.,_RC) - call MAPL_AllocateShared(arr_lat,[Xdim, Ydim],transroot=.true.,_RC) - call MAPL_SyncSharedMemory(_RC) - - fn = this%grid_file_name - key_x = this%var_name_x - key_y = this%var_name_y - key_p = this%var_name_proj - key_p_att = this%att_name_proj - if (mapl_am_i_root()) then - allocate (x(this%Xdim_true)) - allocate (y(this%Ydim_true)) - call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) - call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) - call get_att_real_netcdf(fn, key_p, key_p_att, lambda0_deg, _RC) - lambda0=lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 - !write(6, 101) 'x=', x(::100) - !write(6, 101) 'y=', y(::100) - !write(6, 101) 'lambda0=', lambda0 - - do i = 1, Xdim - do j= 1, Ydim - x0 = x( i * this%thin_factor ) - y0 = y( j * this%thin_factor ) - call ABI_XY_2_lonlat (x0, y0, lambda0, arr_lon(i,j), arr_lat(i,j)) - end do - end do - end if - call MAPL_SyncSharedMemory(_RC) + call MAPL_Grid_Interior (grid, i_1, i_n, j_1, j_n) + call MAPL_AllocateShared(x,[this%Xdim_true],transroot=.true.,_RC) + call MAPL_AllocateShared(y,[this%Ydim_true],transroot=.true.,_RC) + call MAPL_AllocateShared(lambda0,[1],transroot=.true.,_RC) + call MAPL_SyncSharedMemory(_RC) - call ESMF_VMGetCurrent(vm, _RC) - call MAPL_BcastShared (vm, data=arr_lon, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) - call MAPL_BcastShared (vm, data=arr_lat, N=npoints, Root=MAPL_ROOT, RootOnly=.false., _RC) - - call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) - fptr = arr_lon(i_1:i_n,j_1:j_n) + if (mapl_am_i_root()) then + fn = this%grid_file_name + key_x = this%var_name_x + key_y = this%var_name_y + key_p = this%var_name_proj + key_p_att = this%att_name_proj + call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) + call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) + call get_att_real_netcdf (fn, key_p, key_p_att, lambda0_deg, _RC) + lambda0 = lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + end if call MAPL_SyncSharedMemory(_RC) + call ESMF_VMGetCurrent(vm, _RC) + call MAPL_BcastShared (vm, data=x, N=this%Xdim_true, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (vm, data=y, N=this%Ydim_true, Root=MAPL_ROOT, RootOnly=.false., _RC) + call MAPL_BcastShared (vm, data=lambda0, N=1, Root=MAPL_ROOT, RootOnly=.false., _RC) + + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr_x, _RC) call ESMF_GridGetCoord(grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr, _RC) - fptr = arr_lat(i_1:i_n,j_1:j_n) + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=fptr_y, _RC) + lam_sat = lambda0(1) + do i = i_1, i_n + ix = i - i_1 + 1 + do j= j_1, j_n + jx = j - j_1 + 1 + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) + call ABI_XY_2_lonlat (x0, y0, lam_sat, fptr_x(ix, jx), fptr_y(ix, jx) ) + end do + end do + call MAPL_SyncSharedMemory(_RC) if(MAPL_ShmInitialized) then - call MAPL_DeAllocNodeArray(arr_lon,_RC) - call MAPL_DeAllocNodeArray(arr_lat,_RC) + call MAPL_DeAllocNodeArray(x,_RC) + call MAPL_DeAllocNodeArray(y,_RC) else - deallocate(arr_lon) - deallocate(arr_lat) + deallocate(x) + deallocate(y) end if - - _RETURN(_SUCCESS) + + _RETURN(_SUCCESS) end subroutine add_horz_coordinates_from_ABIfile - + subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_file_coordinates, rc) use MAPL_KeywordEnforcerMod @@ -500,7 +483,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc integer :: n1, n2 integer :: arr(2) type(ESMF_VM) :: vm - + if (present(unusable)) print*,shape(unusable) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'GRIDNAME:', default=MAPL_GRID_NAME_DEFAULT, _RC) @@ -518,7 +501,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%var_name_y, label=prefix//'var_name_y:', default="y", _RC) call ESMF_ConfigGetAttribute(config, this%var_name_proj,label=prefix//'var_name_proj:',default="", _RC) call ESMF_ConfigGetAttribute(config, this%att_name_proj,label=prefix//'att_name_proj:',default="", _RC) - call ESMF_ConfigGetAttribute(config, this%thin_factor, label=prefix//'thin_factor:', default=1, _RC) + call ESMF_ConfigGetAttribute(config, this%thin_factor, label=prefix//'thin_factor:', default=1, _RC) if (mapl_am_i_root()) then call get_ncfile_dimension(this%grid_file_name, nlon=n1, nlat=n2, & @@ -535,7 +518,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%ydim_true = arr(2) this%im_world = arr(1) / this%thin_factor this%jm_world = arr(2) / this%thin_factor - + call this%check_and_fill_consistency(rc=status) _RETURN(_SUCCESS) @@ -1030,7 +1013,7 @@ subroutine add_mask(this,grid,rc) integer(ESMF_KIND_I4), pointer :: mask(:,:) real(ESMF_KIND_R8), pointer :: fptr(:,:) - integer :: i,j,status + integer :: status type(ESMF_VM) :: vm integer :: has_undef, local_has_undef @@ -1044,8 +1027,8 @@ subroutine add_mask(this,grid,rc) if (any(fptr == MAPL_UNDEF)) local_has_undef = local_has_undef + 1 call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) - _RETURN_IF(has_undef == 0) + call ESMF_VMAllFullReduce(vm, [local_has_undef], has_undef, 1, ESMF_REDUCE_MAX, _RC) + _RETURN_IF(has_undef == 0) call ESMF_GridAddItem(grid,staggerLoc=ESMF_STAGGERLOC_CENTER,itemflag=ESMF_GRIDITEM_MASK,_RC) call ESMF_GridGetItem(grid,localDE=0,staggerLoc=ESMF_STAGGERLOC_CENTER, & From 8670dcf051124359d0c4c1a8ed1439c2291640ba Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 19 Jan 2024 12:00:29 -0700 Subject: [PATCH 57/86] _RC change --- shared/Shmem/Shmem_implementation.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/shared/Shmem/Shmem_implementation.F90 b/shared/Shmem/Shmem_implementation.F90 index fdda07755951..e8ca038a2a2e 100644 --- a/shared/Shmem/Shmem_implementation.F90 +++ b/shared/Shmem/Shmem_implementation.F90 @@ -797,13 +797,9 @@ end subroutine perror end procedure MAPL_AllocateShared_1DR8 module procedure MAPL_AllocateShared_2DI4 - - integer :: status - if(MAPL_ShmInitialized) then - call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS) - _VERIFY(STATUS) + call MAPL_AllocNodeArray(Ptr, Shp, lbd, _RC) else if (TransRoot) then allocate(Ptr(Shp(1),Shp(2)),stat=status) From 1a7f9e8b68a70871641e8aab8914011e15ec4242 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 22 Jan 2024 08:21:30 -0500 Subject: [PATCH 58/86] Fix bad merge --- gridcomps/History/MAPL_HistoryTrajectoryMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 3e90859c9f8a..060e33756aee 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -95,7 +95,7 @@ module function HistoryTrajectory_from_config(config,string,clock,rc) result(tra integer, optional, intent(out) :: rc end function HistoryTrajectory_from_config - module subroutine initialize_(this,items,bundle,timeInfo,vdata,recycle_track,rc) + module subroutine initialize_(this,items,bundle,timeInfo,vdata,reinitialize,rc) class(HistoryTrajectory), intent(inout) :: this type(GriddedIOitemVector), optional, intent(inout) :: items type(ESMF_FieldBundle), optional, intent(inout) :: bundle From d71b7cdb8deb01105f7505a95beb1833ed4884ab Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 22 Jan 2024 10:14:20 -0500 Subject: [PATCH 59/86] One more merge fix --- gridcomps/History/MAPL_HistoryTrajectoryMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 060e33756aee..9efd6ca1ac25 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -69,7 +69,6 @@ module HistoryTrajectoryMod logical :: active contains procedure :: initialize => initialize_ - procedure :: reinitialize procedure :: create_variable => create_metadata_variable procedure :: create_file_handle procedure :: close_file_handle From cfd8bc827c635a5185140f823a4bab9fb03d8579 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Thu, 25 Jan 2024 23:50:46 +0000 Subject: [PATCH 60/86] Bump styfle/cancel-workflow-action from 0.12.0 to 0.12.1 Bumps [styfle/cancel-workflow-action](https://github.com/styfle/cancel-workflow-action) from 0.12.0 to 0.12.1. - [Release notes](https://github.com/styfle/cancel-workflow-action/releases) - [Commits](https://github.com/styfle/cancel-workflow-action/compare/0.12.0...0.12.1) --- updated-dependencies: - dependency-name: styfle/cancel-workflow-action dependency-type: direct:production update-type: version-update:semver-patch ... Signed-off-by: dependabot[bot] --- .github/workflows/workflow.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index e9b958ef566d..4a360a7d2b51 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -30,7 +30,7 @@ jobs: OMPI_MCA_btl_vader_single_copy_mechanism: none steps: - name: Cancel Previous Runs - uses: styfle/cancel-workflow-action@0.12.0 + uses: styfle/cancel-workflow-action@0.12.1 with: access_token: ${{ github.token }} - name: Checkout @@ -86,7 +86,7 @@ jobs: #password: ${{ secrets.DOCKERHUB_TOKEN }} steps: - name: Cancel Previous Runs - uses: styfle/cancel-workflow-action@0.12.0 + uses: styfle/cancel-workflow-action@0.12.1 with: access_token: ${{ github.token }} - name: Checkout From 6b6707dc7a159f1d86a1e0e9fce665eeed1b4a67 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 26 Jan 2024 10:52:53 -0500 Subject: [PATCH 61/86] Fixes #2553. Detect mpiuni builds of ESMF --- CHANGELOG.md | 4 ++-- gridcomps/Cap/MAPL_Cap.F90 | 7 +++++++ 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a1c8b8d7391b..4586f6066459 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added + - Convert from ABI Fixed Grid to lon/lat coordinates used in MAPL_XYGridFactory (supporting geostationary GOES-R series) - Modify trajectory sampler for a collection with multiple platforms: P3B (air craft) + FIREX - Modify swath sampler to handle two Epoch swath grids @@ -16,8 +17,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - parse "GOCART::CO2" from 'geovals_fields' entry in PLATFORM - Add call MAPL_InitializeShmem to ExtDataDriverGridComp.F90 - Read swath data on root, call MAPL_CommsBcast [which sends data to Shmem (when Shmem initialized) or to MAPL_comm otherwise]. This approach avoids race in reading nc files [e.g. 37 files for 3 hr swath data] - - - Added memory utility, MAPL_MemReport that can be used in any code linking MAPL - Added capability in XY grid factory to add a mask to the grid any points are missing needed for geostationary input data - Added capability in the MAPL ESMF regridding wrapper to apply a destination mask if the destination grid contains a mask @@ -41,6 +40,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Explictly `use` some `iso_c_binding` types previously pulled in through ESMF. This is fixed in future ESMF versions (8.7+) and so we anticipate this here - Add explicit `Fortran_MODULE_DIRECTORY` to `CMakeLists.txt` in benchmarks to avoid race condition in Ninja builds +- Add check to make sure ESMF was not built as `mpiuni` ### Removed diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 3b23c8a5c92d..00640e024c4b 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -275,6 +275,8 @@ subroutine run_model(this, comm, unusable, rc) integer :: status class(Logger), pointer :: lgr logical :: file_exists + type (ESMF_VM) :: VM + character(len=:), allocatable :: esmfComm _UNUSED_DUMMY(unusable) @@ -298,6 +300,11 @@ subroutine run_model(this, comm, unusable, rc) call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, _RC) end if + ! We check to see if ESMF_COMM was built as mpiuni which is not allowed for MAPL + call ESMF_VmGetCurrent(VM, _RC) + call ESMF_VmGet(VM, esmfComm = esmfComm, _RC) + _ASSERT( esmfComm /= 'mpiuni', 'ESMF_COMM=mpiuni is not allowed for MAPL') + ! Note per ESMF this is a temporary routine as eventually MOAB will ! be the only mesh generator. But until then, this allows us to ! test it From 401eb47bd8b2b155058d4abbb7c0c2e036b5af9b Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 26 Jan 2024 13:16:57 -0500 Subject: [PATCH 62/86] Use ESMF_Initialize to get the vm --- gridcomps/Cap/MAPL_Cap.F90 | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 00640e024c4b..007d857d6da0 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -275,7 +275,7 @@ subroutine run_model(this, comm, unusable, rc) integer :: status class(Logger), pointer :: lgr logical :: file_exists - type (ESMF_VM) :: VM + type (ESMF_VM) :: vm character(len=:), allocatable :: esmfComm _UNUSED_DUMMY(unusable) @@ -295,14 +295,13 @@ subroutine run_model(this, comm, unusable, rc) ! If the file exists, we pass it into ESMF_Initialize, else, we ! use the one from the command line arguments if (file_exists) then - call ESMF_Initialize (configFileName='ESMF.rc', mpiCommunicator=comm, _RC) + call ESMF_Initialize (configFileName='ESMF.rc', mpiCommunicator=comm, vm=vm, _RC) else - call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, _RC) + call ESMF_Initialize (logKindFlag=this%cap_options%esmf_logging_mode, mpiCommunicator=comm, vm=vm, _RC) end if ! We check to see if ESMF_COMM was built as mpiuni which is not allowed for MAPL - call ESMF_VmGetCurrent(VM, _RC) - call ESMF_VmGet(VM, esmfComm = esmfComm, _RC) + call ESMF_VmGet(vm, esmfComm = esmfComm, _RC) _ASSERT( esmfComm /= 'mpiuni', 'ESMF_COMM=mpiuni is not allowed for MAPL') ! Note per ESMF this is a temporary routine as eventually MOAB will From f7a1aa49dc39403f34f8de6504e9c507a5ed54ea Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 1 Feb 2024 15:22:38 -0500 Subject: [PATCH 63/86] Update CMakeBuildPresets for NCCS --- CHANGELOG.md | 4 ++++ CMakePresets.json | 37 +++++++++++++++++++++++++++++++------ 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 338d1e9cfe76..372ca8811bf3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -33,6 +33,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 now required), NAG no longer needs this workaround. - Refactor the CircleCI workflows for more flexibility - Fix field utils issue - add npes argument to test subroutine decorators. +- Changed `CMakePresets.json` + - Updated to version 6 and required CMake 3.26.0 + - Changed build style on NCCS machines to by default put build and install directories in a user-specified directory so as not to + pollute swdev ### Fixed diff --git a/CMakePresets.json b/CMakePresets.json index 77d1727caecd..e3b70c28bc7c 100644 --- a/CMakePresets.json +++ b/CMakePresets.json @@ -1,22 +1,47 @@ { - "version": 3, + "version": 6, "cmakeMinimumRequired": { "major": 3, - "minor": 21, + "minor": 26, "patch": 0 }, "configurePresets": [ { - "name": "base-configure", + "name": "base-configure-nccs", + "hidden": true, + "displayName": "Base Configure Settings", + "description": "Sets build and install directories", + "binaryDir": "$penv{CMAKE_BUILD_LOCATIONS}/${sourceDirName}/build-${presetName}", + "installDir": "$penv{CMAKE_INSTALL_LOCATIONS}/${sourceDirName}/install-${presetName}", + "condition": { + "type": "equals", + "lhs": "$penv{CMAKE_SITE_NAME}", + "rhs": "NCCS" + } + }, + { + "name": "base-configure-default", "hidden": true, "displayName": "Base Configure Settings", "description": "Sets build and install directories", "binaryDir": "${sourceDir}/build-${presetName}", - "cacheVariables": { - "BASEDIR": "$env{BASEDIR}", - "CMAKE_INSTALL_PREFIX": "${sourceDir}/install-${presetName}" + "installDir": "${sourceDir}/install-${presetName}", + "condition": { + "type": "notEquals", + "lhs": "$penv{CMAKE_SITE_NAME}", + "rhs": "NCCS" } }, + { + "name": "base-configure", + "hidden": true, + "inherits": [ + "base-configure-nccs", + "base-configure-default" + ], + "displayName": "Base Configure Settings", + "description": "Sets build and install directories" + }, { "name": "base-gnu", "hidden": true, From 531fcb0a8301c0fabd78460c89ebdeaabfb2984e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 1 Feb 2024 15:45:53 -0500 Subject: [PATCH 64/86] Clean up --- CMakePresets.json | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/CMakePresets.json b/CMakePresets.json index e3b70c28bc7c..90adf17d6c78 100644 --- a/CMakePresets.json +++ b/CMakePresets.json @@ -13,11 +13,7 @@ "description": "Sets build and install directories", "binaryDir": "$penv{CMAKE_BUILD_LOCATIONS}/${sourceDirName}/build-${presetName}", "installDir": "$penv{CMAKE_INSTALL_LOCATIONS}/${sourceDirName}/install-${presetName}", - "condition": { - "type": "equals", - "lhs": "$penv{CMAKE_SITE_NAME}", - "rhs": "NCCS" - } + "condition": { "lhs": "$penv{CMAKE_SITE_NAME}", "type": "equals", "rhs": "NCCS" } }, { "name": "base-configure-default", @@ -26,12 +22,7 @@ "description": "Sets build and install directories", "binaryDir": "${sourceDir}/build-${presetName}", "installDir": "${sourceDir}/install-${presetName}", - "condition": { - "type": "notEquals", - "lhs": "$penv{CMAKE_SITE_NAME}", - "rhs": "NCCS" - } - }, + "condition": { "lhs": "$penv{CMAKE_SITE_NAME}", "type": "notEquals", "rhs": "NCCS" } }, { "name": "base-configure", "hidden": true, From 0ee7a08fee70481ee30804918a4470a20c534b6f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 2 Feb 2024 10:28:00 -0500 Subject: [PATCH 65/86] Use includes to workaround CMake issues --- CMakePresets.json | 34 +++++--------------------------- presets/CMakeDefaultPresets.json | 13 ++++++++++++ presets/CMakeNCCSPresets.json | 13 ++++++++++++ 3 files changed, 31 insertions(+), 29 deletions(-) create mode 100644 presets/CMakeDefaultPresets.json create mode 100644 presets/CMakeNCCSPresets.json diff --git a/CMakePresets.json b/CMakePresets.json index 90adf17d6c78..f9b9a129573b 100644 --- a/CMakePresets.json +++ b/CMakePresets.json @@ -1,38 +1,14 @@ { - "version": 6, + "version": 7, "cmakeMinimumRequired": { "major": 3, - "minor": 26, + "minor": 27, "patch": 0 }, + "include": [ + "presets/CMake$penv{CMAKE_SITE_NAME}Presets.json" + ], "configurePresets": [ - { - "name": "base-configure-nccs", - "hidden": true, - "displayName": "Base Configure Settings", - "description": "Sets build and install directories", - "binaryDir": "$penv{CMAKE_BUILD_LOCATIONS}/${sourceDirName}/build-${presetName}", - "installDir": "$penv{CMAKE_INSTALL_LOCATIONS}/${sourceDirName}/install-${presetName}", - "condition": { "lhs": "$penv{CMAKE_SITE_NAME}", "type": "equals", "rhs": "NCCS" } - }, - { - "name": "base-configure-default", - "hidden": true, - "displayName": "Base Configure Settings", - "description": "Sets build and install directories", - "binaryDir": "${sourceDir}/build-${presetName}", - "installDir": "${sourceDir}/install-${presetName}", - "condition": { "lhs": "$penv{CMAKE_SITE_NAME}", "type": "notEquals", "rhs": "NCCS" } }, - { - "name": "base-configure", - "hidden": true, - "inherits": [ - "base-configure-nccs", - "base-configure-default" - ], - "displayName": "Base Configure Settings", - "description": "Sets build and install directories" - }, { "name": "base-gnu", "hidden": true, diff --git a/presets/CMakeDefaultPresets.json b/presets/CMakeDefaultPresets.json new file mode 100644 index 000000000000..3dbaf9e755c0 --- /dev/null +++ b/presets/CMakeDefaultPresets.json @@ -0,0 +1,13 @@ +{ + "configurePresets": [ + { + "name": "base-configure", + "hidden": true, + "displayName": "Base Configure Settings", + "description": "Sets build and install directories", + "binaryDir": "${sourceDir}/build-${presetName}", + "installDir": "${sourceDir}/install-${presetName}" + } + ], + "version": 7 +} diff --git a/presets/CMakeNCCSPresets.json b/presets/CMakeNCCSPresets.json new file mode 100644 index 000000000000..730b13432fd0 --- /dev/null +++ b/presets/CMakeNCCSPresets.json @@ -0,0 +1,13 @@ +{ + "configurePresets": [ + { + "name": "base-configure", + "hidden": true, + "displayName": "Base Configure Settings", + "description": "Sets build and install directories", + "binaryDir": "$penv{CMAKE_BUILD_LOCATION}/${sourceDirName}/build-${presetName}", + "installDir": "$penv{CMAKE_INSTALL_LOCATION}/${sourceDirName}/install-${presetName}", + } + ], + "version": 7 +} From 15f658836a3bb0b924bd577c830950e972f4559f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 2 Feb 2024 10:57:35 -0500 Subject: [PATCH 66/86] Use CMAKE_PRESET_NAME --- CMakePresets.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakePresets.json b/CMakePresets.json index f9b9a129573b..60c99f0d9d00 100644 --- a/CMakePresets.json +++ b/CMakePresets.json @@ -6,7 +6,7 @@ "patch": 0 }, "include": [ - "presets/CMake$penv{CMAKE_SITE_NAME}Presets.json" + "presets/CMake$penv{CMAKE_PRESET_NAME}Presets.json" ], "configurePresets": [ { From 16908022e0bc0d0766b55127910887bcab2da529 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 2 Feb 2024 12:58:05 -0500 Subject: [PATCH 67/86] Fix up changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 372ca8811bf3..05718efc4a34 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -34,7 +34,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Refactor the CircleCI workflows for more flexibility - Fix field utils issue - add npes argument to test subroutine decorators. - Changed `CMakePresets.json` - - Updated to version 6 and required CMake 3.26.0 + - Updated to version 7 and required CMake 3.27.0 (the minimum version that supports CMakePresets.json v7) - Changed build style on NCCS machines to by default put build and install directories in a user-specified directory so as not to pollute swdev From 368eeb2663609e1eae96f1a94756ee039652e6f9 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 2 Feb 2024 14:50:30 -0500 Subject: [PATCH 68/86] added interface to read and write 1d string --- CHANGELOG.md | 1 + pfio/CMakeLists.txt | 2 +- pfio/NetCDF4_FileFormatter.F90 | 29 +++++-- pfio/NetCDF4_get_var.H | 10 +++ pfio/NetCDF4_put_var.H | 11 ++- pfio/NetCDF_Supplement.F90 | 109 +++++++++++++++++++++++++ pfio/pfio_get_att_string.c | 51 ------------ pfio/pfio_nf90_supplement.c | 142 +++++++++++++++++++++++++++++++++ 8 files changed, 295 insertions(+), 60 deletions(-) delete mode 100644 pfio/pfio_get_att_string.c create mode 100644 pfio/pfio_nf90_supplement.c diff --git a/CHANGELOG.md b/CHANGELOG.md index 338d1e9cfe76..7f5dd8c4a589 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added nf90 interface to read and write 1d string - Convert from ABI Fixed Grid to lon/lat coordinates used in MAPL_XYGridFactory (supporting geostationary GOES-R series) - Modify trajectory sampler for a collection with multiple platforms: P3B (air craft) + FIREX - Modify swath sampler to handle two Epoch swath grids diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 6af1d06b6d7d..f85647b4a163 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -21,7 +21,7 @@ set (srcs FileMetadata.F90 FileMetadataVector.F90 NetCDF4_FileFormatter.F90 - pfio_get_att_string.c + pfio_nf90_supplement.c NetCDF_Supplement.F90 pFIO_Utilities.F90 pFIO.F90 diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index 7a16331ada8e..dacf59b5f6e8 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -43,7 +43,6 @@ module pFIO_NetCDF4_FileFormatterMod #include "new_overload.macro" - procedure :: ___SUB(get_var,string,0) procedure :: ___SUB(get_var,string,1) procedure :: ___SUB(get_var,int32,0) @@ -67,7 +66,6 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(get_var,real64,3) procedure :: ___SUB(get_var,real64,4) - procedure :: ___SUB(put_var,string,0) procedure :: ___SUB(put_var,string,1) procedure :: ___SUB(put_var,int32,0) procedure :: ___SUB(put_var,int32,1) @@ -91,7 +89,6 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(put_var,real64,4) - generic :: get_var => ___SUB(get_var,string,0) generic :: get_var => ___SUB(get_var,string,1) generic :: get_var => ___SUB(get_var,int32,0) generic :: get_var => ___SUB(get_var,int32,1) @@ -114,7 +111,6 @@ module pFIO_NetCDF4_FileFormatterMod generic :: get_var => ___SUB(get_var,real64,3) generic :: get_var => ___SUB(get_var,real64,4) - generic :: put_var => ___SUB(put_var,string,0) generic :: put_var => ___SUB(put_var,string,1) generic :: put_var => ___SUB(put_var,int32,0) generic :: put_var => ___SUB(put_var,int32,1) @@ -139,6 +135,7 @@ module pFIO_NetCDF4_FileFormatterMod #include "undo_overload.macro" + procedure :: inq_var_string_length procedure, private :: def_dimensions procedure, private :: put_attributes procedure, private :: put_var_attributes @@ -751,9 +748,12 @@ subroutine def_variables(this, cf, unusable, varname, rc) status = nf90_def_var(this%ncid, var_name, xtype, dimids, varid) !$omp end critical _VERIFY(status) - !$omp critical - status = nf90_def_var_fill(this%ncid, varid, NF90_NOFILL, 0) - !$omp end critical + ! There is no nf90 interface for string. skip the fill + if (xtype /=12) then + !$omp critical + status = nf90_def_var_fill(this%ncid, varid, NF90_NOFILL, 0) + !$omp end critical + endif _VERIFY(status) chunksizes => var%get_chunksizes() if (size(chunksizes) > 0) then @@ -1092,6 +1092,21 @@ subroutine inq_var_attributes(this, var, varid, unusable, rc) _UNUSED_DUMMY(unusable) end subroutine inq_var_attributes + subroutine inq_var_string_length(this, var_name, length, unusable, rc) + class (NetCDF4_FileFormatter), intent(inout) :: this + character(*), intent(in) :: var_name + integer, intent(out) :: length + class (KeywordEnforcer), optional, intent(in):: unusable + integer, optional, intent(out) :: rc + + integer :: varid, status + + status = nf90_inq_varid(this%ncid, name=var_name, varid=varid) + _VERIFY(status) + status = pfio_nf90_get_var_string_len(this%ncid, varid, length) + _VERIFY(status) + _RETURN(_SUCCESS) + end subroutine inq_var_string_length subroutine inq_variables(this, cf, unusable, rc) class (NetCDF4_FileFormatter), intent(inout) :: this diff --git a/pfio/NetCDF4_get_var.H b/pfio/NetCDF4_get_var.H index 874d3d5c8671..48f252828027 100644 --- a/pfio/NetCDF4_get_var.H +++ b/pfio/NetCDF4_get_var.H @@ -36,10 +36,20 @@ _ASSERT(status==0,"Variable not found: "//trim(var_name)//" in file: "//trim(this%origin_file)) !$omp critical +#if (_VARTYPE == 0) + +#if (_RANK == 1) + ! only support rank 1 of string + status = pfio_nf90_get_var_string(ncid, varid, values, start, count) +#endif + +#else + #if (_RANK == 0) status = nf90_get_var(ncid, varid, values) #else status = nf90_get_var(ncid, varid, values, start, count) +#endif #endif !$omp end critical _ASSERT(status==0,"Unable to get variable: "//trim(var_name)//" from file: "//trim(this%origin_file)) diff --git a/pfio/NetCDF4_put_var.H b/pfio/NetCDF4_put_var.H index 6a43e824c406..1c5a2eb52f46 100644 --- a/pfio/NetCDF4_put_var.H +++ b/pfio/NetCDF4_put_var.H @@ -22,16 +22,25 @@ integer :: status integer :: varid - !$omp critical status = nf90_inq_varid(this%ncid, name=var_name, varid=varid) !$omp end critical _VERIFY(status) !$omp critical +#if (_VARTYPE == 0) + +#if (_RANK == 1) + ! only support 1d string + status = pfio_nf90_put_var_string(this%ncid, varid, values, start, count) +#endif + +#else + #if (_RANK == 0) status = nf90_put_var(this%ncid, varid, values) #else status = nf90_put_var(this%ncid, varid, values, start, count) +#endif #endif !$omp end critical _VERIFY(status) diff --git a/pfio/NetCDF_Supplement.F90 b/pfio/NetCDF_Supplement.F90 index cb406f9d04fc..699b274d50a2 100644 --- a/pfio/NetCDF_Supplement.F90 +++ b/pfio/NetCDF_Supplement.F90 @@ -7,6 +7,10 @@ module pfio_NetCDF_Supplement private public :: pfio_get_att_string + public :: pfio_nf90_put_var_string + public :: pfio_nf90_get_var_string + public :: pfio_nf90_get_var_string_len + interface function c_f_pfio_get_att_string(ncid, varid, name, string, attlen) & & result(stat) bind(C, name='pfio_get_att_string') @@ -19,6 +23,44 @@ function c_f_pfio_get_att_string(ncid, varid, name, string, attlen) & character(kind=C_CHAR), intent(inout) :: string(*) integer(kind=C_INT), intent(inout) :: attlen end function c_f_pfio_get_att_string + + function c_f_pfio_get_var_string_len(ncid, varid, str_len_ptr, size) & + & result(stat) bind(C, name='pfio_get_var_string_len') + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + integer(kind=C_INT), value, intent(in) :: ncid + integer(kind=C_INT), value, intent(in) :: varid + type(c_ptr), value, intent(in) :: str_len_ptr + integer(kind=C_INT), value, intent(in) :: size + end function c_f_pfio_get_var_string_len + + function c_f_pfio_get_var_string(ncid, varid, string_ptr, start_ptr, count_ptr) & + & result(stat) bind(C, name='pfio_get_var_string') + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + integer(kind=C_INT), value, intent(in) :: ncid + integer(kind=C_INT), value, intent(in) :: varid + type(c_ptr), intent(in), value :: string_ptr + type(c_ptr), intent(in), value :: start_ptr + type(c_ptr), intent(in), value :: count_ptr + end function c_f_pfio_get_var_string + + function c_f_pfio_put_var_string(ncid, varid, string_ptr, str_len, str_size, start_ptr, count_ptr) & + & result(stat) bind(C, name='pfio_put_var_string') + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + integer(kind=C_INT), value, intent(in) :: ncid + integer(kind=C_INT), value, intent(in) :: varid + type(c_ptr), intent(in), value :: string_ptr + integer(kind=C_INT), value, intent(in) :: str_len + integer(kind=C_INT), value, intent(in) :: str_size + type(c_ptr), intent(in), value :: start_ptr + type(c_ptr), intent(in), value :: count_ptr + end function c_f_pfio_put_var_string + end interface contains @@ -48,4 +90,71 @@ function pfio_get_att_string(ncid, varid, name, string) result(status) deallocate(c_name) end function pfio_get_att_string + function pfio_nf90_get_var_string(ncid, varid, string, start, count) result(status) + integer :: status + integer(kind=C_INT), intent(in) :: ncid + integer(kind=C_INT), intent(in) :: varid + character(*), target,intent(inout):: string(:) + integer, optional, intent(in) :: start(:) + integer, optional, intent(in) :: count(:) + integer, target, allocatable :: start_(:), count_(:) + integer :: str_len, str_size + + str_len = len(string(1)) + str_size = size(string) + if (.not. present(start) .or. .not. present(count)) then + allocate(start_(1), count_(1)) + start_(1) = 1 + count_(1) = str_size + else + start_ = start + count_ = count + endif + status = c_f_pfio_get_var_string(ncid, varid, c_loc(string), c_loc(start_), c_loc(count_)) + deallocate(start_, count_) + + end function pfio_nf90_get_var_string + + function pfio_nf90_put_var_string(ncid, varid, string, start, count) result(status) + integer :: status + integer(kind=C_INT), intent(in) :: ncid + integer(kind=C_INT), intent(in) :: varid + character(*), target,intent(in):: string(:) + integer, optional, intent(in) :: start(:) + integer, optional, intent(in) :: count(:) + integer, target, allocatable :: start_(:), count_(:) + integer :: str_len, str_size + + str_len = len(string(1)) + str_size = size(string) + if (.not. present(start) .or. .not. present(count)) then + allocate(start_(1), count_(1)) + start_(1) = 1 + count_(1) = str_size + else + start_ = start + count_ = count + endif + status = c_f_pfio_put_var_string(ncid, varid, c_loc(string), str_len, str_size, c_loc(start_), c_loc(count_)) + deallocate(start_, count_) + end function pfio_nf90_put_var_string + + function pfio_nf90_get_var_string_len(ncid, varid, str_len) result(status) + use netcdf + integer :: status + integer, intent(in) :: ncid + integer, intent(in) :: varid + integer, intent(out):: str_len + integer, allocatable :: dimids(:) + integer :: size + integer, target :: length + + allocate(dimids(1)) + status = nf90_inquire_variable(ncid, varid, dimids=dimids) + status = nf90_inquire_dimension(ncid, dimids(1), len=size) + status = c_f_pfio_get_var_string_len(ncid, varid, c_loc(length), size) + str_len = length + + end function pfio_nf90_get_var_string_len + end module pfio_NetCDF_Supplement diff --git a/pfio/pfio_get_att_string.c b/pfio/pfio_get_att_string.c deleted file mode 100644 index 6b7b8475774e..000000000000 --- a/pfio/pfio_get_att_string.c +++ /dev/null @@ -1,51 +0,0 @@ -#include -#include -#include -#include - -void pfio_check(int stat) { - if (stat != NC_NOERR) { - printf("NetCDF error: %s\n", nc_strerror(stat)); - exit(1); - } -} - -int pfio_get_att_string(int ncid, int varid, const char* name, char* value, int *attlen) -{ - int stat; - size_t alen; - - /* note: C-varid starts from 0, Fortran from 1 */ - int varid_C = varid - 1; - - stat = nc_inq_attlen(ncid, varid_C, name, &alen); pfio_check(stat); - - if (alen > 1) { - printf("pfio doesnot support multi-dimentional strings"); - exit(-1); - } - - char **string_attr = (char**)malloc( sizeof(char*)); - memset(string_attr, 0, sizeof(char*)); - - stat = nc_get_att_string(ncid, varid_C, name, string_attr); pfio_check(stat); - - *attlen = 0; - alen = 0; - char *p = string_attr[0]; - for(;;){ - if (alen >=511) { - printf("pfio doesnot support string longer than 512"); - exit(-1); - } - *(value+alen) = (*(p+alen)); - if (*(p + alen) == '\0'){ - break; - } - alen = alen + 1; - } - *attlen = alen; - stat = nc_free_string(1, string_attr); pfio_check(stat); - free(string_attr); - return stat; -} diff --git a/pfio/pfio_nf90_supplement.c b/pfio/pfio_nf90_supplement.c new file mode 100644 index 000000000000..4af44ec0cd5c --- /dev/null +++ b/pfio/pfio_nf90_supplement.c @@ -0,0 +1,142 @@ +#include +#include +#include +#include + +void pfio_check(int stat) { + if (stat != NC_NOERR) { + printf("NetCDF error: %s\n", nc_strerror(stat)); + exit(1); + } +} + +int pfio_get_att_string(int ncid, int varid, const char* name, char* value, int *attlen) +{ + int stat; + size_t alen; + + /* note: C-varid starts from 0, Fortran from 1 */ + int varid_C = varid - 1; + + stat = nc_inq_attlen(ncid, varid_C, name, &alen); pfio_check(stat); + + if (alen > 1) { + printf("pfio doesnot support multi-dimentional strings"); + exit(-1); + } + + char **string_attr = (char**)malloc( sizeof(char*)); + memset(string_attr, 0, sizeof(char*)); + + stat = nc_get_att_string(ncid, varid_C, name, string_attr); pfio_check(stat); + + *attlen = 0; + alen = 0; + char *p = string_attr[0]; + for(;;){ + if (alen >=511) { + printf("pfio doesnot support string longer than 512"); + exit(-1); + } + *(value+alen) = (*(p+alen)); + if (*(p + alen) == '\0'){ + break; + } + alen = alen + 1; + } + *attlen = alen; + stat = nc_free_string(1, string_attr); pfio_check(stat); + free(string_attr); + return stat; +} + +// +int pfio_get_var_string_len(int ncid, int varid, int *str_len, int str_size) +{ + int stat; + + // note: C-varid starts from 0, Fortran from 1 + int varid_C = varid - 1; + char *string[str_size]; + stat = nc_get_var(ncid, varid_C, string ); pfio_check(stat); + + char *p ; + int i, j; + *str_len = 0; + for (i = 0; i Date: Fri, 2 Feb 2024 14:58:40 -0500 Subject: [PATCH 69/86] add an example --- .../pfio_read_write_1d_string_example.F90 | 49 +++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 pfio/tests/pfio_read_write_1d_string_example.F90 diff --git a/pfio/tests/pfio_read_write_1d_string_example.F90 b/pfio/tests/pfio_read_write_1d_string_example.F90 new file mode 100644 index 000000000000..04fb5c86297a --- /dev/null +++ b/pfio/tests/pfio_read_write_1d_string_example.F90 @@ -0,0 +1,49 @@ +program main + use MAPL_ExceptionHandling + use pFIO + use gFTL_StringVector + use gFTL_StringIntegerMap + use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc + use, intrinsic :: iso_fortran_env, only: REAL32 + + use pFIO_NetCDF4_FileFormatterMod + implicit none + + character(len=:), allocatable, target :: cvar1(:) + character(len=:), allocatable, target :: cvar2(:) + type (NetCDF4_FileFormatter) :: test_formatter + type (FileMetadata) :: metadata + type (Variable) :: v + integer :: Ydim, status, length, my_dim, k + + Ydim = 5 + call metadata%add_dimension('Ydim', Ydim) + v = Variable(type=pFIO_STRING, dimensions='Ydim') + call metadata%add_variable('char1',v) + cvar1 = ["abcd","lmnd","xyzu", "1234", "haha"] + + call test_formatter%create('test_in.nc4', rc=status) + call test_formatter%write(metadata, rc=status) + call test_formatter%put_var('char1', cvar1, start=[1], count=[Ydim]) + !call test_formatter%put_var('char1', cvar1) + call test_formatter%close(rc=status) + +! read back + + call test_formatter%open('test_in.nc4', PFIO_READ, rc=status) + call test_formatter%inq_var_string_length('char1',length) + metadata = test_formatter%read() + my_dim = metadata%get_dimension('Ydim') + if (my_dim /= Ydim ) print *, "dim is wrong" + + allocate(character(len=length):: cvar2(my_dim)) + call test_formatter%get_var('char1', cvar2, start=[1], count=[Ydim]) + ! call test_formatter%get_var('char1', cvar2) + call test_formatter%close() + do k = 1, Ydim + print*, cvar2(k) + enddo + + +end program + From 1bd8ddf613d77a0711ab376dd532aa2735749e88 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 2 Feb 2024 15:14:12 -0500 Subject: [PATCH 70/86] remove 0d string definition --- pfio/NetCDF4_FileFormatter.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index dacf59b5f6e8..26b894e39b44 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -1330,10 +1330,6 @@ end subroutine inq_variables ! string #define _VARTYPE 0 -# define _RANK 0 -# include "NetCDF4_get_var.H" -# include "NetCDF4_put_var.H" -# undef _RANK # define _RANK 1 # include "NetCDF4_get_var.H" # include "NetCDF4_put_var.H" From 11b8c07999ef92e303f6ff94741318b1cee67816 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 5 Feb 2024 15:11:59 -0500 Subject: [PATCH 71/86] writing 1d string without trailing space --- pfio/NetCDF_Supplement.F90 | 19 ++++++++++++++----- pfio/pfio_nf90_supplement.c | 19 +++++++++---------- .../pfio_read_write_1d_string_example.F90 | 3 ++- 3 files changed, 25 insertions(+), 16 deletions(-) diff --git a/pfio/NetCDF_Supplement.F90 b/pfio/NetCDF_Supplement.F90 index 699b274d50a2..66eab29c22b2 100644 --- a/pfio/NetCDF_Supplement.F90 +++ b/pfio/NetCDF_Supplement.F90 @@ -35,7 +35,7 @@ function c_f_pfio_get_var_string_len(ncid, varid, str_len_ptr, size) & integer(kind=C_INT), value, intent(in) :: size end function c_f_pfio_get_var_string_len - function c_f_pfio_get_var_string(ncid, varid, string_ptr, start_ptr, count_ptr) & + function c_f_pfio_get_var_string(ncid, varid, string_ptr, str_len, start_ptr, count_ptr) & & result(stat) bind(C, name='pfio_get_var_string') use, intrinsic :: iso_c_binding implicit none @@ -43,6 +43,7 @@ function c_f_pfio_get_var_string(ncid, varid, string_ptr, start_ptr, count_ptr) integer(kind=C_INT), value, intent(in) :: ncid integer(kind=C_INT), value, intent(in) :: varid type(c_ptr), intent(in), value :: string_ptr + integer(kind=C_INT), value, intent(in) :: str_len type(c_ptr), intent(in), value :: start_ptr type(c_ptr), intent(in), value :: count_ptr end function c_f_pfio_get_var_string @@ -110,7 +111,7 @@ function pfio_nf90_get_var_string(ncid, varid, string, start, count) result(stat start_ = start count_ = count endif - status = c_f_pfio_get_var_string(ncid, varid, c_loc(string), c_loc(start_), c_loc(count_)) + status = c_f_pfio_get_var_string(ncid, varid, c_loc(string), str_len, c_loc(start_), c_loc(count_)) deallocate(start_, count_) end function pfio_nf90_get_var_string @@ -123,9 +124,10 @@ function pfio_nf90_put_var_string(ncid, varid, string, start, count) result(stat integer, optional, intent(in) :: start(:) integer, optional, intent(in) :: count(:) integer, target, allocatable :: start_(:), count_(:) - integer :: str_len, str_size + integer :: max_len, str_size, k + character(len=:),allocatable, target :: string_C(:) - str_len = len(string(1)) + max_len = len(string(1)) + 1 str_size = size(string) if (.not. present(start) .or. .not. present(count)) then allocate(start_(1), count_(1)) @@ -135,8 +137,15 @@ function pfio_nf90_put_var_string(ncid, varid, string, start, count) result(stat start_ = start count_ = count endif - status = c_f_pfio_put_var_string(ncid, varid, c_loc(string), str_len, str_size, c_loc(start_), c_loc(count_)) + + allocate(character(len=max_len) :: string_C(str_size)) + do k = 1, str_size + string_C(k) = trim(string(k))//c_null_char + enddo + + status = c_f_pfio_put_var_string(ncid, varid, c_loc(string_C), max_len, str_size, c_loc(start_), c_loc(count_)) deallocate(start_, count_) + deallocate(string_C) end function pfio_nf90_put_var_string function pfio_nf90_get_var_string_len(ncid, varid, str_len) result(status) diff --git a/pfio/pfio_nf90_supplement.c b/pfio/pfio_nf90_supplement.c index 4af44ec0cd5c..6237102a2a29 100644 --- a/pfio/pfio_nf90_supplement.c +++ b/pfio/pfio_nf90_supplement.c @@ -77,7 +77,7 @@ int pfio_get_var_string_len(int ncid, int varid, int *str_len, int str_size) return stat; } -int pfio_get_var_string(int ncid, int varid, char* value, const size_t *start, const size_t *count) +int pfio_get_var_string(int ncid, int varid, char* value, int max_len, const size_t *start, const size_t *count) { int stat; @@ -101,10 +101,15 @@ int pfio_get_var_string(int ncid, int varid, char* value, const size_t *start, c j = 0; for (;;){ if (*(p+j) == '\0'){ + for (; j Date: Tue, 6 Feb 2024 10:44:42 -0500 Subject: [PATCH 72/86] Fixes #2469. Convert MAPL to use ESMF::ESMF target --- Apps/CMakeLists.txt | 6 +++--- CHANGELOG.md | 3 +++ CMakeLists.txt | 11 ++++++----- MAPL/CMakeLists.txt | 2 +- MAPL_cfio/CMakeLists.txt | 2 +- Tests/CMakeLists.txt | 6 +++--- base/CMakeLists.txt | 4 ++-- base/tests/CMakeLists.txt | 2 +- benchmarks/io/checkpoint_simulator/CMakeLists.txt | 2 +- cmake/FindESMF.cmake | 5 +++++ components.yaml | 2 +- .../automatic_code_generator_example/CMakeLists.txt | 2 +- .../grid_comps/hello_world_gridcomp/CMakeLists.txt | 2 +- docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt | 2 +- docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt | 2 +- .../grid_comps/parent_with_no_children/CMakeLists.txt | 2 +- .../grid_comps/parent_with_one_child/CMakeLists.txt | 2 +- .../parent_with_two_children/CMakeLists.txt | 2 +- field_utils/CMakeLists.txt | 4 ++-- generic/CMakeLists.txt | 2 +- gridcomps/Cap/CMakeLists.txt | 2 +- gridcomps/ExtData/CMakeLists.txt | 2 +- gridcomps/ExtData2G/CMakeLists.txt | 2 +- gridcomps/History/CMakeLists.txt | 2 +- gridcomps/Orbit/CMakeLists.txt | 2 +- griddedio/CMakeLists.txt | 2 +- pfunit/CMakeLists.txt | 2 +- 27 files changed, 44 insertions(+), 35 deletions(-) diff --git a/Apps/CMakeLists.txt b/Apps/CMakeLists.txt index 41cd7462a4a7..7c3e9507c814 100644 --- a/Apps/CMakeLists.txt +++ b/Apps/CMakeLists.txt @@ -24,7 +24,7 @@ install( DESTINATION bin/forcing_converter) ecbuild_add_executable (TARGET Regrid_Util.x SOURCES Regrid_Util.F90) -target_link_libraries (Regrid_Util.x PRIVATE MAPL MPI::MPI_Fortran esmf) +target_link_libraries (Regrid_Util.x PRIVATE MAPL MPI::MPI_Fortran ESMF::ESMF) target_include_directories (Regrid_Util.x PRIVATE $) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") @@ -32,7 +32,7 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") endif () ecbuild_add_executable (TARGET time_ave_util.x SOURCES time_ave_util.F90) -target_link_libraries (time_ave_util.x PRIVATE MAPL MPI::MPI_Fortran esmf) +target_link_libraries (time_ave_util.x PRIVATE MAPL MPI::MPI_Fortran ESMF::ESMF) target_include_directories (time_ave_util.x PRIVATE $) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") @@ -40,7 +40,7 @@ if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") endif () ecbuild_add_executable (TARGET Comp_Testing_Driver.x SOURCES Comp_Testing_Driver.F90) -target_link_libraries (Comp_Testing_Driver.x PRIVATE MAPL MPI::MPI_Fortran esmf) +target_link_libraries (Comp_Testing_Driver.x PRIVATE MAPL MPI::MPI_Fortran ESMF::ESMF) target_include_directories (Comp_Testing_Driver.x PRIVATE $) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/CHANGELOG.md b/CHANGELOG.md index eb184c25e792..55a8e558bd86 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -33,6 +33,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 now required), NAG no longer needs this workaround. - Refactor the CircleCI workflows for more flexibility - Fix field utils issue - add npes argument to test subroutine decorators. +- Change MAPL CMake to use `ESMF::ESMF` target instead of `esmf` or `ESMF` as the imported target name + - Updated `FindESMF.cmake` to match that of ESMF `develop` as of commit `da8f410`. This will be in ESMF 8.6.1+ + - Requires ESMA_cmake 3.40.0 or later as this adds the `ESMF::ESMF` target ALIAS for Baselibs and non-Baselibs builds ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 198d56ba599c..501be67d6dcc 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -147,20 +147,21 @@ if (NOT Baselibs_FOUND) add_definitions(-DH5_HAVE_PARALLEL) endif() - if (NOT TARGET esmf) + if (NOT TARGET ESMF::ESMF) find_package(ESMF 8.6.0 MODULE REQUIRED) # ESMF as used in MAPL requires MPI # NOTE: This looks odd because some versions of FindESMF.cmake out in the # world provide an "esmf" target while others provide "ESMF". So we # need this ugliness to support both. - if (TARGET esmf) - target_link_libraries(esmf INTERFACE MPI::MPI_Fortran) + if (TARGET ESMF::ESMF) + target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) else() - target_link_libraries(ESMF INTERFACE MPI::MPI_Fortran) + target_link_libraries(ESMF::ESMF INTERFACE MPI::MPI_Fortran) # MAPL and GEOS use lowercase target due to historical reasons but # the latest FindESMF.cmake file from ESMF produces an ESMF target. - add_library(esmf ALIAS ESMF) + add_library(ESMF::ESMF ALIAS ESMF) + add_library(ESMF::ESMF ALIAS esmf) endif() endif () else () diff --git a/MAPL/CMakeLists.txt b/MAPL/CMakeLists.txt index 694250dcc33c..edf76dfc0a20 100644 --- a/MAPL/CMakeLists.txt +++ b/MAPL/CMakeLists.txt @@ -4,7 +4,7 @@ esma_set_this() esma_add_library (${this} SRCS MAPL.F90 DEPENDENCIES MAPL.base MAPL.generic MAPL.pfio MAPL_cfio_r4 MAPL.gridcomps MAPL.orbit MAPL.griddedio MAPL.field_utils ${EXTDATA_TARGET} - esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran + ESMF::ESMF NetCDF::NetCDF_Fortran MPI::MPI_Fortran $<$:FLAP::FLAP> TYPE ${MAPL_LIBRARY_TYPE} ) diff --git a/MAPL_cfio/CMakeLists.txt b/MAPL_cfio/CMakeLists.txt index a7d9c3018538..01ccb4b5e8c2 100644 --- a/MAPL_cfio/CMakeLists.txt +++ b/MAPL_cfio/CMakeLists.txt @@ -44,7 +44,7 @@ endif () esma_add_library (${lib} SRCS ${srcs} - DEPENDENCIES esmf NetCDF::NetCDF_Fortran + DEPENDENCIES ESMF::ESMF NetCDF::NetCDF_Fortran TYPE ${LIBRARY_TYPE} ) diff --git a/Tests/CMakeLists.txt b/Tests/CMakeLists.txt index d427e82a59c0..ebb0dcb2122d 100644 --- a/Tests/CMakeLists.txt +++ b/Tests/CMakeLists.txt @@ -11,7 +11,7 @@ set (srcs if (BUILD_WITH_FARGPARSE) ecbuild_add_executable (TARGET ExtDataDriver.x SOURCES ${srcs}) - target_link_libraries (ExtDataDriver.x PRIVATE MAPL FARGPARSE::fargparse esmf) + target_link_libraries (ExtDataDriver.x PRIVATE MAPL FARGPARSE::fargparse ESMF::ESMF) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(ExtDataDriver.x PRIVATE OpenMP::OpenMP_Fortran) @@ -21,14 +21,14 @@ if (BUILD_WITH_FARGPARSE) add_subdirectory(ExtData_Testing_Framework EXCLUDE_FROM_ALL) ecbuild_add_executable (TARGET pfio_MAPL_demo.x SOURCES pfio_MAPL_demo.F90) - target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FARGPARSE::fargparse esmf) + target_link_libraries (pfio_MAPL_demo.x PRIVATE MAPL FARGPARSE::fargparse ESMF::ESMF) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(pfio_MAPL_demo.x PRIVATE OpenMP::OpenMP_Fortran) endif () set_target_properties(pfio_MAPL_demo.x PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) ecbuild_add_executable (TARGET MAPL_demo_fargparse.x SOURCES MAPL_demo_fargparse.F90) - target_link_libraries (MAPL_demo_fargparse.x PRIVATE MAPL FARGPARSE::fargparse esmf) + target_link_libraries (MAPL_demo_fargparse.x PRIVATE MAPL FARGPARSE::fargparse ESMF::ESMF) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(MAPL_demo_fargparse.x PRIVATE OpenMP::OpenMP_Fortran) diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 17db0ff4209a..02aa55f6af08 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -69,7 +69,7 @@ esma_add_library( ${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 MAPL.field_utils PFLOGGER::pflogger GFTL_SHARED::gftl-shared-v2 GFTL_SHARED::gftl-shared-v1 GFTL::gftl-v2 GFTL::gftl-v1 - esmf NetCDF::NetCDF_Fortran MPI::MPI_Fortran + ESMF::ESMF NetCDF::NetCDF_Fortran MPI::MPI_Fortran TYPE ${MAPL_LIBRARY_TYPE}) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 @@ -90,7 +90,7 @@ foreach(dir ${OSX_EXTRA_LIBRARY_PATH}) target_link_libraries(${this} PUBLIC "-Xlinker -rpath -Xlinker ${dir}") endforeach() -ecbuild_add_executable (TARGET cub2latlon.x SOURCES cub2latlon_regridder.F90 DEPENDS esmf MAPL.shared) +ecbuild_add_executable (TARGET cub2latlon.x SOURCES cub2latlon_regridder.F90 DEPENDS ESMF::ESMF MAPL.shared) target_link_libraries (cub2latlon.x PRIVATE ${this} MAPL.pfio MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/base/tests/CMakeLists.txt b/base/tests/CMakeLists.txt index 46577909e502..d246076f242f 100644 --- a/base/tests/CMakeLists.txt +++ b/base/tests/CMakeLists.txt @@ -33,7 +33,7 @@ set (SRCS # MAPL_Initialize.F90 # ) #target_link_libraries (base_extras MAPL.shared MAPL.pfunit -# esmf NetCDF::NetCDF_Fortran) +# ESMF::ESMF NetCDF::NetCDF_Fortran) add_pfunit_ctest(MAPL.base.tests TEST_SOURCES ${TEST_SRCS} diff --git a/benchmarks/io/checkpoint_simulator/CMakeLists.txt b/benchmarks/io/checkpoint_simulator/CMakeLists.txt index fedd46d5f3f4..4b08c60fffd6 100644 --- a/benchmarks/io/checkpoint_simulator/CMakeLists.txt +++ b/benchmarks/io/checkpoint_simulator/CMakeLists.txt @@ -6,7 +6,7 @@ ecbuild_add_executable ( SOURCES checkpoint_simulator.F90 DEFINITIONS USE_MPI) -target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse esmf ) +target_link_libraries (${exe} PRIVATE MAPL.shared MPI::MPI_Fortran FARGPARSE::fargparse ESMF::ESMF ) target_include_directories (${exe} PUBLIC $) set_target_properties (${exe} PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) diff --git a/cmake/FindESMF.cmake b/cmake/FindESMF.cmake index 23efbb31d078..eabba677d3b6 100644 --- a/cmake/FindESMF.cmake +++ b/cmake/FindESMF.cmake @@ -109,6 +109,11 @@ if(EXISTS ${ESMFMKFILE}) endif() endif() + # Add target alias to facilitate unambiguous linking + if(NOT TARGET ESMF::ESMF) + add_library(ESMF::ESMF ALIAS ESMF) + endif() + # Add ESMF include directories set(ESMF_INCLUDE_DIRECTORIES "") separate_arguments(_ESMF_F90COMPILEPATHS UNIX_COMMAND ${ESMF_F90COMPILEPATHS}) diff --git a/components.yaml b/components.yaml index fd6df1677150..4c63d816dee8 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.37.0 + tag: v3.40.0 develop: develop ecbuild: diff --git a/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt b/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt index 4ae20760f332..8422b3a79540 100644 --- a/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt +++ b/docs/tutorial/grid_comps/automatic_code_generator_example/CMakeLists.txt @@ -6,7 +6,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) diff --git a/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt b/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt index cc348414e1aa..0e74c76742a1 100644 --- a/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt +++ b/docs/tutorial/grid_comps/hello_world_gridcomp/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt b/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt index 1dfc4cd25bae..d912da16f28d 100644 --- a/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt +++ b/docs/tutorial/grid_comps/leaf_comp_a/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt b/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt index ec9acc547f90..e2ae84142283 100644 --- a/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt +++ b/docs/tutorial/grid_comps/leaf_comp_b/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt b/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt index c8e06933c33b..c9c4299b76bd 100644 --- a/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt +++ b/docs/tutorial/grid_comps/parent_with_no_children/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt b/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt index 4274f2448dc0..b5da305f8e82 100644 --- a/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt +++ b/docs/tutorial/grid_comps/parent_with_one_child/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt b/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt index d3f0ea92b3c7..66b39a86a6b3 100644 --- a/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt +++ b/docs/tutorial/grid_comps/parent_with_two_children/CMakeLists.txt @@ -7,7 +7,7 @@ esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL TYPE ${MAPL if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") target_link_libraries(${this} PRIVATE OpenMP::OpenMP_Fortran) endif () -target_link_libraries(${this} PRIVATE esmf) +target_link_libraries(${this} PRIVATE ESMF::ESMF) target_include_directories (${this} PUBLIC $) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) #target_compile_definitions(${this} PRIVATE SYSTEM_DSO_SUFFIX="${CMAKE_SHARED_LIBRARY_SUFFIX}") diff --git a/field_utils/CMakeLists.txt b/field_utils/CMakeLists.txt index 68381a757c12..136d8cdb2dd0 100644 --- a/field_utils/CMakeLists.txt +++ b/field_utils/CMakeLists.txt @@ -30,8 +30,8 @@ esma_add_library(${this} target_include_directories (${this} PUBLIC $) -#target_link_libraries (${this} PUBLIC esmf NetCDF::NetCDF_Fortran) -target_link_libraries (${this} PUBLIC esmf) +#target_link_libraries (${this} PUBLIC ESMF::ESMF NetCDF::NetCDF_Fortran) +target_link_libraries (${this} PUBLIC ESMF::ESMF) if (PFUNIT_FOUND) # Turning off until test with GNU can be fixed diff --git a/generic/CMakeLists.txt b/generic/CMakeLists.txt index 901ec303d3ff..06b6468771dc 100644 --- a/generic/CMakeLists.txt +++ b/generic/CMakeLists.txt @@ -69,7 +69,7 @@ esma_add_library(${this} ) target_include_directories (${this} PUBLIC $) -target_link_libraries (${this} PUBLIC esmf NetCDF::NetCDF_Fortran) +target_link_libraries (${this} PUBLIC ESMF::ESMF NetCDF::NetCDF_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/gridcomps/Cap/CMakeLists.txt b/gridcomps/Cap/CMakeLists.txt index c6136b4f63e3..20b70e3953fd 100644 --- a/gridcomps/Cap/CMakeLists.txt +++ b/gridcomps/Cap/CMakeLists.txt @@ -16,7 +16,7 @@ endif() esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.profiler MAPL.history MAPL.ExtData ${EXTDATA2G_TARGET} TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran $<$:FLAP::FLAP> $<$:FARGPARSE::fargparse>) diff --git a/gridcomps/ExtData/CMakeLists.txt b/gridcomps/ExtData/CMakeLists.txt index f48868e1fe4f..51ccf7a3a3be 100644 --- a/gridcomps/ExtData/CMakeLists.txt +++ b/gridcomps/ExtData/CMakeLists.txt @@ -8,7 +8,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.pfio MAPL.griddedio MAPL_cfio_r4 TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/gridcomps/ExtData2G/CMakeLists.txt b/gridcomps/ExtData2G/CMakeLists.txt index 97d1e5d41c92..52f6507fe5ae 100644 --- a/gridcomps/ExtData2G/CMakeLists.txt +++ b/gridcomps/ExtData2G/CMakeLists.txt @@ -24,7 +24,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.base MAPL.generic MAPL.griddedio TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) target_include_directories (${this} PUBLIC $) diff --git a/gridcomps/History/CMakeLists.txt b/gridcomps/History/CMakeLists.txt index 25ba48139cfe..269ae7317758 100644 --- a/gridcomps/History/CMakeLists.txt +++ b/gridcomps/History/CMakeLists.txt @@ -11,7 +11,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.profiler MAPL.griddedio TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/gridcomps/Orbit/CMakeLists.txt b/gridcomps/Orbit/CMakeLists.txt index b33c4f37778b..ed51cb1e23cb 100644 --- a/gridcomps/Orbit/CMakeLists.txt +++ b/gridcomps/Orbit/CMakeLists.txt @@ -5,7 +5,7 @@ set (srcs ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/griddedio/CMakeLists.txt b/griddedio/CMakeLists.txt index 1721226ab822..db7322918aef 100644 --- a/griddedio/CMakeLists.txt +++ b/griddedio/CMakeLists.txt @@ -12,7 +12,7 @@ set (srcs esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.pfio MAPL_cfio_r4 TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared esmf NetCDF::NetCDF_Fortran +target_link_libraries (${this} PUBLIC GFTL::gftl GFTL_SHARED::gftl-shared ESMF::ESMF NetCDF::NetCDF_Fortran PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 diff --git a/pfunit/CMakeLists.txt b/pfunit/CMakeLists.txt index 2cb3a2a44654..51d6682aa6f5 100644 --- a/pfunit/CMakeLists.txt +++ b/pfunit/CMakeLists.txt @@ -10,5 +10,5 @@ set (srcs esma_add_library (${this} EXCLUDE_FROM_ALL SRCS ${srcs} NOINSTALL TYPE ${MAPL_LIBRARY_TYPE}) -target_link_libraries (${this} MAPL.shared PFUNIT::pfunit esmf NetCDF::NetCDF_Fortran) +target_link_libraries (${this} MAPL.shared PFUNIT::pfunit ESMF::ESMF NetCDF::NetCDF_Fortran) set_target_properties (${this} PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) From 03896ba2d9406cb7a7fe2caa933ded7e3df70861 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 Feb 2024 11:13:44 -0500 Subject: [PATCH 73/86] Fix JSON --- presets/CMakeNCCSPresets.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/presets/CMakeNCCSPresets.json b/presets/CMakeNCCSPresets.json index 730b13432fd0..4902c9b29cbb 100644 --- a/presets/CMakeNCCSPresets.json +++ b/presets/CMakeNCCSPresets.json @@ -6,7 +6,7 @@ "displayName": "Base Configure Settings", "description": "Sets build and install directories", "binaryDir": "$penv{CMAKE_BUILD_LOCATION}/${sourceDirName}/build-${presetName}", - "installDir": "$penv{CMAKE_INSTALL_LOCATION}/${sourceDirName}/install-${presetName}", + "installDir": "$penv{CMAKE_INSTALL_LOCATION}/${sourceDirName}/install-${presetName}" } ], "version": 7 From 2a331d9c5d7c072c81a5baeb87f20d44936ec1ca Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 6 Feb 2024 11:29:01 -0500 Subject: [PATCH 74/86] Update gitignore --- .gitignore | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.gitignore b/.gitignore index 1d39e86a6c17..5e844f143a4a 100644 --- a/.gitignore +++ b/.gitignore @@ -9,6 +9,10 @@ *.py.bak CMakeUserPresets.json +# Ignore possible symlinked build and install directories +build-* +install-* + *.swp *.swo .DS_Store From df36196f2431eaaa660cc8e005173dce4ad7217d Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Tue, 6 Feb 2024 14:27:39 -0500 Subject: [PATCH 75/86] trim leading space in 1d string --- pfio/NetCDF_Supplement.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pfio/NetCDF_Supplement.F90 b/pfio/NetCDF_Supplement.F90 index 66eab29c22b2..c9de2f26417c 100644 --- a/pfio/NetCDF_Supplement.F90 +++ b/pfio/NetCDF_Supplement.F90 @@ -140,7 +140,7 @@ function pfio_nf90_put_var_string(ncid, varid, string, start, count) result(stat allocate(character(len=max_len) :: string_C(str_size)) do k = 1, str_size - string_C(k) = trim(string(k))//c_null_char + string_C(k) = trim(adjustl(string(k)))//c_null_char enddo status = c_f_pfio_put_var_string(ncid, varid, c_loc(string_C), max_len, str_size, c_loc(start_), c_loc(count_)) From 2a79d2f6428422b5a3cc173f9cd9510f79792102 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 7 Feb 2024 09:15:30 -0500 Subject: [PATCH 76/86] Integrate test changes from `release/MAPL-v3 --- field_utils/tests/Test_FieldArithmetic.pf | 2 +- field_utils/tests/Test_FieldBLAS.pf | 115 +++++++++++++--------- field_utils/tests/field_utils_setup.F90 | 16 +-- 3 files changed, 78 insertions(+), 55 deletions(-) diff --git a/field_utils/tests/Test_FieldArithmetic.pf b/field_utils/tests/Test_FieldArithmetic.pf index cb21eda11296..57bb1e20c10a 100644 --- a/field_utils/tests/Test_FieldArithmetic.pf +++ b/field_utils/tests/Test_FieldArithmetic.pf @@ -66,7 +66,7 @@ contains call ESMF_FieldGet(y , farrayPtr = y_ptr, _RC) x_ptr = 2.0 - y_ptr = 3.0 + y_ptr = 3.0 result_array = x_ptr result_array = 5.0 call FieldAdd(y, x, y, _RC) diff --git a/field_utils/tests/Test_FieldBLAS.pf b/field_utils/tests/Test_FieldBLAS.pf index f7359eb07d7a..9c467810d30b 100644 --- a/field_utils/tests/Test_FieldBLAS.pf +++ b/field_utils/tests/Test_FieldBLAS.pf @@ -6,7 +6,7 @@ module Test_FieldBLAS use field_utils_setup use MAPL_FieldPointerUtilities use ESMF - use funit + use pfunit use MAPL_ExceptionHandling implicit none @@ -14,8 +14,8 @@ module Test_FieldBLAS contains @Before - subroutine set_up_data() - implicit none + subroutine set_up_data(this) + class(MpiTestMethod), intent(inout) :: this integer :: status, rc @@ -43,9 +43,15 @@ contains end subroutine set_up_data - @Test(npes=product(REG_DECOMP_DEFAULT)) + @after + subroutine teardown(this) + class(MpiTestMethod), intent(inout) :: this + end subroutine teardown + + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL32) - subroutine test_FieldCOPY_R4() + subroutine test_FieldCOPY_R4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr @@ -61,9 +67,10 @@ contains end subroutine test_FieldCOPY_R4 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL64) - subroutine test_FieldCOPY_R8() + subroutine test_FieldCOPY_R8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr @@ -79,9 +86,10 @@ contains end subroutine test_FieldCOPY_R8 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL32 -> REAL64) - subroutine test_FieldCOPY_R4R8() + subroutine test_FieldCOPY_R4R8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: x_ptr @@ -97,9 +105,10 @@ contains end subroutine test_FieldCOPY_R4R8 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! Basic test of FieldCOPY subroutine (REAL64 -> REAL32) - subroutine test_FieldCOPY_R8R4() + subroutine test_FieldCOPY_R8R4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr @@ -117,9 +126,10 @@ contains end subroutine test_FieldCOPY_R8R4 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! Basic test of FieldSCAL subroutine (REAL32) - subroutine test_FieldSCAL_R4() + subroutine test_FieldSCAL_R4(this) + class(MpiTestMethod), intent(inout) :: this real(kind=ESMF_KIND_R4), parameter :: a = 2.0 type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), dimension(:,:), allocatable :: x_array @@ -135,10 +145,11 @@ contains end subroutine test_FieldSCAL_R4 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! Basic test of FieldSCAL subroutine (REAL64) - subroutine test_FieldSCAL_R8() - real(kind=ESMF_KIND_R8), parameter :: a = 2.0 + subroutine test_FieldSCAL_R8(this) + class(MpiTestMethod), intent(inout) :: this + real(kind=ESMF_KIND_R8), parameter :: a = 2.0 type(ESMF_Field) :: x real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr @@ -153,9 +164,10 @@ contains end subroutine test_FieldSCAL_R8 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! - subroutine test_FieldAXPY_R4() + subroutine test_FieldAXPY_R4(this) + class(MpiTestMethod), intent(inout) :: this real(kind=ESMF_KIND_R4), parameter :: a = 2.0 type(ESMF_Field) :: x type(ESMF_Field) :: y @@ -178,10 +190,11 @@ contains end subroutine test_FieldAXPY_R4 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! - subroutine test_FieldAXPY_R8() - real(kind=ESMF_KIND_R8), parameter :: a = 2.0 + subroutine test_FieldAXPY_R8(this) + class(MpiTestMethod), intent(inout) :: this + real(kind=ESMF_KIND_R8), parameter :: a = 2.0 type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array @@ -203,8 +216,9 @@ contains end subroutine test_FieldAXPY_R8 - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldGetLocalElementCount() + @Test(npes=[4]) + subroutine test_FieldGetLocalElementCount(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x integer :: rank integer, allocatable :: expected_count(:) @@ -217,13 +231,13 @@ contains call ESMF_FieldGet(x, localElementCount=expected_count, _RC) actual_count = FieldGetLocalElementCount(x, _RC) @assertEqual(actual_count, expected_count) - if(allocated(expected_count)) deallocate(expected_count) end subroutine test_FieldGetLocalElementCount - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! - subroutine test_FieldGetLocalSize() + subroutine test_FieldGetLocalSize(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x integer :: status, rc integer :: rank @@ -242,14 +256,14 @@ contains end subroutine test_FieldGetLocalSize - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! Test getting the c_ptr for a field !wdb fixme Should test more extensively for different ranks !wdb fixme Should test for ESMF_KIND_I4 and ESMF_KIND_I8 !wdb fixme Should check c_cptr from tested method against independent test - - subroutine test_FieldGetCptr() - type(ESMF_Field) :: x + subroutine test_FieldGetCptr(this) + class(MpiTestMethod), intent(inout) :: this + type(ESMF_Field) :: x type(c_ptr) :: cptr integer :: status, rc @@ -260,9 +274,10 @@ contains end subroutine test_FieldGetCptr - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) !wdb fixme Probably should test for non-conformable fields - subroutine test_FieldsAreConformableR4() + subroutine test_FieldsAreConformableR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x, y integer :: status, rc logical :: are_conformable @@ -276,9 +291,10 @@ contains end subroutine test_FieldsAreConformableR4 !wdb fixme Probably should test for non-conformable fields - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldsAreConformableR8() - type(ESMF_Field) :: x, y + @Test(npes=[4]) + subroutine test_FieldsAreConformableR8(this) + class(MpiTestMethod), intent(inout) :: this + type(ESMF_Field) :: x, y integer :: status, rc logical :: are_conformable @@ -290,9 +306,10 @@ contains end subroutine test_FieldsAreConformableR8 - @Test(npes=product(REG_DECOMP_DEFAULT)) + @Test(npes=[4]) ! - subroutine test_FieldsAreSameTypeKind() + subroutine test_FieldsAreSameTypeKind(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x, y integer :: status, rc logical :: are_same_typekind @@ -318,9 +335,10 @@ contains end subroutine test_FieldsAreSameTypeKind !wdb fixme Enable assertEqual - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldConvertPrec_R4R8() - integer, parameter :: NROWS = 4 + @Test(npes=[4]) + subroutine test_FieldConvertPrec_R4R8(this) + class(MpiTestMethod), intent(inout) :: this + integer, parameter :: NROWS = 2 integer, parameter :: NCOLS = NROWS type(ESMF_Field) :: r4_field, r8_field real(kind=ESMF_KIND_R4) :: r4_data(NROWS,NCOLS) @@ -340,12 +358,13 @@ contains name = 'YR8', _RC) call FieldConvertPrec(r4_field, r8_field, _RC) call ESMF_FieldGet(r8_field, farrayPtr = r8_pointer, _RC) -! @assertEqual(r8_converted, r8_pointer) !wdb fixme temporarily disabled + @assertEqual(r8_converted, r8_pointer) end subroutine test_FieldConvertPrec_R4R8 - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldClone3D() + @Test(npes=[4]) + subroutine test_FieldClone3D(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x, y integer :: status, rc @@ -380,8 +399,9 @@ contains end subroutine test_FieldClone3D - @Test - subroutine test_almost_equal_scalar() + @Test(npes=[4]) + subroutine test_almost_equal_scalar(this) + class(MpiTestMethod), intent(inout) :: this character(len=*), parameter :: MSG = 'Difference exceeds threshold' real(kind=ESMF_KIND_R8), parameter :: X = 1.0 / 3.0 real(kind=ESMF_KIND_R4) :: y @@ -391,8 +411,9 @@ contains end subroutine test_almost_equal_scalar - @Test - subroutine test_almost_equal_array() + @Test(npes=[4]) + subroutine test_almost_equal_array(this) + class(MpiTestMethod), intent(inout) :: this integer, parameter :: N = 3 character(len=*), parameter :: MSG = 'Difference exceeds threshold' real(kind=ESMF_KIND_R8), parameter :: DENOMS(N) = [3.0, 5.0, 7.0] diff --git a/field_utils/tests/field_utils_setup.F90 b/field_utils/tests/field_utils_setup.F90 index 437a3d107631..76cd290e4ee2 100644 --- a/field_utils/tests/field_utils_setup.F90 +++ b/field_utils/tests/field_utils_setup.F90 @@ -21,7 +21,7 @@ module field_utils_setup integer :: i type(ESMF_Index_Flag), parameter :: INDEX_FLAG_DEFAULT = ESMF_INDEX_DELOCAL integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] - integer, parameter :: MAX_INDEX_DEFAULT(*) = [4, 4] + integer, parameter :: MAX_INDEX_DEFAULT(*) = [2, 2] integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] @@ -29,8 +29,8 @@ module field_utils_setup integer, parameter :: SIZE_R8 = 16 real, parameter :: undef = 42.0 - real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R4)], DIMR4_DEFAULT) - real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, SIZE_R8)], DIMR8_DEFAULT) + real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, 4)], [2,2]) + real(kind=ESMF_KIND_R8), parameter :: R8_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, 4)], [2,2]) type(ESMF_Field) :: XR4 type(ESMF_Field) :: XR8 @@ -56,7 +56,7 @@ function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result integer :: status - grid = ESMF_GridCreateNoPeriDim(regDecomp = regDecomp, maxIndex = maxIndex, minIndex = minIndex, indexflag = indexflag, name = grid_name, _RC) + grid = ESMF_GridCreateNoPeriDim(countsPerDeDim1=[2,2], countsPerDeDim2=[2,2], indexflag = indexflag, name = grid_name, _RC) _RETURN(_SUCCESS) end function mk_grid @@ -96,7 +96,8 @@ function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray + + ptr = farray _RETURN(_SUCCESS) end function mk_field_r4_2d @@ -117,7 +118,7 @@ function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) call ESMF_FieldGet(field, farrayPtr = ptr, _RC) - ptr => farray + ptr = farray _RETURN(_SUCCESS) end function mk_field_r8_2d @@ -138,7 +139,8 @@ function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ung type(ESMF_Field) :: field type(ESMF_Grid) :: grid integer :: status - + real, pointer :: fptr(:,:) + grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) From 631f4a71804f7cf5a012b81e04029d0a0e22ded2 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 7 Feb 2024 09:47:40 -0500 Subject: [PATCH 77/86] Eliminate unused variables. --- field_utils/tests/Test_FieldArithmetic.pf | 12 ++-- field_utils/tests/Test_FieldBLAS.pf | 72 +++-------------------- field_utils/tests/field_utils_setup.F90 | 46 ++++----------- 3 files changed, 24 insertions(+), 106 deletions(-) diff --git a/field_utils/tests/Test_FieldArithmetic.pf b/field_utils/tests/Test_FieldArithmetic.pf index 57bb1e20c10a..7f02be3fed01 100644 --- a/field_utils/tests/Test_FieldArithmetic.pf +++ b/field_utils/tests/Test_FieldArithmetic.pf @@ -35,14 +35,10 @@ contains allocate(y8array, source=R8_ARRAY_DEFAULT) y4array = y4array + ADD_R4 y8array = y8array + ADD_R8 - XR4 = mk_field(R4_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR4', _RC) - YR4 = mk_field(y4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR4', _RC) - XR8 = mk_field(R8_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) - YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) + XR4 = mk_field(R4_ARRAY_DEFAULT, name = 'XR4', _RC) + YR4 = mk_field(y4array, name = 'YR4', _RC) + XR8 = mk_field(R8_ARRAY_DEFAULT, name = 'XR8', _RC) + YR8 = mk_field(y8array, name = 'YR8', _RC) call ESMF_AttributeSet(xr4,name="missing_value",value=undef,_RC) call ESMF_AttributeSet(xr8,name="missing_value",value=undef,_RC) call ESMF_AttributeSet(yr4,name="missing_value",value=undef,_RC) diff --git a/field_utils/tests/Test_FieldBLAS.pf b/field_utils/tests/Test_FieldBLAS.pf index 9c467810d30b..f17f0c9b330c 100644 --- a/field_utils/tests/Test_FieldBLAS.pf +++ b/field_utils/tests/Test_FieldBLAS.pf @@ -28,18 +28,12 @@ contains allocate(y8array, source=R8_ARRAY_DEFAULT) y4array = y4array + ADD_R4 y8array = y8array + ADD_R8 - XR4 = mk_field(R4_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR4', _RC) - YR4 = mk_field(y4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR4', _RC) - XR8 = mk_field(R8_ARRAY_DEFAULT, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR8', _RC) - YR8 = mk_field(y8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR8', _RC) - XR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC) - YR4_3D = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC) + XR4 = mk_field(R4_ARRAY_DEFAULT, name = 'XR4', _RC) + YR4 = mk_field(y4array, name = 'YR4', _RC) + XR8 = mk_field(R8_ARRAY_DEFAULT, name = 'XR8', _RC) + YR8 = mk_field(y8array, name = 'YR8', _RC) + XR4_3D = mk_field_r4_ungrid(name = 'XR4_3D', ungriddedLBound=[1],ungriddedUBound=[3],_RC) + YR4_3D = mk_field_r4_ungrid(name = 'YR4_3D',ungriddedLBound=[1],ungriddedUBound=[3], _RC) end subroutine set_up_data @@ -212,7 +206,6 @@ contains call FieldAXPY(a, x, y, _RC) call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC) -! @assertEqual(y_ptr, a*x_array+y_array) !wdb fixme Temporarily disabled end subroutine test_FieldAXPY_R8 @@ -334,7 +327,6 @@ contains end subroutine test_FieldsAreSameTypeKind -!wdb fixme Enable assertEqual @Test(npes=[4]) subroutine test_FieldConvertPrec_R4R8(this) class(MpiTestMethod), intent(inout) :: this @@ -350,12 +342,8 @@ contains call initialize_array(r4_data, 0.0, 1.0) r8_data = 0.0 r8_converted = r4_data - r4_field = mk_field(r4_data, regDecomp = REG_DECOMP_DEFAULT, minIndex = [1, 1], & - maxIndex = [NROWS, NCOLS], indexflag = INDEX_FLAG_DEFAULT, & - name = 'XR4', _RC) - r8_field = mk_field(r8_data, regDecomp = REG_DECOMP_DEFAULT, minIndex = [1, 1], & - maxIndex = [NROWS, NCOLS], indexflag = INDEX_FLAG_DEFAULT, & - name = 'YR8', _RC) + r4_field = mk_field(r4_data, name = 'XR4', _RC) + r8_field = mk_field(r8_data, name = 'YR8', _RC) call FieldConvertPrec(r4_field, r8_field, _RC) call ESMF_FieldGet(r8_field, farrayPtr = r8_pointer, _RC) @assertEqual(r8_converted, r8_pointer) @@ -427,47 +415,3 @@ contains end subroutine test_almost_equal_array end module Test_FieldBLAS -! @Test(npes=product(REG_DECOMP_DEFAULT)) -! ! -! subroutine test_FieldGEMV_R4() -! real(kind=ESMF_KIND_R4), parameter :: alpha = 3.0 -! real(kind=ESMF_KIND_R4), parameter :: A(*,*,*) -! type(ESMF_Field) :: x -! real(kind=ESMF_KIND_R4), parameter :: beta = 2.0 -! type(ESMF_Field) :: y -! real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: x_array -! real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: x_ptr -! real(kind=ESMF_KIND_R8), dimension(:,:), allocatable :: y_array -! real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: y_ptr -! integer :: status, rc - -! allocate(x_array, source = R4_ARRAY_DEFAULT) -! allocate(y_array, source = R4_ARRAY_DEFAULT) -! y_array = y_array + 100 - -! do while(.TRUE.) -! x = mk_field(x_array, _RC) -! if(status /= ESMF_SUCCESS) exit - -! y = mk_field(y_array, _RC) -! if(status /= ESMF_SUCCESS) exit - -! call FieldAXPY(a, x, y, _RC) -! if(status /= ESMF_SUCCESS) exit -! -! call ESMF_FieldGet(x, farrayPtr = x_ptr, _RC) -! if(status /= ESMF_SUCCESS) exit - -! call ESMF_FieldGet(y, farrayPtr = y_ptr, _RC) -! if(status /= ESMF_SUCCESS) exit - -! @assertEqual(y_ptr, a*x_array+y_array) -! exit -! end do -! -! end subroutine test_FieldGEMV_R4 - -! @Test(npes=product(REG_DECOMP_DEFAULT)) -! ! -! subroutine test_FieldSpread() -! end subroutine test_FieldSpread diff --git a/field_utils/tests/field_utils_setup.F90 b/field_utils/tests/field_utils_setup.F90 index 76cd290e4ee2..2afcabf73a96 100644 --- a/field_utils/tests/field_utils_setup.F90 +++ b/field_utils/tests/field_utils_setup.F90 @@ -44,11 +44,7 @@ module field_utils_setup contains ! MAKE GRID FOR FIELDS - function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result(grid) - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag + function mk_grid(grid_name, rc) result(grid) character(len=*), intent(in) :: grid_name integer, optional, intent(out) :: rc @@ -56,16 +52,12 @@ function mk_grid(regDecomp, minIndex, maxIndex, indexflag, grid_name, rc) result integer :: status - grid = ESMF_GridCreateNoPeriDim(countsPerDeDim1=[2,2], countsPerDeDim2=[2,2], indexflag = indexflag, name = grid_name, _RC) + grid = ESMF_GridCreateNoPeriDim(countsPerDeDim1=[2,2], countsPerDeDim2=[2,2], indexflag=INDEX_FLAG_DEFAULT, name = grid_name, _RC) _RETURN(_SUCCESS) end function mk_grid - function mk_field_r4_ungrid(regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag + function mk_field_r4_ungrid(name, ungriddedLBound, ungriddedUBound, rc) result(field) character(len=*), intent(in) :: name integer, optional, intent(in) :: ungriddedLBound(:) integer, optional, intent(in) :: ungriddedUBound(:) @@ -75,17 +67,13 @@ function mk_field_r4_ungrid(regDecomp, minIndex, maxIndex, indexflag, name, ungr integer :: status - field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) + field = mk_field_common(tk = ESMF_TYPEKIND_R4, name = name, ungriddedLBound=ungriddedLBound, ungriddedUBound=ungriddedUBound, _RC) _RETURN(_SUCCESS) end function mk_field_r4_ungrid - function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r4_2d(farray, name, rc) result(field) real(kind=ESMF_KIND_R4), dimension(:,:), target, intent(in) :: farray - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name integer, optional, intent(out) :: rc @@ -94,7 +82,7 @@ function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, integer :: status - field = mk_field_common(tk = ESMF_TYPEKIND_R4, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + field = mk_field_common(tk = ESMF_TYPEKIND_R4, name = name, _RC) call ESMF_FieldGet(field, farrayPtr = ptr, _RC) ptr = farray @@ -102,12 +90,8 @@ function mk_field_r4_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, _RETURN(_SUCCESS) end function mk_field_r4_2d - function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, rc) result(field) + function mk_field_r8_2d(farray, name, rc) result(field) real(kind=ESMF_KIND_R8), dimension(:,:), target, intent(in) :: farray - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name integer, optional, intent(out) :: rc @@ -116,19 +100,15 @@ function mk_field_r8_2d(farray, regDecomp, minIndex, maxIndex, indexflag, name, integer :: status - field = mk_field_common(tk = ESMF_TYPEKIND_R8, regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, name = name, _RC) + field = mk_field_common(tk = ESMF_TYPEKIND_R8, name = name, _RC) call ESMF_FieldGet(field, farrayPtr = ptr, _RC) ptr = farray _RETURN(_SUCCESS) end function mk_field_r8_2d - function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ungriddedLBound, ungriddedUBound, rc) result(field) + function mk_field_common(tk, name, ungriddedLBound, ungriddedUBound, rc) result(field) type(ESMF_TypeKind_Flag), intent(in) :: tk - integer, dimension(:), intent(in) :: regDecomp - integer, dimension(:), intent(in) :: minIndex - integer, dimension(:), intent(in) :: maxIndex - type(ESMF_Index_Flag), intent(in) :: indexflag character(len=*), intent(in) :: name integer, optional, intent(in) :: ungriddedLBound(:) integer, optional, intent(in) :: ungriddedUBound(:) @@ -141,7 +121,7 @@ function mk_field_common(tk, regDecomp, minIndex, maxIndex, indexflag, name, ung integer :: status real, pointer :: fptr(:,:) - grid = mk_grid(regDecomp=regDecomp, minIndex=minIndex, maxIndex=maxIndex, indexflag = indexflag, grid_name = name // GRID_SUFFIX, _RC) + grid = mk_grid(grid_name = name // GRID_SUFFIX, _RC) field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) _RETURN(_SUCCESS) @@ -193,8 +173,7 @@ function mk_r4field(r4array, field_name, rc) result(r4field) integer :: status - r4field = mk_field(r4array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, & - maxIndex=MAX_INDEX_DEFAULT, indexflag=INDEX_FLAG_DEFAULT, name = field_name, _RC) + r4field = mk_field(r4array, name = field_name, _RC) _RETURN(_SUCCESS) @@ -208,8 +187,7 @@ function mk_r8field(r8array, field_name, rc) result(r8field) integer :: status - r8field = mk_field(r8array, regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, & - maxIndex=MAX_INDEX_DEFAULT, indexflag=INDEX_FLAG_DEFAULT, name = field_name, _RC) + r8field = mk_field(r8array, name = field_name, _RC) _RETURN(_SUCCESS) From df2e2f6f9bbcf818db40705b8908acd1d0b43e52 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 7 Feb 2024 10:14:09 -0500 Subject: [PATCH 78/86] Add INSTALL.md --- CHANGELOG.md | 1 + INSTALL.md | 172 +++++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 6 ++ 3 files changed, 179 insertions(+) create mode 100644 INSTALL.md diff --git a/CHANGELOG.md b/CHANGELOG.md index 11126a66ac4d..faa7b5a031f4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -21,6 +21,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Added memory utility, MAPL_MemReport that can be used in any code linking MAPL - Added capability in XY grid factory to add a mask to the grid any points are missing needed for geostationary input data - Added capability in the MAPL ESMF regridding wrapper to apply a destination mask if the destination grid contains a mask +- Added `INSTALL.md` file to provide instructions on how to install MAPL ### Changed diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 index 000000000000..b6a1455cfeb8 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,172 @@ +# MAPL Installation Instructions + +## Dependent Libraries + +### Compilers + +MAPL requires a Fortran 2003 compliant compiler. It is currently tested and +supported with: + +- Intel Fortran Classic `ifort` 2021.6.0 +- GCC 12.3.0 +- NAG Fortran 7.1.43 + +Note that at present MAPL does not fully support GCC 13, Intel Fortran Classic +2021.10.0+, Intel LLVM `ifx`, or NVHPC. Efforts are underway to support these. + +### MPI + +MAPL requires MPI and has been tested to run with: + +- Open MPI +- Intel MPI +- MPICH 4 (only MAPL 2.41 and higher) +- MVAPICH2 + +### Libraries + +MAPL currently depends on many libraries for full use of its capabilities. These include: + +- ESMF + - netCDF-Fortran + - netCDF-C + - HDF5 +- UDUNITS2 +- GFE + - gFTL + - gFTL-shared + - fArgParse + - pFUnit (for unit testing) + - yaFyaml + - pFlogger + +MAPL is currently tested with the following library versions: + +| Package | Tested Version | +|:---------------|:---------------| +| HDF5 | v1.10.11 | +| netCDF-C | v4.9.2 | +| netCDF-Fortran | v4.6.1 | +| UDUNITS2 | v2.2.28 | +| ESMF | v8.6.0 | +| GFE | v1.12.0 | + +Note that in most cases, MAPL will support *higher* versions of these libraries +(e.g., HDF5 1.14), it's just operationally we have not moved to them and fully +tested it. + +#### GFE Library Versions + +While obtaining GFE libraries via GFE itself is simplest, GFE v1.12.0 is equivalent to the following library versions: + +| Package | Version | +| :------ | :------ | +| gFTL | v1.11.0 | +| gFTL-shared | v1.7.0 | +| fArgParse | v1.6.0 | +| pFUnit | v4.8.0 | +| yaFyaml | v1.2.0 | +| pFlogger | v1.11.0 | + +#### ESMA Baselibs + +The above libraries are equivalent to ESMA-Baselibs v7.17.2. This is used +internally by GEOS-ESM users at the GMAO. + +## Getting MAPL + +### Obtaining MAPL from git clone + +Obtaining MAPL via a `git clone` is a bit complex due to how we handle +sub-repositories. Rather than use Git submodules or +ExternalProject/FetchContent, we use a homegrown tool called +[`mepo`](https://github.com/GEOS-ESM/mepo/) to manage them. `mepo` uses the +`components.yaml` file to know what tag of each sub-repository to clone, where +to put it, and what to name it. + +`mepo` is a fairly simple Python3 tool. All a user needs to do is clone the +`mepo` repo which provides executable `mepo` script that just needs Python3 +and PyYAML. Then you can run `mepo clone` in your MAPL clone and you'll get +three subrepos: + +- [ESMA_env](https://github.com/GEOS-ESM/ESMA_env) + - This is we use internally to control our compilers, libraries, etc. for external users it's a bit of a no-op +- [ESMA_cmake](https://github.com/GEOS-ESM/ESMA_cmake) + - This has most of our CMake controls, macros, etc. +- [ecbuild](https://github.com/GEOS-ESM/ecbuild) + - This is cloned within ESMA_cmake and gives us access to the ecbuild macros + +### Obtaining MAPL from a complete release tarfile + +A simpler way to obtain MAPL is to download a "complete" release tarfile from +the Releases page. Each release has a "complete" tarfile that has had the `mepo clone` +step run within it. This file will be named `MAPL-vX.YY.Z.COMPLETE.tar.xz` +where `X.YY.Z` is the version number of MAPL. We provide this for users that do +not want to deal with `mepo` or the sub-repositories. + +### Spack + +MAPL is also available via [spack](https://spack.io). The spack package is +maintained by GEOS-ESM and is used by external users to provide MAPL. As such, +it has many of the ideosyncracies of MAPL's clone-build-install process "baked" +into it. If you need MAPL-as-library, that could be an easier way to go by +running: +``` +spack install mapl +``` + +## Building MAPL + +Once you have all the dependent libraries, the build process should be pretty standard: + +``` +cmake -B build-dir -S . --install-prefix install-dir < -DCMAKE_Fortran_COMPILER=XXX > +cmake --build build-dir --target install -j N +``` +where `N` is the number of parallel build jobs you want to run. + +Note: If you have `FC` set in the environment, then there is no need for +`CMAKE_Fortran_COMPILER` but many environments do not provide `FC` and might +default to `gfortran` which might not be what you want. + +### Available CMake Options + +- `USE_EXTDATA2G` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL's ExtData2G library. All current GEOS-ESM projects + use ExtData2G (rather than the original ExtData) for reading external data. +- `USE_F2PY` (default: `ON`, recommended: `OFF`) + - If `ON`, will build an f2py-based interface to MAPL. This is not recommended + for general use, as f2py + CMake can be a challenge. +- `BUILD_SHARED_MAPL` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL as a shared library. If `OFF`, will build MAPL as + a static library. Note: unlike many packages, the `ON` option does not build + *both* a shared and static library. It builds *only* a shared library. +- `BUILD_WITH_FARGPARSE` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL with the `fArgParse` library. Much of MAPL's + utilities use `fArgParse` for command-line argument parsing. +- `BUILD_WITH_PFLOGGER` (default: `ON`, recommended: `ON`) + - If `ON`, will build MAPL with the `pFlogger` library. This is the logging + library used by MAPL and while not required yet, it is highly recommended. +- `INSTALL_SOURCE_TARFILE` (default: `OFF`, recommended: `OFF`) + - If `ON`, will install a tarfile of the source code in the install directory. + This is useful for users that want to have the source code as an "archive" + of what was built. +- `USE_CODATA_2018_CONSTANTS` (default: `OFF`, recommended: `OFF`) + - This option enables newer CODATA constants for use in MAPL. It is not + yet defaulted to `ON` as it would change answers in codes using MAPL's + constants. + +## Running MAPL Unit Tests + +If MAPL was built with pFUnit, then the unit tests can be run with: + +``` +ctest --test-dir build-dir -j N +``` +where `N` is the number of tests you want to run in parallel. + +Note that some MAPL tests are quite expensive to run. To avoid running them, +you can instead run: +``` +ctest --test-dir build-dir -j N -LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' +``` diff --git a/README.md b/README.md index 0d35086d038f..1f8785d98d5b 100644 --- a/README.md +++ b/README.md @@ -32,6 +32,12 @@ MAPL also has a variety of other auxiliary directories: 8. **benchmarks** - miscellaneous benchmarking scripts 9. **docs** - documentation +## Installing MAPL + +Please see the [INSTALL.md](INSTALL.md) file for instructions on how to install +MAPL. This also contains information on how to install the required dependencies +including subrepositories MAPL expects. + ## Using MAPL You can find simple examples on how to use MAPL components in ESMF applications at: From 39d0a820b1e6dc48c19242f3d883828c3c121903 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 7 Feb 2024 10:22:44 -0500 Subject: [PATCH 79/86] remove udunits2. only in MAPL3 --- INSTALL.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index b6a1455cfeb8..cebc6c1f1fda 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -31,7 +31,6 @@ MAPL currently depends on many libraries for full use of its capabilities. These - netCDF-Fortran - netCDF-C - HDF5 -- UDUNITS2 - GFE - gFTL - gFTL-shared @@ -47,7 +46,6 @@ MAPL is currently tested with the following library versions: | HDF5 | v1.10.11 | | netCDF-C | v4.9.2 | | netCDF-Fortran | v4.6.1 | -| UDUNITS2 | v2.2.28 | | ESMF | v8.6.0 | | GFE | v1.12.0 | From b0d26016d76f091933c2d478376c917ba261ce0d Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 7 Feb 2024 10:25:05 -0500 Subject: [PATCH 80/86] Add URLs --- INSTALL.md | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index cebc6c1f1fda..f8e796e7eba5 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -27,17 +27,17 @@ MAPL requires MPI and has been tested to run with: MAPL currently depends on many libraries for full use of its capabilities. These include: -- ESMF - - netCDF-Fortran - - netCDF-C - - HDF5 -- GFE - - gFTL - - gFTL-shared - - fArgParse - - pFUnit (for unit testing) - - yaFyaml - - pFlogger +- [ESMF](https://github.com/esmf-org/esmf) + - [netCDF-Fortran](https://github.com/Unidata/netcdf-fortran) + - [netCDF-C](https://github.com/Unidata/netcdf-c) + - [HDF5](https://github.com/HDFGroup/hdf5) +- [GFE](https://github.com/Goddard-Fortran-Ecosystem/GFE) + - [gFTL](https://github.com/Goddard-Fortran-Ecosystem/gFTL) + - [gFTL-shared](https://github.com/Goddard-Fortran-Ecosystem/gFTL-shared) + - [fArgParse](https://github.com/Goddard-Fortran-Ecosystem/fArgParse) + - [pFUnit](https://github.com/Goddard-Fortran-Ecosystem/pFUnit) (for unit testing) + - [yaFyaml](https://github.com/Goddard-Fortran-Ecosystem/yaFyaml) + - [pFlogger](https://github.com/Goddard-Fortran-Ecosystem/pFlogger) MAPL is currently tested with the following library versions: From db6efb5918f5868555ae3baa0fba0886c3306ad6 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 7 Feb 2024 11:04:15 -0500 Subject: [PATCH 81/86] Remove unneeded table --- INSTALL.md | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/INSTALL.md b/INSTALL.md index f8e796e7eba5..16696eec4d44 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -53,18 +53,6 @@ Note that in most cases, MAPL will support *higher* versions of these libraries (e.g., HDF5 1.14), it's just operationally we have not moved to them and fully tested it. -#### GFE Library Versions - -While obtaining GFE libraries via GFE itself is simplest, GFE v1.12.0 is equivalent to the following library versions: - -| Package | Version | -| :------ | :------ | -| gFTL | v1.11.0 | -| gFTL-shared | v1.7.0 | -| fArgParse | v1.6.0 | -| pFUnit | v4.8.0 | -| yaFyaml | v1.2.0 | -| pFlogger | v1.11.0 | #### ESMA Baselibs From 5a7bdd6de7de40aab61bcba29e9b478ce91f4889 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 7 Feb 2024 11:43:48 -0500 Subject: [PATCH 82/86] Fix npes args ; funit=>pfunit; remove unused vars --- field_utils/tests/Test_FieldArithmetic.pf | 49 ++++++++++++++--------- field_utils/tests/field_utils_setup.F90 | 18 ++++----- 2 files changed, 37 insertions(+), 30 deletions(-) diff --git a/field_utils/tests/Test_FieldArithmetic.pf b/field_utils/tests/Test_FieldArithmetic.pf index 7f02be3fed01..b3302c0401ce 100644 --- a/field_utils/tests/Test_FieldArithmetic.pf +++ b/field_utils/tests/Test_FieldArithmetic.pf @@ -8,7 +8,7 @@ module Test_FieldArithmetic use MAPL_FieldUtilities use MAPL_FieldPointerUtilities use ESMF - use funit + use pfunit use MAPL_ExceptionHandling implicit none @@ -21,8 +21,8 @@ contains ! Making the fields should be done in the tests themselves so because ! of the npes argument. @Before - subroutine set_up_data() - implicit none + subroutine set_up_data(this) + class(MpiTestMethod), intent(inout) :: this integer :: status, rc @@ -46,8 +46,14 @@ contains end subroutine set_up_data - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldAddR4() + @after + subroutine teardown(this) + class(MpiTestMethod), intent(inout) :: this + end subroutine teardown + + @Test(npes=[4]) + subroutine test_FieldAddR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) @@ -70,11 +76,9 @@ contains end subroutine test_FieldAddR4 - ! Rather than use the fields created in setup, make the fields - ! in this subroutine to make sure that the npes match the - ! regDecomp. - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldAddR4_missing + @Test(npes=[4]) + subroutine test_FieldAddR4_missing(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:), y_ptr(:,:) @@ -94,8 +98,9 @@ contains @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR4_missing - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldAddR8() + @Test(npes=[4]) + subroutine test_FieldAddR8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x type(ESMF_Field) :: y real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:), y_ptr(:,:) @@ -117,8 +122,9 @@ contains @assertEqual(y_ptr, result_array) end subroutine test_FieldAddR8 - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldPowR4() + @Test(npes=[4]) + subroutine test_FieldPowR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) @@ -136,8 +142,9 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR4 - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldPowR8() + @Test(npes=[4]) + subroutine test_FieldPowR8(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R8), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R8), allocatable :: result_array(:,:) @@ -155,8 +162,9 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldPowR8 - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldSinR4() + @Test(npes=[4]) + subroutine test_FieldSinR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) @@ -172,8 +180,9 @@ contains @assertEqual(x_ptr, result_array) end subroutine test_FieldSinR4 - @Test(npes=product(REG_DECOMP_DEFAULT)) - subroutine test_FieldNegR4() + @Test(npes=[4]) + subroutine test_FieldNegR4(this) + class(MpiTestMethod), intent(inout) :: this type(ESMF_Field) :: x real(kind=ESMF_KIND_R4), pointer :: x_ptr(:,:) real(kind=ESMF_KIND_R4), allocatable :: result_array(:,:) diff --git a/field_utils/tests/field_utils_setup.F90 b/field_utils/tests/field_utils_setup.F90 index 2afcabf73a96..967753e98c3c 100644 --- a/field_utils/tests/field_utils_setup.F90 +++ b/field_utils/tests/field_utils_setup.F90 @@ -20,13 +20,13 @@ module field_utils_setup integer :: i type(ESMF_Index_Flag), parameter :: INDEX_FLAG_DEFAULT = ESMF_INDEX_DELOCAL - integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] - integer, parameter :: MAX_INDEX_DEFAULT(*) = [2, 2] - integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] - integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] - integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] - integer, parameter :: SIZE_R4 = 16 - integer, parameter :: SIZE_R8 = 16 +! integer, parameter :: REG_DECOMP_DEFAULT(*) = [2, 2] !wdb delete +! integer, parameter :: MAX_INDEX_DEFAULT(*) = [2, 2] !wdb delete +! integer, parameter :: MIN_INDEX_DEFAULT(*) = [1, 1] !wdb delete +! integer, parameter :: DIMR4_DEFAULT(*) = [4, 4] !wdb delete +! integer, parameter :: DIMR8_DEFAULT(*) = [4, 4] !wdb delete +! integer, parameter :: SIZE_R4 = 16 !wdb delete +! integer, parameter :: SIZE_R8 = 16 !wdb delete real, parameter :: undef = 42.0 real(kind=ESMF_KIND_R4), parameter :: R4_ARRAY_DEFAULT(*,*) = reshape([(i, i = 1, 4)], [2,2]) @@ -119,7 +119,6 @@ function mk_field_common(tk, name, ungriddedLBound, ungriddedUBound, rc) result( type(ESMF_Field) :: field type(ESMF_Grid) :: grid integer :: status - real, pointer :: fptr(:,:) grid = mk_grid(grid_name = name // GRID_SUFFIX, _RC) field = ESMF_FieldCreate(grid, typekind = tk, name = name // FIELD_SUFFIX, ungriddedLBound = ungriddedLBound, ungriddedUBound = ungriddedUBound, _RC) @@ -202,8 +201,7 @@ function mk_r4ungrid_field(field_name, lbound, ubound, rc) result(r4field) integer :: status - r4field = mk_field_r4_ungrid(regDecomp=REG_DECOMP_DEFAULT, minIndex=MIN_INDEX_DEFAULT, maxIndex=MAX_INDEX_DEFAULT, & - indexflag=INDEX_FLAG_DEFAULT, name = field_name, ungriddedLBound=[lbound],ungriddedUBound=[ubound],_RC) + r4field = mk_field_r4_ungrid(name = field_name, ungriddedLBound=[lbound],ungriddedUBound=[ubound],_RC) _RETURN(_SUCCESS) From cefa47c1030004915e0e957c791a399579e5791e Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 7 Feb 2024 12:08:27 -0500 Subject: [PATCH 83/86] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 11126a66ac4d..3242edfe9694 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -49,6 +49,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 we anticipate this here - Add explicit `Fortran_MODULE_DIRECTORY` to `CMakeLists.txt` in benchmarks to avoid race condition in Ninja builds - Add check to make sure ESMF was not built as `mpiuni` +- Fixed failing tests for `field_utils`. ### Removed From ef867a17e1d17a34f0d416e4e08e1e9a02828785 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 8 Feb 2024 12:33:32 -0500 Subject: [PATCH 84/86] Update gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 --- gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index 0ff9bd14b4a0..d266b34e1f93 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -647,7 +647,6 @@ if (mapl_am_I_root()) then ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time - !call sort_multi_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) call ESMF_ClockGet(this%clock,currTime=current_time,_RC) timeset(1) = current_time From 54a944183f8882aa02adcc4158aa8b87165fcee8 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 8 Feb 2024 12:34:49 -0500 Subject: [PATCH 85/86] Update generic/OpenMP_Support.F90 --- generic/OpenMP_Support.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/OpenMP_Support.F90 b/generic/OpenMP_Support.F90 index a00d53e3c4b8..c2742a6c9a6c 100644 --- a/generic/OpenMP_Support.F90 +++ b/generic/OpenMP_Support.F90 @@ -605,7 +605,6 @@ subroutine copy_callbacks(state, multi_states, rc) do while (iter /= e) wrapper => iter%second() do i = 1, n_multi - !call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=wrapper%userRoutine, _RC) userRoutine => wrapper%userRoutine call ESMF_MethodAdd(multi_states(i), label=iter%first(), userRoutine=userRoutine, _RC) end do From fc051cfd00578f8f2b1dd8d37f23af5ebde975c5 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 8 Feb 2024 15:33:43 -0500 Subject: [PATCH 86/86] Prepare for 2.44.0 Release --- CHANGELOG.md | 17 ++++++++++++----- CMakeLists.txt | 2 +- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3520bc922563..6dcd08ebfdcf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,18 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +### Changed + +### Fixed + +### Removed + +### Deprecated + +## [2.44.0] - 2024-02-08 + +### Added + - Added nf90 interface to read and write 1d string - Convert from ABI Fixed Grid to lon/lat coordinates used in MAPL_XYGridFactory (supporting geostationary GOES-R series) - Modify trajectory sampler for a collection with multiple platforms: P3B (air craft) + FIREX @@ -53,11 +65,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Fixed failing tests for `field_utils`. - Various fixes for NVHPC work - -### Removed - -### Deprecated - ## [2.43.2] - 2024-02-06 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 501be67d6dcc..5e2df2da13e6 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.43.2 + VERSION 2.44.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui