From 9468c66e2598db4a9e0652133532bfcbe8f2fdd5 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Tue, 3 Jan 2023 14:03:07 -0500 Subject: [PATCH 01/83] pmn: first attemp at SunGetLocalSolarHourAngle function --- base/MAPL_sun_uc.F90 | 141 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 141 insertions(+) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index f964b7d7f34..f116f17d0b0 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -41,6 +41,7 @@ module MAPL_SunMod public MAPL_SunGetSolarConstant public MAPL_SunGetDaylightDuration public MAPL_SunGetDaylightDurationMax + public MAPL_SunGetLocalSolarHourAngle ! !PUBLIC TYPES: @@ -2979,4 +2980,144 @@ end subroutine MAPL_SunGetDaylightDurationMax !========================================================================== +!BOPI + +! !IROUTINE: MAPL_SunGetLocalSolarHourAngle + +! !DESCRIPTION: + +! Returns the local solar hour angle (in radians) at the single time and +! multiple longitudes specified. In order of preference, time is taken +! from TIME, if present, or else the CURRTIME of CLOCK, if present, or +! else the CURRTIME of the ORBIT's associated clock. +! NB: For accurate results, ensure the ORBIT has the EOT flag set true. + +! !INTERFACE: + + subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) + +! !ARGUMENTS: + + type (MAPL_SunOrbit), intent(IN ) :: ORBIT + real, dimension(:), intent(IN ) :: LONS ! [radians] + logical, dimension(:), intent(OUT) :: LSHA + type (ESMF_Time), optional, intent(IN ) :: TIME + type (ESMF_Clock), optional, intent(IN ) :: CLOCK + integer, optional, intent(OUT) :: RC + +! !EXAMPLE OF USE: +! +! ! detecting noon within the current timestep +! type (ESMF_Time) :: NOW +! type (ESMF_TimeInterval) :: DELT +! real, dimension(size(LONS)) :: LSHA0, LSHA1 +! logical, dimension(size(LONS)) :: isNoon +! call ESMF_ClockGet (CLOCK, CURRTIME=NOW, TIMESTEP=DELT, __RC__) +! call MAPL_SunGetLocalSolarHourAngle (ORBIT, LONS, LSHA0, TIME=NOW, __RC__) +! call MAPL_SunGetLocalSolarHourAngle (ORBIT, LONS, LSHA1, TIME=NOW+DELT, __RC__) +! isnoon = (LSHA0 <= 0. .and. LSHA1 > 0.) + +!EOPI + +! Locals + + character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_SunGetLocalSolarHourAngle" + integer :: STATUS + + type (ESMF_Time) :: T + real (ESMF_KIND_R8) :: days + integer :: YEAR, SEC_OF_DAY, DAY_OF_YEAR, IDAY, IDAYP1 + real :: DFRAC, GSHA + real :: ECC, OBQ, LAMBDAP + real :: OMECC, OPECC, OMSQECC, EAFAC + real :: MA, EA, dE, TA, LAMBDA + real :: RT, RM, ET + integer :: i, nits + +! Begin + + _ASSERT (MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') + + ! Which time? + if (present(TIME)) then + T = TIME + else + if (present(CLOCK)) then + call ESMF_ClockGet ( CLOCK, CURRTIME=T, RC=STATUS) + _VERIFY(STATUS) + else + call ESMF_ClockGet (ORBIT%CLOCK, CURRTIME=T, RC=STATUS) + _VERIFY(STATUS) + end if + end if + call ESMF_TimeGet (T, S=SEC_OF_DAY, RC=STATUS) + _VERIFY(STATUS) + + ! fraction of day (0 at midnight) + DFRAC = real(SEC_OF_DAY) / 86400. + + ! Greenwich MEAN solar hour angle (zero at noon) + GSHA = 2. * MAPL_PI * (DFRAC - 0.5) + + ! Apply equation of time correction? + if (ORBIT%EOT) then + + if (ORBIT%ANAL2B) then + + ! include time variation in orbit from reference time + call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_REF, d_r8=days, RC=STATUS) + _VERIFY(STATUS) + ECC = ORBIT%ORB2B_ECC_REF + days * ORBIT%ORB2B_ECC_RATE + OBQ = ORBIT%ORB2B_OBQ_REF + days * ORBIT%ORB2B_OBQ_RATE + LAMBDAP = ORBIT%ORB2B_LAMBDAP_REF + days * ORBIT%ORB2B_LAMBDAP_RATE + ! derived quantities + OMECC = 1. - ECC + OPECC = 1. + ECC + OMSQECC = OMECC * OPECC + EAFAC = sqrt(OMECC/OPECC) + ! time interval since perhelion in days + call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_PERI, d_r8=days, RC=STATUS) + _VERIFY(STATUS) + ! mean anomaly + MA = ORBIT%ORB2B_OMG0 * days + ! eccentric anomaly + call invert_Keplers_Newton (MA,ECC,EA,dE,nits) + ! true anomaly + TA = calcTAfromEA (EA,EAFAC) + ! celestial longitude + LAMBDA = TA + LAMBDAP + ! solar right ascension (true and mean) + RT = atan2(sin(LAMBDA)*cos(OBQ),cos(LAMBDA)) + RM = MA + LAMBDAP + ! equation of time + ET = RECT_PMPI (RM - RT) + + else + + ! get equation of time by from table interpolation + call ESMF_TimeGet (T, YY=YEAR, dayOfYear=DAY_OF_YEAR, RC=STATUS) + _VERIFY(STATUS) + YEAR = mod(YEAR-1,ORBIT%YEARS_PER_CYCLE) + IDAY = YEAR*int(ORBIT%YEARLEN)+DAY_OF_YEAR + IDAYP1 = mod(IDAY,ORBIT%DAYS_PER_CYCLE) + 1 + ET = ORBIT%ET(IDAYP1)*DFRAC + ORBIT%ET(IDAY)*(1.-DFRAC) + + endif + + ! Gives Greenwich TRUE solar hour angle + GSHA = GSHA + ET + + end if ! EOT correction + + ! LOCAL solar hour angle + do i = 1, size(LONS) + LSHA(i) = RECT_PMPI (GSHA + LONS(i)) + end do + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_SunGetLocalSolarHourAngle + +!========================================================================== + end module MAPL_SunMod From e3eab8e5aed23bb8f9679f273a4d77c4f0ed3b7d Mon Sep 17 00:00:00 2001 From: adarmenov <47391100+adarmenov@users.noreply.github.com> Date: Wed, 4 Jan 2023 15:40:59 -0500 Subject: [PATCH 02/83] Update MAPL_sun_uc.F90 Correct the type of the local solar hour angle (LSHA) argument. --- base/MAPL_sun_uc.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index f116f17d0b0..1bc1dfbe34e 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -3000,7 +3000,7 @@ subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) type (MAPL_SunOrbit), intent(IN ) :: ORBIT real, dimension(:), intent(IN ) :: LONS ! [radians] - logical, dimension(:), intent(OUT) :: LSHA + real, dimension(:), intent(OUT) :: LSHA type (ESMF_Time), optional, intent(IN ) :: TIME type (ESMF_Clock), optional, intent(IN ) :: CLOCK integer, optional, intent(OUT) :: RC From 02790cb6f3e66598f0f87319fe1e81f5935f33b4 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Wed, 4 Jan 2023 18:06:45 -0500 Subject: [PATCH 03/83] pmn: bug fix --- base/MAPL_sun_uc.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index 1bc1dfbe34e..5b05c58bcf9 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -3050,7 +3050,10 @@ subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) _VERIFY(STATUS) end if end if - call ESMF_TimeGet (T, S=SEC_OF_DAY, RC=STATUS) + + ! NB: include YY and dayOfYear here so that S is seconds WITHIN a day. + ! YEAR and DAY_OF_YEAR are used within the non-ANAL2B branch anyway. + call ESMF_TimeGet (T, YY=YEAR, dayOfYear=DAY_OF_YEAR, S=SEC_OF_DAY, RC=STATUS) _VERIFY(STATUS) ! fraction of day (0 at midnight) @@ -3094,9 +3097,7 @@ subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) else - ! get equation of time by from table interpolation - call ESMF_TimeGet (T, YY=YEAR, dayOfYear=DAY_OF_YEAR, RC=STATUS) - _VERIFY(STATUS) + ! get equation of time by table interpolation YEAR = mod(YEAR-1,ORBIT%YEARS_PER_CYCLE) IDAY = YEAR*int(ORBIT%YEARLEN)+DAY_OF_YEAR IDAYP1 = mod(IDAY,ORBIT%DAYS_PER_CYCLE) + 1 From c1e8fe77bd084f62f9d7b1ddb5a91dd94b73e544 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Thu, 5 Jan 2023 23:09:39 +0000 Subject: [PATCH 04/83] Bump actions/checkout from 3.2.0 to 3.3.0 Bumps [actions/checkout](https://github.com/actions/checkout) from 3.2.0 to 3.3.0. - [Release notes](https://github.com/actions/checkout/releases) - [Changelog](https://github.com/actions/checkout/blob/main/CHANGELOG.md) - [Commits](https://github.com/actions/checkout/compare/v3.2.0...v3.3.0) --- updated-dependencies: - dependency-name: actions/checkout dependency-type: direct:production update-type: version-update:semver-minor ... Signed-off-by: dependabot[bot] --- .github/workflows/push-to-develop.yml | 2 +- .github/workflows/push-to-main.yml | 2 +- .github/workflows/release-tarball.yml | 4 ++-- .github/workflows/validate_yaml_files.yml | 2 +- .github/workflows/workflow.yml | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml index 26351cbd5f0..cea02428d49 100644 --- a/.github/workflows/push-to-develop.yml +++ b/.github/workflows/push-to-develop.yml @@ -11,7 +11,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout repo - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 0 - name: Run the action diff --git a/.github/workflows/push-to-main.yml b/.github/workflows/push-to-main.yml index aded8b19cc3..ab955b6be68 100644 --- a/.github/workflows/push-to-main.yml +++ b/.github/workflows/push-to-main.yml @@ -11,7 +11,7 @@ jobs: runs-on: ubuntu-latest steps: - name: Checkout repo - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 0 - name: Run the action diff --git a/.github/workflows/release-tarball.yml b/.github/workflows/release-tarball.yml index 732280a0260..41f2838932a 100644 --- a/.github/workflows/release-tarball.yml +++ b/.github/workflows/release-tarball.yml @@ -10,12 +10,12 @@ jobs: steps: - name: Checkout - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: path: ${{ github.event.repository.name }}-${{ github.event.release.tag_name }} - name: Checkout mepo - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: repository: GEOS-ESM/mepo path: mepo diff --git a/.github/workflows/validate_yaml_files.yml b/.github/workflows/validate_yaml_files.yml index 1b475fc4e4a..86df2bb00b7 100644 --- a/.github/workflows/validate_yaml_files.yml +++ b/.github/workflows/validate_yaml_files.yml @@ -15,7 +15,7 @@ jobs: validate-YAML: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3.2.0 + - uses: actions/checkout@v3.3.0 - id: yaml-lint name: yaml-lint uses: ibiqlik/action-yamllint@v3 diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 22b5f5c2c19..ac6ebd4acf3 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -34,7 +34,7 @@ jobs: with: access_token: ${{ github.token }} - name: Checkout - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 1 - name: Set all directories as git safe @@ -90,7 +90,7 @@ jobs: with: access_token: ${{ github.token }} - name: Checkout - uses: actions/checkout@v3.2.0 + uses: actions/checkout@v3.3.0 with: fetch-depth: 1 - name: Set all directories as git safe From 8cb2933f1696fd9b471a2dc1f6c71e46b204abef Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 6 Jan 2023 23:55:02 -0500 Subject: [PATCH 05/83] fix typo in the range of halo in LatLonGridfactory --- CHANGELOG.md | 2 ++ base/MAPL_LatLonGridFactory.F90 | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2a7c1d95664..342eb901cfc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Fixed range in halo of LatLonGridFactory + ### Removed ### Deprecated diff --git a/base/MAPL_LatLonGridFactory.F90 b/base/MAPL_LatLonGridFactory.F90 index f4df37d7cad..370cbc2f655 100644 --- a/base/MAPL_LatLonGridFactory.F90 +++ b/base/MAPL_LatLonGridFactory.F90 @@ -1718,8 +1718,8 @@ subroutine fill_east(array, rc) integer :: len, last - last = size(array,2)-1 - len = size(array,1) + last = size(array,1)-1 + len = size(array,2) call MAPL_CommsSendRecv(this%layout, & array(2 , : ), len, pet_west, & From fb9e000542e0a14a3426ea44e7f8f1599383c7c0 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Sat, 7 Jan 2023 19:04:20 -0500 Subject: [PATCH 06/83] more bugs on fill_east of halo --- base/MAPL_LatLonGridFactory.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/base/MAPL_LatLonGridFactory.F90 b/base/MAPL_LatLonGridFactory.F90 index 370cbc2f655..e6fb433a1a4 100644 --- a/base/MAPL_LatLonGridFactory.F90 +++ b/base/MAPL_LatLonGridFactory.F90 @@ -1744,8 +1744,8 @@ subroutine fill_west(array, rc) len = size(array,2) call MAPL_CommsSendRecv(this%layout, & - array(last , : ), len, pet_west, & - array(1 , : ), len, pet_east, & + array(last , : ), len, pet_east, & + array(1 , : ), len, pet_west, & rc=status) _VERIFY(status) From 4425dbf48299b72d4cd2481431c41171a943e995 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 9 Jan 2023 09:08:59 -0500 Subject: [PATCH 07/83] correct values in the halo corner of LatLon --- CHANGELOG.md | 1 + base/MAPL_LatLonGridFactory.F90 | 50 +++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 342eb901cfc..3b1a5cc799d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -13,6 +13,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Added the correct values to halo corner of LatLon grid - Fixed range in halo of LatLonGridFactory ### Removed diff --git a/base/MAPL_LatLonGridFactory.F90 b/base/MAPL_LatLonGridFactory.F90 index e6fb433a1a4..8cbba70dccc 100644 --- a/base/MAPL_LatLonGridFactory.F90 +++ b/base/MAPL_LatLonGridFactory.F90 @@ -1617,6 +1617,8 @@ subroutine halo(this, array, unusable, halo_width, rc) integer :: pet_south integer :: pet_east integer :: pet_west + integer :: pet_N_E, pet_N_W, pet_S_E, pet_S_W + integer :: last_lon, last_lat _UNUSED_DUMMY(unusable) ! not yet implmented, default is 1 @@ -1627,6 +1629,9 @@ subroutine halo(this, array, unusable, halo_width, rc) _VERIFY(status) end if + last_lon = size(array,1) + last_lat = size(array,2) + associate (nx => this%nx, ny => this% ny, px => this%px, py => this%py) ! Nearest neighbors processor' ids pet_north = get_pet(px, py+1, nx, ny) @@ -1644,6 +1649,51 @@ subroutine halo(this, array, unusable, halo_width, rc) call fill_west(array, rc=status) _VERIFY(status) + pet_N_E = get_pet(px+1, py+1, nx, ny) + pet_N_W = get_pet(px-1, py+1, nx, ny) + pet_S_E = get_pet(px+1, py-1, nx, ny) + pet_S_W = get_pet(px-1, py-1, nx, ny) + + !fill north east + call MAPL_CommsSendRecv(this%layout, & + array(2, 2 ), 1, pet_S_W, & + array(last_lon,last_lat ), 1, pet_N_E, & + rc=status) + _VERIFY(status) + + !fill north west + call MAPL_CommsSendRecv(this%layout, & + array(last_lon-1, 2), 1, pet_S_E, & + array(1, last_lat), 1, pet_N_W, & + rc=status) + _VERIFY(status) + + ! north pol corner + if(this%py== this%ny-1) then + array(last_lon,last_lat) = array(last_lon-1,last_lat-1) + array(1,last_lat) = array(2,last_lat-1) + endif + + !fill south east + call MAPL_CommsSendRecv(this%layout, & + array(2, last_lat-1), 1, pet_N_W, & + array(last_lon,1), 1, pet_S_E, & + rc=status) + _VERIFY(status) + + !fill south west + call MAPL_CommsSendRecv(this%layout, & + array(last_lon-1,last_lat-1), 1, pet_N_E, & + array(1,1 ), 1, pet_S_W, & + rc=status) + _VERIFY(status) + + ! south pole corner + if(this%py==0) then + array(last_lon,1 ) = array(last_lon-1,2 ) + array(1,1 ) = array(2,2 ) + endif + end associate _RETURN(ESMF_SUCCESS) From 6a80583cd0fbde4c771d8363c6ec7b7ab37fe2fe Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 9 Jan 2023 09:55:16 -0500 Subject: [PATCH 08/83] added senrecv real scalar --- base/MAPL_Comms.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 51d86ae8c74..aaa63fbb973 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -208,6 +208,7 @@ module MAPL_CommsMod interface MAPL_CommsSendRecv module procedure MAPL_CommsSendRecv_I4_0 + module procedure MAPL_CommsSendRecv_R4_0 module procedure MAPL_CommsSendRecv_R4_1 module procedure MAPL_CommsSendRecv_R4_2 module procedure MAPL_CommsSendRecv_R8_1 @@ -1479,6 +1480,11 @@ end subroutine MAPL_BcastShared_2DR4 #define VARTYPE_ 1 #include "sendrecv.H" +!--------------------------- +#define RANK_ 0 +#define VARTYPE_ 3 +#include "sendrecv.H" + !--------------------------- #define RANK_ 1 #define VARTYPE_ 3 From 91c426bb2f664f60f193169d2dfd086031c35308 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Mon, 9 Jan 2023 10:47:15 -0500 Subject: [PATCH 09/83] pmn: add FORCE_MLSHA optional argument --- base/MAPL_sun_uc.F90 | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index 5b05c58bcf9..f134a869d04 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -2990,11 +2990,23 @@ end subroutine MAPL_SunGetDaylightDurationMax ! multiple longitudes specified. In order of preference, time is taken ! from TIME, if present, or else the CURRTIME of CLOCK, if present, or ! else the CURRTIME of the ORBIT's associated clock. -! NB: For accurate results, ensure the ORBIT has the EOT flag set true. +! +! NB: For accurate results, namely to receive the TRUE local solar hour +! angle, ensure the ORBIT has the EOT flag set true. Conversely, to get +! only the MEAN local solar hour angle, use the optional argument +! FORCE_MLSHA=.TRUE.. This will turn off the Equation of Time correction +! (for this LSHA calculation only) even if the ORBIT includes it. For +! example, in the local noon detection in the EXAMPLE below, this will +! give mean local noons that are exactly 24 hours apart at a particular +! location. But they will no longer exactly be the solar culmination +! times (the TRUE local noon) in that case. TRUE local noons are not +! exactly 24h apart because of orbital variations in length of day +! throughout the year, as described by the Equation of Time. ! !INTERFACE: - subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) + subroutine MAPL_SunGetLocalSolarHourAngle (ORBIT,LONS,LSHA, & + TIME,CLOCK,FORCE_MLSHA,RC) ! !ARGUMENTS: @@ -3003,6 +3015,7 @@ subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) real, dimension(:), intent(OUT) :: LSHA type (ESMF_Time), optional, intent(IN ) :: TIME type (ESMF_Clock), optional, intent(IN ) :: CLOCK + logical, optional, intent(IN ) :: FORCE_MLSHA integer, optional, intent(OUT) :: RC ! !EXAMPLE OF USE: @@ -3033,8 +3046,7 @@ subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) real :: MA, EA, dE, TA, LAMBDA real :: RT, RM, ET integer :: i, nits - -! Begin + logical :: do_EOT _ASSERT (MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') @@ -3063,7 +3075,11 @@ subroutine MAPL_SunGetLocalSolarHourAngle(ORBIT,LONS,LSHA,TIME,CLOCK,RC) GSHA = 2. * MAPL_PI * (DFRAC - 0.5) ! Apply equation of time correction? - if (ORBIT%EOT) then + do_EOT = ORBIT%EOT + if (present(FORCE_MLSHA)) then + if (FORCE_MLSHA) do_EOT = .FALSE. + endif + if (do_EOT) then if (ORBIT%ANAL2B) then From 79a1513d109d222bcd1b0cb9e121d514198db11d Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 9 Jan 2023 11:03:47 -0500 Subject: [PATCH 10/83] Update base/MAPL_sun_uc.F90 --- base/MAPL_sun_uc.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index f134a869d04..4927d0a59c1 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -3055,11 +3055,9 @@ subroutine MAPL_SunGetLocalSolarHourAngle (ORBIT,LONS,LSHA, & T = TIME else if (present(CLOCK)) then - call ESMF_ClockGet ( CLOCK, CURRTIME=T, RC=STATUS) - _VERIFY(STATUS) + call ESMF_ClockGet ( CLOCK, CURRTIME=T, _RC) else - call ESMF_ClockGet (ORBIT%CLOCK, CURRTIME=T, RC=STATUS) - _VERIFY(STATUS) + call ESMF_ClockGet (ORBIT%CLOCK, CURRTIME=T, _RC) end if end if From b6d124f16ea0359a7cfa9c7ca4ff70a42a4bdd3d Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 9 Jan 2023 11:04:12 -0500 Subject: [PATCH 11/83] Update base/MAPL_sun_uc.F90 --- base/MAPL_sun_uc.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index 4927d0a59c1..37c9676cbd8 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -3082,8 +3082,7 @@ subroutine MAPL_SunGetLocalSolarHourAngle (ORBIT,LONS,LSHA, & if (ORBIT%ANAL2B) then ! include time variation in orbit from reference time - call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_REF, d_r8=days, RC=STATUS) - _VERIFY(STATUS) + call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_REF, d_r8=days, _RC) ECC = ORBIT%ORB2B_ECC_REF + days * ORBIT%ORB2B_ECC_RATE OBQ = ORBIT%ORB2B_OBQ_REF + days * ORBIT%ORB2B_OBQ_RATE LAMBDAP = ORBIT%ORB2B_LAMBDAP_REF + days * ORBIT%ORB2B_LAMBDAP_RATE From ea71f46b1584b28e6413e4378c00914c234e7a06 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 9 Jan 2023 11:04:38 -0500 Subject: [PATCH 12/83] Update base/MAPL_sun_uc.F90 --- base/MAPL_sun_uc.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index 37c9676cbd8..cd4b4306516 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -3092,8 +3092,7 @@ subroutine MAPL_SunGetLocalSolarHourAngle (ORBIT,LONS,LSHA, & OMSQECC = OMECC * OPECC EAFAC = sqrt(OMECC/OPECC) ! time interval since perhelion in days - call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_PERI, d_r8=days, RC=STATUS) - _VERIFY(STATUS) + call ESMF_TimeIntervalGet (T - ORBIT%ORB2B_TIME_PERI, d_r8=days, _RC) ! mean anomaly MA = ORBIT%ORB2B_OMG0 * days ! eccentric anomaly From 2f16dd350c41f3f13c30d1b901b5b721f3aacf29 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 9 Jan 2023 12:38:19 -0500 Subject: [PATCH 13/83] Update CHANGELOG.md --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 342eb901cfc..658a2d04ccf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,12 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This provides a +  convenient local solar hour angle diagnostic which will be used to detect local +  solar noon via the EXAMPLE OF USE in the subroutine header. See DESCRIPTION in code for more +  details. Provides the TRUE local solar hour angle (i.e., with equation of time included), but +  can also provide the MEAN value (without EOT) via FORCE_MLSHA=.TRUE. optional argument. + ### Changed ### Fixed From b9e7adf8d8342597898f68973c5000cfa4ee930c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 9 Jan 2023 13:40:50 -0500 Subject: [PATCH 14/83] Fixes #1912. Fixes for ACG Cmake code --- CHANGELOG.md | 1 + cmake/mapl_acg.cmake | 21 ++++++++++++++++++++- 2 files changed, 21 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 658a2d04ccf..fd5e0691501 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed - Fixed range in halo of LatLonGridFactory +- Fix bug in `mapl_acg.cmake` that caused unnecessary rebuilds ### Removed diff --git a/cmake/mapl_acg.cmake b/cmake/mapl_acg.cmake index d37f08eafc5..fe125c68770 100644 --- a/cmake/mapl_acg.cmake +++ b/cmake/mapl_acg.cmake @@ -44,7 +44,26 @@ function (mapl_acg target specs_file) list (APPEND options ${flag} ${ARGS_${opt}}) elseif (${opt} IN_LIST ARGS_KEYWORDS_MISSING_VALUES) string (REPLACE "{component}" component_name fname ${default}) - list (APPEND generated "${component_name}_${fname}${suffix_for_generated_include_files}") + + # What the ACG does is take the specs_file and then removes the extension and then + # it removes both "_Registry" and "_StateSpecs" from the resulting string. We need to do the + # same here in CMake. + # Example: ${specs_file1} = GEOS_MyGridComp_Registry.rc + # ${specs_file2} = GEOS_MyGridComp_StateSpecs.rc + # + # ${specs_file1} -> GEOS_MyGridComp_Registry.rc -> GEOS_MyGridComp_Registry -> GEOS_MyGridComp + # ${specs_file2} -> GEOS_MyGridComp_StateSpecs.rc -> GEOS_MyGridComp_StateSpecs -> GEOS_MyGridComp + + # First get the filename without the extension + get_filename_component (specs_file_no_ext ${specs_file} NAME_WE) + + # Now remove the _Registry and _StateSpecs + string (REPLACE "_Registry" "" specs_file_base ${specs_file_no_ext}) + string (REPLACE "_StateSpecs" "" specs_file_base ${specs_file_base}) + + # Now we let CMake know the generated file will be named off of the specs_file_base + list (APPEND generated "${specs_file_base}_${fname}${suffix_for_generated_include_files}") + list (APPEND options ${flag}) endif () From 10b45e2ac87c25f7c5f16215c8acdea3bd350b9c Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Tue, 10 Jan 2023 10:52:48 -0500 Subject: [PATCH 15/83] pmn: first crack not compiling --- base/MAPL_sun_uc.F90 | 204 ++++++++++++++++++++++++++++++ generic/MAPL_Generic.F90 | 263 ++++++++++++++++++++------------------- 2 files changed, 337 insertions(+), 130 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index cd4b4306516..661495c00dd 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -24,6 +24,7 @@ module MAPL_SunMod use MAPL_IOMod use MAPL_CommsMod use MAPL_ExceptionHandling + use MAPL_GenericMod, only: MAPL_MetaComp use netcdf use, intrinsic :: iso_fortran_env, only: REAL64 use pflogger, only: logging, Logger @@ -34,6 +35,7 @@ module MAPL_SunMod ! !PUBLIC MEMBER FUNCTIONS: public MAPL_SunOrbitCreate + public MAPL_SunOrbitCreateFromResource public MAPL_SunOrbitCreated public MAPL_SunOrbitDestroy public MAPL_SunOrbitQuery @@ -56,6 +58,53 @@ module MAPL_SunMod integer, public, parameter :: MAPL_SunDailyMean = 5 integer, public, parameter :: MAPL_SunAnnualMean = 6 +! Default solar orbital system parameters (private). +! Dont change these unless you know what you are doing. +! They are appropriate for the current modern epoch circa 2000. +! ------------------------------------------------------------- + + ! Parameters of old orbital system (tabularized intercalation cycle) + ! ------------------------------------------------------------------ + real, parameter :: DEFAULT_ORBIT_ECCENTRICITY = 0.0167 + real, parameter :: DEFAULT_ORBIT_OBLIQUITY = 23.45 + real, parameter :: DEFAULT_ORBIT_PERIHELION = 102.0 + integer, parameter :: DEFAULT_ORBIT_EQUINOX = 80 + + ! Parameters of new orbital system (analytic two-body), which allows some + ! time-varying behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. + ! ------------------------------------------------------------------------- + + ! Fixed anomalistic year length in mean solar days + real, parameter :: DEFAULT_ORB2B_YEARLEN = 365.2596 + + ! Reference date and time for orbital parameters + ! (defaults to J2000 = 01Jan2000 12:00:00 TT = 11:58:56 UTC) + integer, parameter :: DEFAULT_ORB2B_REF_YYYYMMDD = 20000101 + integer, parameter :: DEFAULT_ORB2B_REF_HHMMSS = 115856 + + ! Orbital eccentricity at reference date + real, parameter :: DEFAULT_ORB2B_ECC_REF = 0.016710 + ! Rate of change of orbital eccentricity per Julian century + real, parameter :: DEFAULT_ORB2B_ECC_RATE = -4.2e-5 + + ! Earth's obliquity (axial tilt) at reference date [degrees] + real, parameter :: DEFAULT_ORB2B_OBQ_REF = 23.44 + ! Rate of change of obliquity [degrees per Julian century] + real, parameter :: DEFAULT_ORB2B_OBQ_RATE = -1.3e-2 + + ! Longitude of perihelion at reference date [degrees] + ! (from March equinox to perihelion in direction of earth's motion) + real, parameter :: DEFAULT_ORB2B_LAMBDAP_REF = 282.947 + ! Rate of change of LAMBDAP [degrees per Julian century] + ! (Combines both equatorial and ecliptic precession) + real, parameter :: DEFAULT_ORB2B_LAMBDAP_RATE = 1.7195 + + ! March Equinox date and time + ! (defaults to March 20, 2000 at 07:35:00 UTC) + integer, parameter :: DEFAULT_ORB2B_EQUINOX_YYYYMMDD = 20000320 + integer, parameter :: DEFAULT_ORB2B_EQUINOX_HHMMSS = 73500 + +! ------------------------------------------------------------- interface MAPL_SunGetInsolation module procedure SOLAR_1D @@ -759,6 +808,161 @@ end function MAPL_SunOrbitCreate !========================================================================== +!BOPI + +! !IROUTINE: MAPL_SunOrbitCreateFromResource + +! !DESCRIPTION: + +! Like MAPL_SunOrbitCreate() but gets orbital parameters from the Resource +! file associated with the STATE. + +! !INTERFACE: + + function MAPL_SunOrbitCreateFromResource (STATE, RC) result (ORBIT) + +! !ARGUMENTS: + + type (MAPL_MetaComp), intent(IN) :: STATE + integer, optional, intent(OUT) :: RC + + type (MAPL_SunOrbit) :: ORBIT + +!EOPI + + character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitCreateFromResource" + + real :: ECC + real :: OB + real :: PER + integer :: EQNX + logical :: FIX_SUN + character(len=ESMF_MAXSTR) :: gname + + logical :: EOT, ORBIT_ANAL2B + integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & + ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS + real :: ORB2B_YEARLEN, & + ORB2B_ECC_REF, ORB2B_ECC_RATE, & + ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & + ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE + + ! pmn: There is one orbit is per STATE, so, for example, the MAPL states of the + ! solar and land gridded components can potentially have independent solar orbits. + ! Usually these "independent orbits" will be IDENTICAL because the configuration + ! resources such as "ECCENTRICITY:" or "EOT:" will not be qualified by the name + ! of the gridded component. But for example, if the resource file specifies + ! "EOT: .FALSE." + ! but + ! "SOLAR_EOT: .TRUE." + ! then only SOLAR will have an EOT correction. The same goes for the new orbital + ! system choice ORBIT_ANAL2B. + ! A state's orbit is actually created in this routine by requesting the ORBIT + ! object. If its not already created then it will be made below. GridComps that + ! don't needed an orbit and dont request one will not have one. + + call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,_RC) + if (index(gname,"DP")>0) then + FIX_SUN=.true. + else + FIX_SUN=.false. + end if + + ! Parameters of standard orbital system (tabularized intercalation cycle) + ! ----------------------------------------------------------------------- + call MAPL_GetResource(STATE, ECC, Label="ECCENTRICITY:", & + default=DEFAULT_ORBIT_ECCENTRICITY, _RC) + + call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", & + default=DEFAULT_ORBIT_OBLIQUITY, _RC) + + call MAPL_GetResource(STATE, PER, Label="PERIHELION:", & + default=DEFAULT_ORBIT_PERIHELION, _RC) + + call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", & + default=DEFAULT_ORBIT_EQUINOX, _RC) + + ! Apply Equation of Time correction? + ! ---------------------------------- + call MAPL_GetResource(STATE, EOT, Label="EOT:", default=.FALSE., _RC) + + ! New orbital system (analytic two-body) allows some time-varying + ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. + ! --------------------------------------------------------------- + + call MAPL_GetResource(STATE, & + ORBIT_ANAL2B, Label="ORBIT_ANAL2B:", default=.FALSE., _RC) + + ! Fixed anomalistic year length in mean solar days + call MAPL_GetResource(STATE, & + ORB2B_YEARLEN, Label="ORB2B_YEARLEN:", & + default=DEFAULT_ORB2B_YEARLEN, _RC) + + ! Reference date and time for orbital parameters + call MAPL_GetResource(STATE, & + ORB2B_REF_YYYYMMDD, Label="ORB2B_REF_YYYYMMDD:", & + default=DEFAULT_ORB2B_REF_YYYYMMDD, _RC) + call MAPL_GetResource(STATE, & + ORB2B_REF_HHMMSS, Label="ORB2B_REF_HHMMSS:", & + default=DEFAULT_ORB2B_REF_HHMMSS, _RC) + + ! Orbital eccentricity at reference date + call MAPL_GetResource(STATE, & + ORB2B_ECC_REF, Label="ORB2B_ECC_REF:", & + default=DEFAULT_ORB2B_ECC_REF, _RC) + + ! Rate of change of orbital eccentricity per Julian century + call MAPL_GetResource(STATE, & + ORB2B_ECC_RATE, Label="ORB2B_ECC_RATE:", & + default=DEFAULT_ORB2B_ECC_RATE, _RC) + + ! Earth's obliquity (axial tilt) at reference date [degrees] + call MAPL_GetResource(STATE, & + ORB2B_OBQ_REF, Label="ORB2B_OBQ_REF:", & + default=DEFAULT_ORB2B_OBQ_REF, _RC) + + ! Rate of change of obliquity [degrees per Julian century] + call MAPL_GetResource(STATE, & + ORB2B_OBQ_RATE, Label="ORB2B_OBQ_RATE:", & + default=DEFAULT_ORB2B_OBQ_RATE, _RC) + + ! Longitude of perihelion at reference date [degrees] + ! (from March equinox to perihelion in direction of earth's motion) + call MAPL_GetResource(STATE, & + ORB2B_LAMBDAP_REF, Label="ORB2B_LAMBDAP_REF:", & + default=DEFAULT_ORB2B_LAMBDAP_REF, _RC) + + ! Rate of change of LAMBDAP [degrees per Julian century] + ! (Combines both equatorial and ecliptic precession) + call MAPL_GetResource(STATE, & + ORB2B_LAMBDAP_RATE, Label="ORB2B_LAMBDAP_RATE:", & + default=DEFAULT_ORB2B_LAMBDAP_RATE, _RC) + + ! March Equinox date and time + call MAPL_GetResource(STATE, & + ORB2B_EQUINOX_YYYYMMDD, Label="ORB2B_EQUINOX_YYYYMMDD:", & + default=DEFAULT_ORB2B_EQUINOX_YYYYMMDD, _RC) + call MAPL_GetResource(STATE, & + ORB2B_EQUINOX_HHMMSS, Label="ORB2B_EQUINOX_HHMMSS:", & + default=DEFAULT_ORB2B_EQUINOX_HHMMSS, _RC) + + ! create the orbit object + ORBIT = MAPL_SunOrbitCreate ( & + STATE%CLOCK, ECC, OB, PER, EQNX, & + EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & + ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & + ORB2B_ECC_REF, ORB2B_ECC_RATE, & + ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & + ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE, & + ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS, & + FIX_SUN=FIX_SUN,_RC) + + _RETURN(ESMF_SUCCESS) + + end function MAPL_SunOrbitCreateFromResource + +!========================================================================== + !BOP ! !IROUTINE: MAPL_SunOrbitDestroy diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index ed77a88b2b3..9ef44dbe0a5 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -4031,20 +4031,20 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_GenericStateGet" integer :: status - real :: ECC - real :: OB - real :: PER - integer :: EQNX - logical :: FIX_SUN - character(len=ESMF_MAXSTR) :: gname - - logical :: EOT, ORBIT_ANAL2B - integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & - ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS - real :: ORB2B_YEARLEN, & - ORB2B_ECC_REF, ORB2B_ECC_RATE, & - ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & - ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE +! real :: ECC +! real :: OB +! real :: PER +! integer :: EQNX +! logical :: FIX_SUN +! character(len=ESMF_MAXSTR) :: gname + +! logical :: EOT, ORBIT_ANAL2B +! integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & +! ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS +! real :: ORB2B_YEARLEN, & +! ORB2B_ECC_REF, ORB2B_ECC_RATE, & +! ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & +! ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE type(MaplGrid), pointer :: temp_grid if(present(IM)) then @@ -4106,124 +4106,127 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & if(.not.MAPL_SunOrbitCreated(STATE%ORBIT)) then - call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,rc=status) - _VERIFY(status) - if (index(gname,"DP")>0) then - FIX_SUN=.true. - else - FIX_SUN=.false. - end if - - ! Fixed parameters of standard orbital system (tabularized intercalation cycle) - ! ----------------------------------------------------------------------------- - - call MAPL_GetResource(STATE, ECC, Label="ECCENTRICITY:", default=0.0167, & - RC=status) - _VERIFY(status) - - call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", default=23.45, & - RC=status) - _VERIFY(status) - - call MAPL_GetResource(STATE, PER, Label="PERIHELION:", default=102.0, & - RC=status) - _VERIFY(status) - - call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", default=80, & - RC=status) - _VERIFY(status) - - ! Apply Equation of Time correction? - ! ---------------------------------- - call MAPL_GetResource(STATE, EOT, Label="EOT:", default=.FALSE., & - RC=status) - _VERIFY(status) - - ! New orbital system (analytic two-body) allows some time-varying - ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. - ! --------------------------------------------------------------- - - call MAPL_GetResource(STATE, & - ORBIT_ANAL2B, Label="ORBIT_ANAL2B:", default=.FALSE., & - RC=status) - _VERIFY(status) - - ! Fixed anomalistic year length in mean solar days - call MAPL_GetResource(STATE, & - ORB2B_YEARLEN, Label="ORB2B_YEARLEN:", default=365.2596, & - RC=status) - _VERIFY(status) - - ! Reference date and time for orbital parameters - ! (defaults to J2000 = 01Jan2000 12:00:00 TT = 11:58:56 UTC) - call MAPL_GetResource(STATE, & - ORB2B_REF_YYYYMMDD, Label="ORB2B_REF_YYYYMMDD:", default=20000101, & - RC=status) - _VERIFY(status) - call MAPL_GetResource(STATE, & - ORB2B_REF_HHMMSS, Label="ORB2B_REF_HHMMSS:", default=115856, & - RC=status) - _VERIFY(status) - - ! Orbital eccentricity at reference date - call MAPL_GetResource(STATE, & - ORB2B_ECC_REF, Label="ORB2B_ECC_REF:", default=0.016710, & - RC=status) - _VERIFY(status) - - ! Rate of change of orbital eccentricity per Julian century - call MAPL_GetResource(STATE, & - ORB2B_ECC_RATE, Label="ORB2B_ECC_RATE:", default=-4.2e-5, & - RC=status) - _VERIFY(status) - - ! Earth's obliquity (axial tilt) at reference date [degrees] - call MAPL_GetResource(STATE, & - ORB2B_OBQ_REF, Label="ORB2B_OBQ_REF:", default=23.44, & - RC=status) - _VERIFY(status) - - ! Rate of change of obliquity [degrees per Julian century] - call MAPL_GetResource(STATE, & - ORB2B_OBQ_RATE, Label="ORB2B_OBQ_RATE:", default=-1.3e-2, & - RC=status) - _VERIFY(status) - - ! Longitude of perihelion at reference date [degrees] - ! (from March equinox to perihelion in direction of earth's motion) - call MAPL_GetResource(STATE, & - ORB2B_LAMBDAP_REF, Label="ORB2B_LAMBDAP_REF:", default=282.947, & - RC=status) - _VERIFY(status) - - ! Rate of change of LAMBDAP [degrees per Julian century] - ! (Combines both equatorial and ecliptic precession) - call MAPL_GetResource(STATE, & - ORB2B_LAMBDAP_RATE, Label="ORB2B_LAMBDAP_RATE:", default=1.7195, & - RC=status) - _VERIFY(status) - - ! March Equinox date and time - ! (defaults to March 20, 2000 at 07:35:00 UTC) - call MAPL_GetResource(STATE, & - ORB2B_EQUINOX_YYYYMMDD, Label="ORB2B_EQUINOX_YYYYMMDD:", default=20000320, & - RC=status) - _VERIFY(status) - call MAPL_GetResource(STATE, & - ORB2B_EQUINOX_HHMMSS, Label="ORB2B_EQUINOX_HHMMSS:", default=073500, & - RC=status) - _VERIFY(status) +! call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,rc=status) +! _VERIFY(status) +! if (index(gname,"DP")>0) then +! FIX_SUN=.true. +! else +! FIX_SUN=.false. +! end if + +! ! Fixed parameters of standard orbital system (tabularized intercalation cycle) +! ! ----------------------------------------------------------------------------- + +! call MAPL_GetResource(STATE, ECC, Label="ECCENTRICITY:", default=0.0167, & +! RC=status) +! _VERIFY(status) + +! call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", default=23.45, & +! RC=status) +! _VERIFY(status) + +! call MAPL_GetResource(STATE, PER, Label="PERIHELION:", default=102.0, & +! RC=status) +! _VERIFY(status) + +! call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", default=80, & +! RC=status) +! _VERIFY(status) + +! ! Apply Equation of Time correction? +! ! ---------------------------------- +! call MAPL_GetResource(STATE, EOT, Label="EOT:", default=.FALSE., & +! RC=status) +! _VERIFY(status) + +! ! New orbital system (analytic two-body) allows some time-varying +! ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. +! ! --------------------------------------------------------------- + +! call MAPL_GetResource(STATE, & +! ORBIT_ANAL2B, Label="ORBIT_ANAL2B:", default=.FALSE., & +! RC=status) +! _VERIFY(status) + +! ! Fixed anomalistic year length in mean solar days +! call MAPL_GetResource(STATE, & +! ORB2B_YEARLEN, Label="ORB2B_YEARLEN:", default=365.2596, & +! RC=status) +! _VERIFY(status) + +! ! Reference date and time for orbital parameters +! ! (defaults to J2000 = 01Jan2000 12:00:00 TT = 11:58:56 UTC) +! call MAPL_GetResource(STATE, & +! ORB2B_REF_YYYYMMDD, Label="ORB2B_REF_YYYYMMDD:", default=20000101, & +! RC=status) +! _VERIFY(status) +! call MAPL_GetResource(STATE, & +! ORB2B_REF_HHMMSS, Label="ORB2B_REF_HHMMSS:", default=115856, & +! RC=status) +! _VERIFY(status) + +! ! Orbital eccentricity at reference date +! call MAPL_GetResource(STATE, & +! ORB2B_ECC_REF, Label="ORB2B_ECC_REF:", default=0.016710, & +! RC=status) +! _VERIFY(status) + +! ! Rate of change of orbital eccentricity per Julian century +! call MAPL_GetResource(STATE, & +! ORB2B_ECC_RATE, Label="ORB2B_ECC_RATE:", default=-4.2e-5, & +! RC=status) +! _VERIFY(status) + +! ! Earth's obliquity (axial tilt) at reference date [degrees] +! call MAPL_GetResource(STATE, & +! ORB2B_OBQ_REF, Label="ORB2B_OBQ_REF:", default=23.44, & +! RC=status) +! _VERIFY(status) + +! ! Rate of change of obliquity [degrees per Julian century] +! call MAPL_GetResource(STATE, & +! ORB2B_OBQ_RATE, Label="ORB2B_OBQ_RATE:", default=-1.3e-2, & +! RC=status) +! _VERIFY(status) + +! ! Longitude of perihelion at reference date [degrees] +! ! (from March equinox to perihelion in direction of earth's motion) +! call MAPL_GetResource(STATE, & +! ORB2B_LAMBDAP_REF, Label="ORB2B_LAMBDAP_REF:", default=282.947, & +! RC=status) +! _VERIFY(status) + +! ! Rate of change of LAMBDAP [degrees per Julian century] +! ! (Combines both equatorial and ecliptic precession) +! call MAPL_GetResource(STATE, & +! ORB2B_LAMBDAP_RATE, Label="ORB2B_LAMBDAP_RATE:", default=1.7195, & +! RC=status) +! _VERIFY(status) + +! ! March Equinox date and time +! ! (defaults to March 20, 2000 at 07:35:00 UTC) +! call MAPL_GetResource(STATE, & +! ORB2B_EQUINOX_YYYYMMDD, Label="ORB2B_EQUINOX_YYYYMMDD:", default=20000320, & +! RC=status) +! _VERIFY(status) +! call MAPL_GetResource(STATE, & +! ORB2B_EQUINOX_HHMMSS, Label="ORB2B_EQUINOX_HHMMSS:", default=073500, & +! RC=status) +! _VERIFY(status) + +! ! create the orbit object +! STATE%ORBIT = MAPL_SunOrbitCreate(STATE%CLOCK, ECC, OB, PER, EQNX, & +! EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & +! ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & +! ORB2B_ECC_REF, ORB2B_ECC_RATE, & +! ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & +! ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE, & +! ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS, & +! FIX_SUN=FIX_SUN,RC=status) +! _VERIFY(status) ! create the orbit object - STATE%ORBIT = MAPL_SunOrbitCreate(STATE%CLOCK, ECC, OB, PER, EQNX, & - EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & - ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & - ORB2B_ECC_REF, ORB2B_ECC_RATE, & - ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & - ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE, & - ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS, & - FIX_SUN=FIX_SUN,RC=status) - _VERIFY(status) + STATE%ORBIT = MAPL_SunOrbitCreateFromResource (STATE, _RC) end if ORBIT=STATE%ORBIT From 8d60a3503f99de727acafa55d8319936f3f7f9c1 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 10 Jan 2023 14:39:57 -0500 Subject: [PATCH 16/83] Fixes #1888. Identity metadata fix --- CHANGELOG.md | 3 ++- griddedio/GriddedIO.F90 | 13 +++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2b7fde4838b..642c0875ae6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -19,8 +19,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed -- Added the correct values to halo corner of LatLon grid +- Added the correct values to halo corner of LatLon grid - Fixed range in halo of LatLonGridFactory +- Corrected issue with native output having metadata saying it was bilinearly regridded ### Removed diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index 351fcbda73d..2ba104b50a2 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -125,6 +125,7 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr integer :: metadataVarsSize type(StringStringMapIterator) :: s_iter character(len=:), pointer :: attr_name, attr_val + integer (kind=ESMF_KIND_I8) :: id_in, id_out integer :: status this%items = items @@ -142,6 +143,13 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr end if this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) _VERIFY(status) + + id_in = get_factory_id(input_grid,_RC) + id_out = get_factory_id(this%output_grid,_RC) + if (id_in == id_out) then + this%regrid_method = REGRID_METHOD_IDENTITY + end if + call ESMF_FieldBundleSet(this%output_bundle,grid=this%output_grid,rc=status) _VERIFY(status) factory => get_factory(this%output_grid,rc=status) @@ -1002,6 +1010,11 @@ subroutine request_data_from_file(this,filename,timeindex,rc) if (filegrid/=output_grid) then this%regrid_handle => new_regridder_manager%make_regridder(filegrid,output_grid,this%regrid_method,rc=status) _VERIFY(status) + id_in = get_factory_id(input_grid,_RC) + id_out = get_factory_id(this%output_grid,_RC) + if (id_in == id_out) then + this%regrid_method = REGRID_METHOD_IDENTITY + end if end if call MAPL_GridGet(filegrid,globalCellCountPerdim=dims,rc=status) _VERIFY(status) From ccd71ee645f2f2f3d78ba11eea2fca5acd4f2a7e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 10 Jan 2023 15:19:28 -0500 Subject: [PATCH 17/83] A better way thanks to @tclune --- base/MAPL_AbstractRegridder.F90 | 80 ++++++++++++++++++--------------- base/MAPL_IdentityRegridder.F90 | 14 +++--- griddedio/GriddedIO.F90 | 14 ++---- 3 files changed, 56 insertions(+), 52 deletions(-) diff --git a/base/MAPL_AbstractRegridder.F90 b/base/MAPL_AbstractRegridder.F90 index 30ffeb83017..52aa6364a38 100644 --- a/base/MAPL_AbstractRegridder.F90 +++ b/base/MAPL_AbstractRegridder.F90 @@ -11,7 +11,7 @@ module MAPL_AbstractRegridderMod use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none private - + public :: AbstractRegridder type, abstract :: AbstractRegridder @@ -29,7 +29,7 @@ module MAPL_AbstractRegridderMod procedure :: get_spec procedure :: set_spec procedure :: isTranspose - + procedure :: regrid_scalar_2d_real32 procedure :: regrid_scalar_2d_real64 procedure :: regrid_scalar_3d_real32 @@ -44,7 +44,7 @@ module MAPL_AbstractRegridderMod ! interfaces. procedure :: regrid_esmf_fields_scalar procedure :: regrid_esmf_fields_vector - + ! Generic overload generic :: regrid => regrid_esmf_fields_scalar generic :: regrid => regrid_esmf_fields_vector @@ -90,6 +90,7 @@ module MAPL_AbstractRegridderMod procedure :: get_undef_value procedure :: clear_undef_value procedure :: has_undef_value + procedure :: get_regrid_method end type AbstractRegridder @@ -105,7 +106,7 @@ subroutine initialize_subclass(this, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc end subroutine initialize_subclass - + end interface character(len=*), parameter :: MOD_NAME = 'MAPL_AbstractRegridder::' @@ -272,7 +273,7 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in type (ESMF_Field), intent(in) :: f_out integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'regrid_esmf_fields' integer :: rank_in type (ESMF_TypeKind_Flag) :: typekind_in @@ -298,7 +299,7 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL32), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -311,7 +312,7 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL64), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -356,13 +357,13 @@ subroutine regrid_esmf_fields_scalar(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported type kind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine regrid_esmf_fields_scalar @@ -377,7 +378,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in(NUM_DIM) type (ESMF_Field), intent(in) :: f_out(NUM_DIM) integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'regrid_esmf_fields' integer :: rank_in(NUM_DIM) type (ESMF_TypeKind_Flag) :: typekind_in(NUM_DIM) @@ -413,7 +414,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:), v_in(:,:) real(REAL32), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -431,7 +432,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:), v_in(:,:) real(REAL64), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -455,7 +456,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL32), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -473,7 +474,7 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL64), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -489,19 +490,19 @@ subroutine regrid_esmf_fields_vector(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported type-kind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine regrid_esmf_fields_vector ! Begin - transpose interfaces - + subroutine transpose_regrid_scalar_2d_real32(this, q_in, q_out, rc) class (AbstractRegridder), intent(in) :: this real(kind=REAL32), intent(in) :: q_in(:,:) @@ -531,7 +532,7 @@ subroutine transpose_regrid_scalar_2d_real64(this, q_in, q_out, rc) _RETURN(_FAILURE) end subroutine transpose_regrid_scalar_2d_real64 - + subroutine transpose_regrid_scalar_3d_real32(this, q_in, q_out, rc) class (AbstractRegridder), intent(in) :: this real(kind=REAL32), intent(in) :: q_in(:,:,:) @@ -563,7 +564,7 @@ subroutine transpose_regrid_scalar_3d_real64(this, q_in, q_out, rc) end subroutine transpose_regrid_scalar_3d_real64 - + subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) class (AbstractRegridder), intent(in) :: this real(kind=REAL32), intent(in) :: u_in(:,:) @@ -585,7 +586,7 @@ subroutine transpose_regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rot u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_2d_real32 @@ -610,7 +611,7 @@ subroutine transpose_regrid_vector_2d_real64(this, u_in, v_in, u_out, v_out, rot u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_2d_real64 @@ -635,7 +636,7 @@ subroutine transpose_regrid_vector_3d_real32(this, u_in, v_in, u_out, v_out, rot u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_3d_real32 @@ -658,7 +659,7 @@ subroutine transpose_regrid_vector_3d_real64(this, u_in, v_in, u_out, v_out, rc) u_out = 0 v_out = 0 _RETURN(_FAILURE) - + end subroutine transpose_regrid_vector_3d_real64 @@ -672,7 +673,7 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in type (ESMF_Field), intent(in) :: f_out integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_esmf_fields' integer :: rank_in type (ESMF_TypeKind_Flag) :: typekind_in @@ -698,7 +699,7 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL32), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -711,7 +712,7 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) block real(REAL64), pointer :: q_in(:,:), q_out(:,:) - + call ESMF_FieldGet(f_in , 0, q_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_out , 0, q_out, rc=status) @@ -756,13 +757,13 @@ subroutine transpose_regrid_esmf_fields_scalar(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported typekind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine transpose_regrid_esmf_fields_scalar @@ -777,7 +778,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) type (ESMF_Field), intent(in) :: f_in(NUM_DIM) type (ESMF_Field), intent(in) :: f_out(NUM_DIM) integer, optional, intent(out) :: rc - + character(len=*), parameter :: Iam = MOD_NAME//'transpose_regrid_esmf_fields' integer :: rank_in(NUM_DIM) type (ESMF_TypeKind_Flag) :: typekind_in(NUM_DIM) @@ -813,7 +814,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:), v_in(:,:) real(REAL32), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -831,7 +832,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:), v_in(:,:) real(REAL64), pointer :: u_out(:,:), v_out(:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -855,7 +856,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL32), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL32), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -873,7 +874,7 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) block real(REAL64), pointer :: u_in(:,:,:), v_in(:,:,:) real(REAL64), pointer :: u_out(:,:,:), v_out(:,:,:) - + call ESMF_FieldGet(f_in(1) , 0, u_in, rc=status) _VERIFY(status) call ESMF_FieldGet(f_in(2) , 0, v_in, rc=status) @@ -889,13 +890,13 @@ subroutine transpose_regrid_esmf_fields_vector(this, f_in, f_out, rc) case default ! unsupported type/kind _FAIL( 'unsupported typekind') end select - + case default ! unsupported rank _FAIL( 'unsupported rank') end select _RETURN(_SUCCESS) - + end subroutine transpose_regrid_esmf_fields_vector @@ -940,7 +941,7 @@ function get_spec(this) result(spec) class (AbstractRegridder), intent(in) :: this spec = this%spec end function get_spec - + subroutine set_spec(this, spec) class(AbstractRegridder), intent(inout) :: this type(RegridderSpec), intent(in) :: spec @@ -974,7 +975,7 @@ subroutine initialize_base(this, spec, unusable, rc) _RETURN(_SUCCESS) end subroutine initialize_base - + function clone(this) class (AbstractRegridder), allocatable :: clone class (AbstractRegridder), intent(in) :: this @@ -1000,4 +1001,9 @@ logical function supports(spec, unusable, rc) end function supports + integer function get_regrid_method(this) result(method) + class (AbstractRegridder), intent(in) :: this + method = this%spec%regrid_method + end function get_regrid_method + end module MAPL_AbstractRegridderMod diff --git a/base/MAPL_IdentityRegridder.F90 b/base/MAPL_IdentityRegridder.F90 index c3514f4b59f..28dc6a517b7 100644 --- a/base/MAPL_IdentityRegridder.F90 +++ b/base/MAPL_IdentityRegridder.F90 @@ -8,7 +8,7 @@ module MAPL_IdentityRegridderMod use mapl_ErrorHandlingMod use mapl_RegridMethods use ESMF - + use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -38,15 +38,19 @@ module MAPL_IdentityRegridderMod character(len=*), parameter :: MOD_NAME = 'MAPL_IdentityRegridder::' type (IdentityRegridder), save, target :: singleton - + contains function identity_regridder() result(regridder) use ESMF type (IdentityRegridder), pointer :: regridder + type (RegridderSpec), pointer :: spec regridder => singleton + + spec => regridder%get_spec() + spec%regrid_method = REGRID_METHOD_IDENTITY end function identity_regridder @@ -63,7 +67,7 @@ subroutine regrid_scalar_2d_real32(this, q_in, q_out, rc) q_out = q_in _RETURN(_SUCCESS) - + end subroutine regrid_scalar_2d_real32 @@ -85,7 +89,7 @@ subroutine regrid_scalar_3d_real32(this, q_in, q_out, rc) q_out = q_in _RETURN(_SUCCESS) - + end subroutine regrid_scalar_3d_real32 subroutine regrid_vector_2d_real32(this, u_in, v_in, u_out, v_out, rotate, rc) @@ -169,5 +173,5 @@ subroutine initialize_subclass(this, unusable, rc) _UNUSED_DUMMY(rc) end subroutine initialize_subclass - + end module MAPL_IdentityRegridderMod diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index 2ba104b50a2..30480a13745 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -144,11 +144,10 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) _VERIFY(status) - id_in = get_factory_id(input_grid,_RC) - id_out = get_factory_id(this%output_grid,_RC) - if (id_in == id_out) then - this%regrid_method = REGRID_METHOD_IDENTITY - end if + ! We get the regrid_method here because we default to bilinear even in the case + ! of input_grid and this%output_grid being the same. But if the regrid_handle + ! is the identity regridder, then this will set it to REGRID_METHOD_IDENTITY + this%regrid_method = this%regrid_handle%get_regrid_method() call ESMF_FieldBundleSet(this%output_bundle,grid=this%output_grid,rc=status) _VERIFY(status) @@ -1010,11 +1009,6 @@ subroutine request_data_from_file(this,filename,timeindex,rc) if (filegrid/=output_grid) then this%regrid_handle => new_regridder_manager%make_regridder(filegrid,output_grid,this%regrid_method,rc=status) _VERIFY(status) - id_in = get_factory_id(input_grid,_RC) - id_out = get_factory_id(this%output_grid,_RC) - if (id_in == id_out) then - this%regrid_method = REGRID_METHOD_IDENTITY - end if end if call MAPL_GridGet(filegrid,globalCellCountPerdim=dims,rc=status) _VERIFY(status) From 7d90490279d95e26c3ded3e67aa838a7522498b1 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Tue, 10 Jan 2023 17:15:36 -0500 Subject: [PATCH 18/83] pmn: compiles now --- base/MAPL_sun_uc.F90 | 106 +++++++++++++++++++-------------------- generic/MAPL_Generic.F90 | 15 ++---- 2 files changed, 57 insertions(+), 64 deletions(-) diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index 661495c00dd..11992e405a8 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -24,7 +24,6 @@ module MAPL_SunMod use MAPL_IOMod use MAPL_CommsMod use MAPL_ExceptionHandling - use MAPL_GenericMod, only: MAPL_MetaComp use netcdf use, intrinsic :: iso_fortran_env, only: REAL64 use pflogger, only: logging, Logger @@ -35,7 +34,7 @@ module MAPL_SunMod ! !PUBLIC MEMBER FUNCTIONS: public MAPL_SunOrbitCreate - public MAPL_SunOrbitCreateFromResource + public MAPL_SunOrbitCreateFromConfig public MAPL_SunOrbitCreated public MAPL_SunOrbitDestroy public MAPL_SunOrbitQuery @@ -810,34 +809,33 @@ end function MAPL_SunOrbitCreate !BOPI -! !IROUTINE: MAPL_SunOrbitCreateFromResource +! !IROUTINE: MAPL_SunOrbitCreateFromConfig ! !DESCRIPTION: -! Like MAPL_SunOrbitCreate() but gets orbital parameters from the Resource -! file associated with the STATE. +! Like MAPL_SunOrbitCreate() but gets orbital parameters from Config CF. ! !INTERFACE: - function MAPL_SunOrbitCreateFromResource (STATE, RC) result (ORBIT) + function MAPL_SunOrbitCreateFromConfig ( & + CF, CLOCK, FIX_SUN, RC) result (ORBIT) ! !ARGUMENTS: - type (MAPL_MetaComp), intent(IN) :: STATE - integer, optional, intent(OUT) :: RC + type (ESMF_Config), intent(INOUT) :: CF + type (ESMF_Clock), intent(IN ) :: CLOCK + logical, intent(IN ) :: FIX_SUN + integer, optional, intent(OUT ) :: RC - type (MAPL_SunOrbit) :: ORBIT + type (MAPL_SunOrbit) :: ORBIT !EOPI - character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitCreateFromResource" + character(len=ESMF_MAXSTR), parameter :: IAm = "SunOrbitCreateFromConfig" + integer :: STATUS - real :: ECC - real :: OB - real :: PER - integer :: EQNX - logical :: FIX_SUN - character(len=ESMF_MAXSTR) :: gname + real :: ECC, OB, PER + integer :: EQNX logical :: EOT, ORBIT_ANAL2B integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & @@ -861,94 +859,94 @@ function MAPL_SunOrbitCreateFromResource (STATE, RC) result (ORBIT) ! object. If its not already created then it will be made below. GridComps that ! don't needed an orbit and dont request one will not have one. - call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,_RC) - if (index(gname,"DP")>0) then - FIX_SUN=.true. - else - FIX_SUN=.false. - end if - ! Parameters of standard orbital system (tabularized intercalation cycle) ! ----------------------------------------------------------------------- - call MAPL_GetResource(STATE, ECC, Label="ECCENTRICITY:", & + call ESMF_ConfigGetAttribute (CF, & + ECC, label="ECCENTRICITY:", & default=DEFAULT_ORBIT_ECCENTRICITY, _RC) - call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", & + call ESMF_ConfigGetAttribute (CF, & + OB, label="OBLIQUITY:", & default=DEFAULT_ORBIT_OBLIQUITY, _RC) - call MAPL_GetResource(STATE, PER, Label="PERIHELION:", & + call ESMF_ConfigGetAttribute (CF, & + PER, label="PERIHELION:", & default=DEFAULT_ORBIT_PERIHELION, _RC) - call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", & + call ESMF_ConfigGetAttribute (CF, & + EQNX, label="EQUINOX:", & default=DEFAULT_ORBIT_EQUINOX, _RC) ! Apply Equation of Time correction? ! ---------------------------------- - call MAPL_GetResource(STATE, EOT, Label="EOT:", default=.FALSE., _RC) + call ESMF_ConfigGetAttribute (CF, & + EOT, label="EOT:", & + default=.FALSE., _RC) ! New orbital system (analytic two-body) allows some time-varying ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. ! --------------------------------------------------------------- - call MAPL_GetResource(STATE, & - ORBIT_ANAL2B, Label="ORBIT_ANAL2B:", default=.FALSE., _RC) + call ESMF_ConfigGetAttribute (CF, & + ORBIT_ANAL2B, label="ORBIT_ANAL2B:", & + default=.FALSE., _RC) ! Fixed anomalistic year length in mean solar days - call MAPL_GetResource(STATE, & - ORB2B_YEARLEN, Label="ORB2B_YEARLEN:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_YEARLEN, label="ORB2B_YEARLEN:", & default=DEFAULT_ORB2B_YEARLEN, _RC) ! Reference date and time for orbital parameters - call MAPL_GetResource(STATE, & - ORB2B_REF_YYYYMMDD, Label="ORB2B_REF_YYYYMMDD:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_REF_YYYYMMDD, label="ORB2B_REF_YYYYMMDD:", & default=DEFAULT_ORB2B_REF_YYYYMMDD, _RC) - call MAPL_GetResource(STATE, & - ORB2B_REF_HHMMSS, Label="ORB2B_REF_HHMMSS:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_REF_HHMMSS, label="ORB2B_REF_HHMMSS:", & default=DEFAULT_ORB2B_REF_HHMMSS, _RC) ! Orbital eccentricity at reference date - call MAPL_GetResource(STATE, & - ORB2B_ECC_REF, Label="ORB2B_ECC_REF:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_ECC_REF, label="ORB2B_ECC_REF:", & default=DEFAULT_ORB2B_ECC_REF, _RC) ! Rate of change of orbital eccentricity per Julian century - call MAPL_GetResource(STATE, & - ORB2B_ECC_RATE, Label="ORB2B_ECC_RATE:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_ECC_RATE, label="ORB2B_ECC_RATE:", & default=DEFAULT_ORB2B_ECC_RATE, _RC) ! Earth's obliquity (axial tilt) at reference date [degrees] - call MAPL_GetResource(STATE, & - ORB2B_OBQ_REF, Label="ORB2B_OBQ_REF:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_OBQ_REF, label="ORB2B_OBQ_REF:", & default=DEFAULT_ORB2B_OBQ_REF, _RC) ! Rate of change of obliquity [degrees per Julian century] - call MAPL_GetResource(STATE, & - ORB2B_OBQ_RATE, Label="ORB2B_OBQ_RATE:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_OBQ_RATE, label="ORB2B_OBQ_RATE:", & default=DEFAULT_ORB2B_OBQ_RATE, _RC) ! Longitude of perihelion at reference date [degrees] ! (from March equinox to perihelion in direction of earth's motion) - call MAPL_GetResource(STATE, & - ORB2B_LAMBDAP_REF, Label="ORB2B_LAMBDAP_REF:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_LAMBDAP_REF, label="ORB2B_LAMBDAP_REF:", & default=DEFAULT_ORB2B_LAMBDAP_REF, _RC) ! Rate of change of LAMBDAP [degrees per Julian century] ! (Combines both equatorial and ecliptic precession) - call MAPL_GetResource(STATE, & - ORB2B_LAMBDAP_RATE, Label="ORB2B_LAMBDAP_RATE:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_LAMBDAP_RATE, label="ORB2B_LAMBDAP_RATE:", & default=DEFAULT_ORB2B_LAMBDAP_RATE, _RC) ! March Equinox date and time - call MAPL_GetResource(STATE, & - ORB2B_EQUINOX_YYYYMMDD, Label="ORB2B_EQUINOX_YYYYMMDD:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_EQUINOX_YYYYMMDD, label="ORB2B_EQUINOX_YYYYMMDD:", & default=DEFAULT_ORB2B_EQUINOX_YYYYMMDD, _RC) - call MAPL_GetResource(STATE, & - ORB2B_EQUINOX_HHMMSS, Label="ORB2B_EQUINOX_HHMMSS:", & + call ESMF_ConfigGetAttribute (CF, & + ORB2B_EQUINOX_HHMMSS, label="ORB2B_EQUINOX_HHMMSS:", & default=DEFAULT_ORB2B_EQUINOX_HHMMSS, _RC) ! create the orbit object ORBIT = MAPL_SunOrbitCreate ( & - STATE%CLOCK, ECC, OB, PER, EQNX, & + CLOCK, ECC, OB, PER, EQNX, & EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & ORB2B_ECC_REF, ORB2B_ECC_RATE, & @@ -959,7 +957,7 @@ function MAPL_SunOrbitCreateFromResource (STATE, RC) result (ORBIT) _RETURN(ESMF_SUCCESS) - end function MAPL_SunOrbitCreateFromResource + end function MAPL_SunOrbitCreateFromConfig !========================================================================== diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 9ef44dbe0a5..ef00b4cae36 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -4035,8 +4035,8 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & ! real :: OB ! real :: PER ! integer :: EQNX -! logical :: FIX_SUN -! character(len=ESMF_MAXSTR) :: gname + logical :: FIX_SUN + character(len=ESMF_MAXSTR) :: gname ! logical :: EOT, ORBIT_ANAL2B ! integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & @@ -4106,13 +4106,8 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & if(.not.MAPL_SunOrbitCreated(STATE%ORBIT)) then -! call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,rc=status) -! _VERIFY(status) -! if (index(gname,"DP")>0) then -! FIX_SUN=.true. -! else -! FIX_SUN=.false. -! end if + call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,_RC) + FIX_SUN = (index(gname,"DP")>0) ! ! Fixed parameters of standard orbital system (tabularized intercalation cycle) ! ! ----------------------------------------------------------------------------- @@ -4226,7 +4221,7 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & ! _VERIFY(status) ! create the orbit object - STATE%ORBIT = MAPL_SunOrbitCreateFromResource (STATE, _RC) + STATE%ORBIT = MAPL_SunOrbitCreateFromConfig (STATE%CF, STATE%CLOCK, FIX_SUN, _RC) end if ORBIT=STATE%ORBIT From ff0c9adc028462f7b79453e3cdfb60ed9641564f Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Tue, 10 Jan 2023 17:44:22 -0500 Subject: [PATCH 19/83] pmn: cosmetic only, removing defunct commented lines, no need to test --- generic/MAPL_Generic.F90 | 136 --------------------------------------- 1 file changed, 136 deletions(-) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index ef00b4cae36..d29db2dcce8 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -4031,20 +4031,9 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & character(len=ESMF_MAXSTR), parameter :: IAm = "MAPL_GenericStateGet" integer :: status -! real :: ECC -! real :: OB -! real :: PER -! integer :: EQNX logical :: FIX_SUN character(len=ESMF_MAXSTR) :: gname -! logical :: EOT, ORBIT_ANAL2B -! integer :: ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & -! ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS -! real :: ORB2B_YEARLEN, & -! ORB2B_ECC_REF, ORB2B_ECC_RATE, & -! ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & -! ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE type(MaplGrid), pointer :: temp_grid if(present(IM)) then @@ -4088,20 +4077,6 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & CF=STATE%CF endif - ! pmn: There is one orbit is per STATE, so, for example, the MAPL states of the - ! solar and land gridded components can potentially have independent solar orbits. - ! Usually these "independent orbits" will be IDENTICAL because the configuration - ! resources such as "ECCENTRICITY:" or "EOT:" will not be qualified by the name - ! of the gridded component. But for example, if the resource file specifies - ! "EOT: .FALSE." - ! but - ! "SOLAR_EOT: .TRUE." - ! then only SOLAR will have an EOT correction. The same goes for the new orbital - ! system choice ORBIT_ANAL2B. - ! A state's orbit is actually created in this routine by requesting the ORBIT - ! object. If its not already created then it will be made below. GridComps that - ! don't needed an orbit and dont request one will not have one. - if(present(ORBIT)) then if(.not.MAPL_SunOrbitCreated(STATE%ORBIT)) then @@ -4109,117 +4084,6 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,_RC) FIX_SUN = (index(gname,"DP")>0) -! ! Fixed parameters of standard orbital system (tabularized intercalation cycle) -! ! ----------------------------------------------------------------------------- - -! call MAPL_GetResource(STATE, ECC, Label="ECCENTRICITY:", default=0.0167, & -! RC=status) -! _VERIFY(status) - -! call MAPL_GetResource(STATE, OB, Label="OBLIQUITY:", default=23.45, & -! RC=status) -! _VERIFY(status) - -! call MAPL_GetResource(STATE, PER, Label="PERIHELION:", default=102.0, & -! RC=status) -! _VERIFY(status) - -! call MAPL_GetResource(STATE, EQNX, Label="EQUINOX:", default=80, & -! RC=status) -! _VERIFY(status) - -! ! Apply Equation of Time correction? -! ! ---------------------------------- -! call MAPL_GetResource(STATE, EOT, Label="EOT:", default=.FALSE., & -! RC=status) -! _VERIFY(status) - -! ! New orbital system (analytic two-body) allows some time-varying -! ! behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. -! ! --------------------------------------------------------------- - -! call MAPL_GetResource(STATE, & -! ORBIT_ANAL2B, Label="ORBIT_ANAL2B:", default=.FALSE., & -! RC=status) -! _VERIFY(status) - -! ! Fixed anomalistic year length in mean solar days -! call MAPL_GetResource(STATE, & -! ORB2B_YEARLEN, Label="ORB2B_YEARLEN:", default=365.2596, & -! RC=status) -! _VERIFY(status) - -! ! Reference date and time for orbital parameters -! ! (defaults to J2000 = 01Jan2000 12:00:00 TT = 11:58:56 UTC) -! call MAPL_GetResource(STATE, & -! ORB2B_REF_YYYYMMDD, Label="ORB2B_REF_YYYYMMDD:", default=20000101, & -! RC=status) -! _VERIFY(status) -! call MAPL_GetResource(STATE, & -! ORB2B_REF_HHMMSS, Label="ORB2B_REF_HHMMSS:", default=115856, & -! RC=status) -! _VERIFY(status) - -! ! Orbital eccentricity at reference date -! call MAPL_GetResource(STATE, & -! ORB2B_ECC_REF, Label="ORB2B_ECC_REF:", default=0.016710, & -! RC=status) -! _VERIFY(status) - -! ! Rate of change of orbital eccentricity per Julian century -! call MAPL_GetResource(STATE, & -! ORB2B_ECC_RATE, Label="ORB2B_ECC_RATE:", default=-4.2e-5, & -! RC=status) -! _VERIFY(status) - -! ! Earth's obliquity (axial tilt) at reference date [degrees] -! call MAPL_GetResource(STATE, & -! ORB2B_OBQ_REF, Label="ORB2B_OBQ_REF:", default=23.44, & -! RC=status) -! _VERIFY(status) - -! ! Rate of change of obliquity [degrees per Julian century] -! call MAPL_GetResource(STATE, & -! ORB2B_OBQ_RATE, Label="ORB2B_OBQ_RATE:", default=-1.3e-2, & -! RC=status) -! _VERIFY(status) - -! ! Longitude of perihelion at reference date [degrees] -! ! (from March equinox to perihelion in direction of earth's motion) -! call MAPL_GetResource(STATE, & -! ORB2B_LAMBDAP_REF, Label="ORB2B_LAMBDAP_REF:", default=282.947, & -! RC=status) -! _VERIFY(status) - -! ! Rate of change of LAMBDAP [degrees per Julian century] -! ! (Combines both equatorial and ecliptic precession) -! call MAPL_GetResource(STATE, & -! ORB2B_LAMBDAP_RATE, Label="ORB2B_LAMBDAP_RATE:", default=1.7195, & -! RC=status) -! _VERIFY(status) - -! ! March Equinox date and time -! ! (defaults to March 20, 2000 at 07:35:00 UTC) -! call MAPL_GetResource(STATE, & -! ORB2B_EQUINOX_YYYYMMDD, Label="ORB2B_EQUINOX_YYYYMMDD:", default=20000320, & -! RC=status) -! _VERIFY(status) -! call MAPL_GetResource(STATE, & -! ORB2B_EQUINOX_HHMMSS, Label="ORB2B_EQUINOX_HHMMSS:", default=073500, & -! RC=status) -! _VERIFY(status) - -! ! create the orbit object -! STATE%ORBIT = MAPL_SunOrbitCreate(STATE%CLOCK, ECC, OB, PER, EQNX, & -! EOT, ORBIT_ANAL2B, ORB2B_YEARLEN, & -! ORB2B_REF_YYYYMMDD, ORB2B_REF_HHMMSS, & -! ORB2B_ECC_REF, ORB2B_ECC_RATE, & -! ORB2B_OBQ_REF, ORB2B_OBQ_RATE, & -! ORB2B_LAMBDAP_REF, ORB2B_LAMBDAP_RATE, & -! ORB2B_EQUINOX_YYYYMMDD, ORB2B_EQUINOX_HHMMSS, & -! FIX_SUN=FIX_SUN,RC=status) -! _VERIFY(status) - ! create the orbit object STATE%ORBIT = MAPL_SunOrbitCreateFromConfig (STATE%CF, STATE%CLOCK, FIX_SUN, _RC) From c34f7bb7bc963329f05f595064804c3a253bd757 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Tue, 10 Jan 2023 17:55:29 -0500 Subject: [PATCH 20/83] pmn: change log record --- CHANGELOG.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 658a2d04ccf..71f5ecac022 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0   solar noon via the EXAMPLE OF USE in the subroutine header. See DESCRIPTION in code for more   details. Provides the TRUE local solar hour angle (i.e., with equation of time included), but   can also provide the MEAN value (without EOT) via FORCE_MLSHA=.TRUE. optional argument. +- Changed call to MAPL_SunOrbitCreate() inside MAPL_Generic.F90 to new MAPL_SunOrbitCreateFromConfig, + the latter which get the orbital parameters from the MAPL state's Config. In this way no default + orbital parameter values need appear in MAPL_Generic.F90. Rather, these default values are encap- + sulated where they belong in Sun_Mod in base/MAPL_sun_uc.F90 and are now explicitly named and + commented at the head of the module. This is a structural zero-diff change. ### Changed From 62de6171d86ad2853e85ea3e5df0ebb9691218b7 Mon Sep 17 00:00:00 2001 From: Peter Norris Date: Wed, 11 Jan 2023 10:42:30 -0500 Subject: [PATCH 21/83] pmn: minor changes to comments, no recompilation needed --- CHANGELOG.md | 23 +++++++++++++---------- base/MAPL_sun_uc.F90 | 6 +++--- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 074c4804bb9..35000718a4c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,19 +9,22 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This provides a -  convenient local solar hour angle diagnostic which will be used to detect local -  solar noon via the EXAMPLE OF USE in the subroutine header. See DESCRIPTION in code for more -  details. Provides the TRUE local solar hour angle (i.e., with equation of time included), but -  can also provide the MEAN value (without EOT) via FORCE_MLSHA=.TRUE. optional argument. -- Changed call to MAPL_SunOrbitCreate() inside MAPL_Generic.F90 to new MAPL_SunOrbitCreateFromConfig, - the latter which get the orbital parameters from the MAPL state's Config. In this way no default - orbital parameter values need appear in MAPL_Generic.F90. Rather, these default values are encap- - sulated where they belong in Sun_Mod in base/MAPL_sun_uc.F90 and are now explicitly named and - commented at the head of the module. This is a structural zero-diff change. +- Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This + provides a convenient local solar hour angle diagnostic which will be used to detect local + solar noon via the `EXAMPLE OF USE` in the subroutine header. See `DESCRIPTION` in code + for more details. Provides the TRUE local solar hour angle (i.e., with equation of time + included), but can also provide the MEAN value (without EOT) via `FORCE_MLSHA=.TRUE.` + optional argument. ### Changed +- Changed call to `MAPL_SunOrbitCreate()` inside `MAPL_Generic.F90` to call to new function + `MAPL_SunOrbitCreateFromConfig()`, the latter which get the orbital parameters from the MAPL + state's Config. In this way no default orbital parameter values need appear in `MAPL_Generic.F90`. + Rather, these default values are encapsulated where they belong in `Sun_Mod` in `base/MAPL_sun_uc.F90` + and are now explicitly named and commented on at the head of the module. This is a structural + zero-diff change. + ### Fixed - Added the correct values to halo corner of LatLon grid diff --git a/base/MAPL_sun_uc.F90 b/base/MAPL_sun_uc.F90 index 11992e405a8..3ebd68166a1 100644 --- a/base/MAPL_sun_uc.F90 +++ b/base/MAPL_sun_uc.F90 @@ -65,9 +65,9 @@ module MAPL_SunMod ! Parameters of old orbital system (tabularized intercalation cycle) ! ------------------------------------------------------------------ real, parameter :: DEFAULT_ORBIT_ECCENTRICITY = 0.0167 - real, parameter :: DEFAULT_ORBIT_OBLIQUITY = 23.45 - real, parameter :: DEFAULT_ORBIT_PERIHELION = 102.0 - integer, parameter :: DEFAULT_ORBIT_EQUINOX = 80 + real, parameter :: DEFAULT_ORBIT_OBLIQUITY = 23.45 ! degrees + real, parameter :: DEFAULT_ORBIT_PERIHELION = 102.0 ! degrees + integer, parameter :: DEFAULT_ORBIT_EQUINOX = 80 ! days ! Parameters of new orbital system (analytic two-body), which allows some ! time-varying behavior, namely, linear variation in LAMBDAP, ECC, and OBQ. From f701a3a37d1f22080480976351ea78bac9ff1d5e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 12 Jan 2023 12:36:17 -0500 Subject: [PATCH 22/83] Fixes to actually get identity set --- Apps/Regrid_Util.F90 | 2 +- CHANGELOG.md | 7 ++++++- base/MAPL_IdentityRegridder.F90 | 10 +++++++--- base/RegridMethods.F90 | 8 ++++---- base/RegridderSpec.F90 | 18 +++++++++++++----- gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 | 14 +++++++------- gridcomps/History/MAPL_HistoryGridComp.F90 | 2 +- griddedio/GriddedIO.F90 | 9 +++++---- 8 files changed, 44 insertions(+), 26 deletions(-) diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index a018d016795..cb7aa8bd839 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -171,7 +171,7 @@ subroutine process_command_line(this,rc) if (.not.allocated(this%tripolar_file_out)) then this%tripolar_file_out = "empty" end if - this%regridMethod = get_regrid_method(regridMth) + this%regridMethod = regrid_method_string_to_int(regridMth) _ASSERT(this%regridMethod/=UNSPECIFIED_REGRID_METHOD,"improper regrid method chosen") this%filenames = split_string(cfilenames,',') diff --git a/CHANGELOG.md b/CHANGELOG.md index 642c0875ae6..e83081dced2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,11 +17,16 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Renamed `get_regrid_method` and `translate_regrid_method` to `regrid_method_string_to_int` and `regrid_method_int_to_string` + respectively in `RegridMethods.F90`. This was done so we could add `get_regrid_method` to the AbstractRegridder. The new names + more accurately reflect what the RegridMethods functions do. + ### Fixed - Added the correct values to halo corner of LatLon grid - Fixed range in halo of LatLonGridFactory -- Corrected issue with native output having metadata saying it was bilinearly regridded +- Corrected issue with native output having metadata saying it was bilinearly regridded. Now sets these files to have + `regrid_method: identity` ### Removed diff --git a/base/MAPL_IdentityRegridder.F90 b/base/MAPL_IdentityRegridder.F90 index 28dc6a517b7..f937cdf5e6c 100644 --- a/base/MAPL_IdentityRegridder.F90 +++ b/base/MAPL_IdentityRegridder.F90 @@ -45,12 +45,16 @@ module MAPL_IdentityRegridderMod function identity_regridder() result(regridder) use ESMF type (IdentityRegridder), pointer :: regridder - type (RegridderSpec), pointer :: spec + type (RegridderSpec) :: spec regridder => singleton - spec => regridder%get_spec() - spec%regrid_method = REGRID_METHOD_IDENTITY + ! Due to how MAPL is set up, the default regrid_method is + ! bilinear. But if an identity regridder is requested, we + ! want to reflect that in the metadata by updating the spec. + spec = regridder%get_spec() + call spec%set_regrid_method(REGRID_METHOD_IDENTITY) + call regridder%set_spec(spec) end function identity_regridder diff --git a/base/RegridMethods.F90 b/base/RegridMethods.F90 index 0253ab89305..33e8d23c394 100644 --- a/base/RegridMethods.F90 +++ b/base/RegridMethods.F90 @@ -18,8 +18,8 @@ module mapl_RegridMethods public :: REGRID_METHOD_CONSERVE_HFLUX public :: UNSPECIFIED_REGRID_METHOD public :: TILING_METHODS - public :: get_regrid_method - public :: translate_regrid_method + public :: regrid_method_string_to_int + public :: regrid_method_int_to_string enum, bind(c) enumerator :: REGRID_METHOD_IDENTITY @@ -41,7 +41,7 @@ module mapl_RegridMethods contains - function get_regrid_method(string_regrid_method) result(int_regrid_method) + function regrid_method_string_to_int(string_regrid_method) result(int_regrid_method) integer :: int_regrid_method character(len=*), intent(in) :: string_regrid_method @@ -78,7 +78,7 @@ function get_regrid_method(string_regrid_method) result(int_regrid_method) end select end function - function translate_regrid_method(int_regrid_method) result(string_regrid_method) + function regrid_method_int_to_string(int_regrid_method) result(string_regrid_method) integer, intent(in) :: int_regrid_method character(len=:), allocatable :: string_regrid_method diff --git a/base/RegridderSpec.F90 b/base/RegridderSpec.F90 index 0b7ca5ce385..dd4be8ad27f 100644 --- a/base/RegridderSpec.F90 +++ b/base/RegridderSpec.F90 @@ -10,7 +10,7 @@ module mapl_RegridderSpec implicit none private - + public :: RegridderSpec type :: RegridderSpec @@ -24,8 +24,9 @@ module mapl_RegridderSpec generic :: operator (==) => equals procedure :: less_than generic :: operator (<) => less_than + procedure :: set_regrid_method end type RegridderSpec - + interface RegridderSpec module procedure newRegridderSpec @@ -109,7 +110,7 @@ logical function less_than(a, b) integer (kind=INT64) :: a_out_id, b_out_id integer :: a_esmf_method, b_esmf_method - + select case (a%regrid_method) case (REGRID_METHOD_CONSERVE, REGRID_METHOD_VOTE, REGRID_METHOD_FRACTION) a_esmf_method = REGRID_METHOD_CONSERVE @@ -141,7 +142,7 @@ logical function less_than(a, b) less_than = .true. return end if - + a_out_id = get_factory_id(a%grid_out) b_out_id = get_factory_id(b%grid_out) if (a_out_id > b_out_id) then @@ -154,9 +155,16 @@ logical function less_than(a, b) less_than = .false. return - + end function less_than + subroutine set_regrid_method(this, regrid_method) + class (RegridderSpec), intent(inout) :: this + integer, intent(in) :: regrid_method + + this%regrid_method = regrid_method + end subroutine set_regrid_method + end module MAPL_RegridderSpec #undef _UNUSED_DUMMY diff --git a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 index 6c78d49c06f..f84d2936eaf 100644 --- a/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 +++ b/gridcomps/ExtData2G/ExtDataOldTypesCreator.F90 @@ -54,7 +54,7 @@ function new_ExtDataOldTypesCreator(config_file,current_time,unusable,rc ) resul _RETURN(_SUCCESS) end function new_ExtDataOldTypesCreator - + subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusable,rc) class(ExtDataOldTypesCreator), intent(inout) :: this character(len=*), intent(in) :: item_name @@ -77,7 +77,7 @@ subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusa _UNUSED_DUMMY(unusable) rule => this%rule_map%at(trim(item_name)) time_sample => this%sample_map%at(rule%sample_key) - + if(.not.associated(time_sample)) then call default_time_sample%set_defaults() time_sample=>default_time_sample @@ -106,14 +106,14 @@ subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusa primary_item%fileVars%itemType = ItemTypeScalar primary_item%fileVars%xname = trim(rule%file_var) end if - + ! regrid method if (index(rule%regrid_method,"FRACTION;")>0) then semi_pos = index(rule%regrid_method,";") read(rule%regrid_method(semi_pos+1:),*) primary_item%fracVal primary_item%trans = REGRID_METHOD_FRACTION else - primary_item%trans = get_regrid_method(rule%regrid_method) + primary_item%trans = regrid_method_string_to_int(rule%regrid_method) end if _ASSERT(primary_item%trans/=UNSPECIFIED_REGRID_METHOD,"improper regrid method chosen") @@ -131,7 +131,7 @@ subroutine fillin_primary(this,item_name,base_name,primary_item,time,clock,unusa call primary_item%update_freq%create_from_parameters(time_sample%refresh_time, & time_sample%refresh_frequency, time_sample%refresh_offset, time, clock, _RC) - disable_interpolation = .not.time_sample%time_interpolation + disable_interpolation = .not.time_sample%time_interpolation exact = time_sample%exact call primary_item%modelGridFields%comp1%set_parameters(linear_trans=rule%linear_trans,disable_interpolation=disable_interpolation,exact=exact) @@ -185,7 +185,7 @@ subroutine fillin_derived(this,item_name,derived_item,time,clock,unusable,rc) _UNUSED_DUMMY(unusable) rule => this%derived_map%at(trim(item_name)) - + derived_item%name = trim(item_name) derived_item%expression = rule%expression if (allocated(rule%sample_key)) then @@ -204,7 +204,7 @@ subroutine fillin_derived(this,item_name,derived_item,time,clock,unusable,rc) end if _RETURN(_SUCCESS) - + end subroutine fillin_derived end module MAPL_ExtDataOldTypesCreator diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 8ec9f57c8f3..b5a5e179ba4 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -931,7 +931,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_ConfigGetAttribute ( cfg, regrid_method, default="REGRID_METHOD_BILINEAR", & label=trim(string) // 'regrid_method:' ,rc=status ) _VERIFY(STATUS) - list(n)%regrid_method = get_regrid_method(trim(regrid_method)) + list(n)%regrid_method = regrid_method_string_to_int(trim(regrid_method)) end if ! Get an optional file containing a 1-D track for the output diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index 30480a13745..5ffe010cd5c 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -144,9 +144,10 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) _VERIFY(status) - ! We get the regrid_method here because we default to bilinear even in the case - ! of input_grid and this%output_grid being the same. But if the regrid_handle - ! is the identity regridder, then this will set it to REGRID_METHOD_IDENTITY + ! We get the regrid_method here because in the case of Identity, we set it to + ! REGRID_METHOD_IDENTITY in the regridder constructor if identity. Now we need + ! to change the regrid_method in the GriddedIO object to be the same as the + ! the regridder object. this%regrid_method = this%regrid_handle%get_regrid_method() call ESMF_FieldBundleSet(this%output_bundle,grid=this%output_grid,rc=status) @@ -373,7 +374,7 @@ subroutine CreateVariable(this,itemName,rc) call v%add_attribute('add_offset',0.0) call v%add_attribute('_FillValue',MAPL_UNDEF) call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) - call v%add_attribute('regrid_method', translate_regrid_method(this%regrid_method)) + call v%add_attribute('regrid_method', regrid_method_int_to_string(this%regrid_method)) call factory%append_variable_metadata(v) call this%metadata%add_variable(trim(varName),v,rc=status) _VERIFY(status) From e1cf73ca589692a3ea91eed5dd605534f2c94ec3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 12 Jan 2023 12:59:25 -0500 Subject: [PATCH 23/83] No need for setter method --- base/MAPL_IdentityRegridder.F90 | 2 +- base/RegridderSpec.F90 | 8 -------- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/base/MAPL_IdentityRegridder.F90 b/base/MAPL_IdentityRegridder.F90 index f937cdf5e6c..7b70900892d 100644 --- a/base/MAPL_IdentityRegridder.F90 +++ b/base/MAPL_IdentityRegridder.F90 @@ -53,7 +53,7 @@ function identity_regridder() result(regridder) ! bilinear. But if an identity regridder is requested, we ! want to reflect that in the metadata by updating the spec. spec = regridder%get_spec() - call spec%set_regrid_method(REGRID_METHOD_IDENTITY) + spec%regrid_method = REGRID_METHOD_IDENTITY call regridder%set_spec(spec) end function identity_regridder diff --git a/base/RegridderSpec.F90 b/base/RegridderSpec.F90 index dd4be8ad27f..f106fb19ac2 100644 --- a/base/RegridderSpec.F90 +++ b/base/RegridderSpec.F90 @@ -24,7 +24,6 @@ module mapl_RegridderSpec generic :: operator (==) => equals procedure :: less_than generic :: operator (<) => less_than - procedure :: set_regrid_method end type RegridderSpec @@ -158,13 +157,6 @@ logical function less_than(a, b) end function less_than - subroutine set_regrid_method(this, regrid_method) - class (RegridderSpec), intent(inout) :: this - integer, intent(in) :: regrid_method - - this%regrid_method = regrid_method - end subroutine set_regrid_method - end module MAPL_RegridderSpec #undef _UNUSED_DUMMY From 936a21383d1cbd1b0c4e0fe7674e396d17d6c10d Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 12 Jan 2023 13:05:23 -0500 Subject: [PATCH 24/83] Remove unneeded declarations --- griddedio/GriddedIO.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index 5ffe010cd5c..a875388e015 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -125,7 +125,6 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr integer :: metadataVarsSize type(StringStringMapIterator) :: s_iter character(len=:), pointer :: attr_name, attr_val - integer (kind=ESMF_KIND_I8) :: id_in, id_out integer :: status this%items = items From 55f014db773969bd2dde50c779aec938ad26a629 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Tue, 17 Jan 2023 21:36:35 -0500 Subject: [PATCH 25/83] Refactor MAPL_GetResource to base (largely) --- base/CMakeLists.txt | 1 + base/MAPL_Resource.F90 | 402 +++++++++++++++++++++++++++++++++++++++ generic/MAPL_Generic.F90 | 381 +------------------------------------ 3 files changed, 412 insertions(+), 372 deletions(-) create mode 100644 base/MAPL_Resource.F90 diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 091582d1e1a..cdfe87e40db 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -53,6 +53,7 @@ set (srcs TimeStringConversion.F90 MAPL_ISO8601_DateTime_ESMF.F90 FieldUtilities.F90 + MAPL_ResourceMod.F90 # Orphaned program: should not be in this library. # tstqsat.F90 ) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 new file mode 100644 index 00000000000..972fd341f1d --- /dev/null +++ b/base/MAPL_Resource.F90 @@ -0,0 +1,402 @@ +#include "MAPL_Exceptions.h" +#include "MAPL_ErrLog.h" + +!wdb TODO COMMENT if not needed +#include "unused_dummy.H" +!wdb end + +!============================================================================= + + +module MAPL_ResourceMod + + !BOP + ! !MODULE: MAPL_ResourceMod + ! + ! !DESCRIPTION: MAPL\_ResourceMod ... + + ! !USES: + +!wdb TODO what is needed + !wdb Do I need ESMF and ESMF_Mod + use ESMF + use ESMFL_Mod + use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR + use gFTL_StringVector + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 +!wdb end + + ! !PUBLIC MEMBER FUNCTIONS: + + implicit none + private + + public MAPL_GetResource_config_scalar + +contains + + !wdb TODO where is ESMF_MAXSTR defined? + ! MAPL searches for labels with certain prefixes as well as just the label itself + pure function get_labels_with_prefix(compname, label) result(labels_with_prefix) + character(len=*), intent(in) :: compname, label + character(len=ESMF_MAXSTR) :: labels_with_prefix(4), component_type + + component_type = component_name(index(component_name, ":") + 1:) + + ! The order to search for labels in resource files + labels_with_prefix(1) = trim(component_name)//"_"//trim(label) + labels_with_prefix(2) = trim(component_type)//"_"//trim(label) + labels_with_prefix(3) = trim(label) + labels_with_prefix(4) = trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) + + end function get_labels_with_prefix + + subroutine get_label_to_use(config, label, compname, label_is_present, label_to_use, rc) + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: label + character(len=*), intent(in) :: compname + logical, intent(out) :: label_is_present + character(len=ESMF_MAXSTR), intent(out) :: label_to_use + integer, optional, intent(out) :: rc + + character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) + integer :: status + + label_is_present = .false. + labels_to_try = get_labels_with_prefix(compname, label) + + do i = 1, size(labels_to_try) + label_to_use = trim(labels_to_try(i)) + call ESMF_ConfigFindLabel(config, label = label_to_use, isPresent = label_is_present, _RC) + + if (label_is_present) then + exit + end if + end do + + _RETURN(_SUCCESS) + + end subroutine get_label_to_use + + subroutine MAPL_GetResource_config_scalar(config, compname, val, label_to_find, default, rc) + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: compname + class(*), intent(inout) :: val + character(len=*), intent(in) :: label_to_find + class(*), optional, intent(in) :: default + integer, optional, intent(out) :: rc + + integer :: status, printrc + logical :: default_is_present, label_is_present + character(len=:), allocatable :: label_to_print + character(len=:), allocatable :: label + + default_is_present = present(default) + + if (default_is_present) then + _ASSERT(same_type_as(val, default), "Value and default must have same type") + end if + + call get_label_to_use(config, label_to_find, compname, label_is_present, label, _RC) + + ! No default and not in config, error + if (.not. label_is_present .and. .not. default_is_present) then + if (present(rc)) rc = ESMF_FAILURE + return + end if + + select type(val) + type is(integer(int32)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(integer(int32)) + val = default + end select + else + call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + end if + type is(integer(int64)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(integer(int64)) + val = default + end select + else + call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + end if + type is(real(real32)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(real(real32)) + val = default + end select + else + call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + end if + type is (real(real64)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(real(real64)) + val = default + end select + else + call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + end if + type is(character(len=*)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(character(len=*)) + val = trim(default) + end select + else + call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + end if + type is(logical) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(logical) + val = default + end select + else + call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + end if + class default + _FAIL( "Unupported type") + end select + + call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, _RC) + + ! Can set printrc to negative to not print at all + if (MAPL_AM_I_Root() .and. printrc >= 0) then + if (label_is_present) then + label_to_print = label + else + label_to_print = trim(label_to_find) + end if + call print_resource(printrc, label_to_print, val, default=default, _RC) + end if + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_GetResource_config_scalar + + subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, default, rc) + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: compname + character(len=*), intent(in) :: label_to_find + class(*), intent(inout) :: vals(:) + class(*), optional, intent(in) :: default(:) + integer, optional, intent(out) :: rc + + character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) + character(len=:), allocatable :: label_to_use + integer :: i, status, count + logical :: label_is_present, default_is_present + + default_is_present = present(default) + + if (default_is_present) then + _ASSERT(same_type_as(vals, default), "Value and default must have same type") + end if + + call get_label_to_use(config, label_to_find, compname, label_is_present, label_to_use, _RC) + + ! No default and not in config, error + if (.not. label_is_present .and. .not. default_is_present) then + if (present(rc)) rc = ESMF_FAILURE + return + end if + + count = size(vals) + + select type(vals) + type is(integer(int32)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(integer(int32)) + if (.not. label_is_present) vals = default + end select + else + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + end if + type is(integer(int64)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(integer(int64)) + vals = default + end select + else + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + end if + type is(real(real32)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(integer(real32)) + vals = default + end select + else + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + end if + type is (real(real64)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(integer(real64)) + vals = default + end select + else + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + end if + type is(character(len=*)) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(character(*)) + vals = default + end select + else + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + end if + type is(logical) + if (default_is_present .and. .not. label_is_present) then + select type(default) + type is(logical) + vals = default + end select + else + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + end if + class default + _FAIL( "Unsupported type") + end select + + _RETURN(ESMF_SUCCESS) + + end subroutine MAPL_GetResource_config_array + + subroutine print_resource(printrc, label, val, default, rc) + integer, intent(in) :: printrc + character(len=*), intent(in) :: label + class(*), intent(in) :: val + class(*), optional, intent(in) :: default + integer, optional, intent(out) :: rc + + character(len=:), allocatable :: val_str, default_str, output_format, type_str, type_format + type(StringVector), pointer, save :: already_printed_labels => null() + + if (.not. associated(already_printed_labels)) then + allocate(already_printed_labels) + end if + + ! Do not print label more than once + if (.not. vector_contains_str(already_printed_labels, trim(label))) then + call already_printed_labels%push_back(trim(label)) + else + return + end if + + select type(val) + type is(integer(int32)) + type_str = "'Integer*4 '" + type_format = '(i0.1)' + val_str = intrinsic_to_string(val, type_format) + if (present(default)) then + default_str = intrinsic_to_string(default, type_format) + end if + type is(integer(int64)) + type_str = "'Integer*8 '" + type_format = '(i0.1)' + val_str = intrinsic_to_string(val, type_format) + if (present(default)) then + default_str = intrinsic_to_string(default, type_format) + end if + type is(real(real32)) + type_str = "'Real*4 '" + type_format = '(f0.6)' + val_str = intrinsic_to_string(val, type_format) + if (present(default)) then + default_str = intrinsic_to_string(default, type_format) + end if + type is(real(real64)) + type_str = "'Real*8 '" + type_format = '(f0.6)' + val_str = intrinsic_to_string(val, type_format) + if (present(default)) then + default_str = intrinsic_to_string(default, type_format) + end if + type is(logical) + type_str = "'Logical '" + type_format = '(l1)' + val_str = intrinsic_to_string(val, type_format) + if (present(default)) then + default_str = intrinsic_to_string(default, type_format) + end if + type is(character(len=*)) + type_str = "'Character '" + val_str = trim(val) + if (present(default)) then + default_str = intrinsic_to_string(default, 'a') + end if + class default + _FAIL("Unsupported type") + end select + + output_format = "(1x, " // type_str // ", 'Resource Parameter: '" // ", a"// ", a)" + + ! printrc = 0 - Only print non-default values + ! printrc = 1 - Print all values + if (present(default)) then + if (trim(val_str) /= trim(default_str) .or. printrc == 1) then + print output_format, trim(label), trim(val_str) + end if + else + print output_format, trim(label), trim(val_str) + end if + + end subroutine print_resource + + logical function vector_contains_str(vector, string) + type(StringVector), intent(in) :: vector + character(len=*), intent(in) :: string + type(StringVectorIterator) :: iter + + iter = vector%begin() + + vector_contains_str = .false. + + if (vector%size() /= 0) then + do while (iter /= vector%end()) + if (trim(string) == iter%get()) then + vector_contains_str = .true. + return + end if + call iter%next() + end do + end if + + end function vector_contains_str + + function intrinsic_to_string(val, str_format, rc) result(formatted_str) + class(*), intent(in) :: val + character(len=*), intent(in) :: str_format + character(len=256) :: formatted_str + integer, optional, intent(out) :: rc + + select type(val) + type is(integer(int32)) + write(formatted_str, str_format) val + type is(integer(int64)) + write(formatted_str, str_format) val + type is(real(real32)) + write(formatted_str, str_format) val + type is(real(real64)) + write(formatted_str, str_format) val + type is(logical) + write(formatted_str, str_format) val + type is(character(len=*)) + formatted_str = trim(val) + class default + _FAIL( "Unsupported type in intrinsic_to_string") + end select + + end function intrinsic_to_string + +end module MAPL_ResourceMod diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index ed77a88b2b3..03122deed54 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -134,6 +134,7 @@ module MAPL_GenericMod use MaplShared, only: SYSTEM_DSO_EXTENSION, adjust_dso_name, is_valid_dso_name, is_supported_dso_name use MaplShared, only: get_file_extension use MAPL_RunEntryPoint + use MAPL_ResourceMod use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 use, intrinsic :: iso_fortran_env, only: OUTPUT_UNIT @@ -8422,22 +8423,6 @@ recursive subroutine MAPL_GenericConnCheck(GC, RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericConnCheck - - ! MAPL searches for labels with certain prefixes as well as just the label itself - pure function get_labels_with_prefix(component_name, label) result(labels_with_prefix) - character(len=*), intent(in) :: component_name, label - character(len=ESMF_MAXSTR) :: labels_with_prefix(4), component_type - - component_type = component_name(index(component_name, ":") + 1:) - - ! The order to search for labels in resource files - labels_with_prefix(1) = trim(component_name)//"_"//trim(label) - labels_with_prefix(2) = trim(component_type)//"_"//trim(label) - labels_with_prefix(3) = trim(label) - labels_with_prefix(4) = trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) - end function get_labels_with_prefix - - subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) type(MAPL_MetaComp), intent(inout) :: state character(len=*), intent(in) :: label @@ -8445,150 +8430,30 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) class(*), optional, intent(in) :: default integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) - character(len=:), allocatable :: label_to_use - integer :: i, status - logical :: label_is_present, default_is_present - - default_is_present = present(default) - - if (default_is_present) then - _ASSERT(same_type_as(val, default), "Value and default must have same type") - end if - - label_is_present = .false. - labels_to_try = get_labels_with_prefix(state%compname, label) - - do i = 1, size(labels_to_try) - label_to_use = trim(labels_to_try(i)) - call ESMF_ConfigFindLabel(state%cf, label = label_to_use, isPresent = label_is_present, rc = status) - _VERIFY(status) - - if (label_is_present) then - exit - end if - end do - - if (.not. label_is_present .and. .not. default_is_present) then - if (present(rc)) rc = ESMF_FAILURE - return - end if + integer :: status - if (label_is_present) then - call MAPL_GetResourceFromConfig_Scalar(state%cf,val,label_to_use,default,rc = status) - _VERIFY(status) - else - call MAPL_GetResourceFromConfig_Scalar(state%cf,val,label,default,rc = status) - _VERIFY(status) - end if + call MAPL_GetResourceFromConfig_scalar(state%cf, state%compname, val, label, default, _RC) _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromMAPL_scalar - subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) + subroutine MAPL_GetResourceFromConfig_scalar(config, compname, val, label, default, rc) type(ESMF_Config), intent(inout) :: config + character(*), intent(in) :: compname character(len=*), intent(in) :: label class(*), intent(inout) :: val class(*), optional, intent(in) :: default integer, optional, intent(out) :: rc - integer :: status, printrc - logical :: default_is_present, label_is_present - character(len=:), allocatable :: label_to_print - - default_is_present = present(default) - - if (default_is_present) then - _ASSERT(same_type_as(val, default), "Value and default must have same type") - end if - - call ESMF_ConfigFindLabel(config, label = label, isPresent = label_is_present, rc = status) - - select type(val) - type is(integer(int32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int32)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(integer(int64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int64)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(real(real32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(real(real32)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is (real(real64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(real(real64)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(character(len=*)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(character(len=*)) - val = trim(default) - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - type is(logical) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(logical) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = label, rc = status) - _VERIFY(status) - end if - class default - _FAIL( "Unupported type") - end select + integer :: status - call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, rc = status) - _VERIFY(status) - - ! Can set printrc to negative to not print at all - if (MAPL_AM_I_Root() .and. printrc >= 0) then - if (label_is_present) then - label_to_print = label - else - label_to_print = trim(label) - end if - call print_resource(printrc, label_to_print, val, default=default,rc=status) - _VERIFY(status) - end if + call MAPL_GetResource_config_scalar(config, compname, val, label, default, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GetResourceFromConfig_scalar - subroutine MAPL_GetResource_array(state, vals, label, default, rc) type(MAPL_MetaComp), intent(inout) :: state character(len=*), intent(in) :: label @@ -8596,242 +8461,14 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) class(*), optional, intent(in) :: default(:) integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) - character(len=:), allocatable :: label_to_use - integer :: i, status, count - logical :: label_is_present, default_is_present - - default_is_present = present(default) - - if (default_is_present) then - _ASSERT(same_type_as(vals, default), "Value and default must have same type") - end if - - labels_to_try = get_labels_with_prefix(state%compname, label) - label_is_present = .false. - - ! Try out the label variations to see which one exists in the ESMF_Config - do i = 1, size(labels_to_try) - label_to_use = trim(labels_to_try(i)) - - call ESMF_ConfigFindLabel(state%cf, label = label_to_use, isPresent = label_is_present, rc = status) - _VERIFY(status) - - if (label_is_present) then - exit - end if - end do - - ! No default and not in config, error - if (.not. label_is_present .and. .not. default_is_present) then - if (present(rc)) rc = ESMF_FAILURE - return - end if + integer :: status - count = size(vals) - - select type(vals) - type is(integer(int32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int32)) - if (.not. label_is_present) vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(integer(int64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int64)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(real(real32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(real32)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is (real(real64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(real64)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(character(len=*)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(character(*)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - type is(logical) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(logical) - vals = default - end select - else - call ESMF_ConfigGetAttribute(state%cf, valuelist = vals, count = count, label = label_to_use, rc = status) - _VERIFY(status) - end if - class default - _FAIL( "Unsupported type") - end select + call MAPL_GetResource_config_array(state%cf, state%compname, vals, label, default, _RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GetResource_array - - subroutine print_resource(printrc, label, val, default, rc) - integer, intent(in) :: printrc - character(len=*), intent(in) :: label - class(*), intent(in) :: val - class(*), optional, intent(in) :: default - integer, optional, intent(out) :: rc - - character(len=:), allocatable :: val_str, default_str, output_format, type_str, type_format - type(StringVector), pointer, save :: already_printed_labels => null() - - if (.not. associated(already_printed_labels)) then - allocate(already_printed_labels) - end if - - ! Do not print label more than once - if (.not. vector_contains_str(already_printed_labels, trim(label))) then - call already_printed_labels%push_back(trim(label)) - else - return - end if - - select type(val) - type is(integer(int32)) - type_str = "'Integer*4 '" - type_format = '(i0.1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(integer(int64)) - type_str = "'Integer*8 '" - type_format = '(i0.1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(real(real32)) - type_str = "'Real*4 '" - type_format = '(f0.6)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(real(real64)) - type_str = "'Real*8 '" - type_format = '(f0.6)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(logical) - type_str = "'Logical '" - type_format = '(l1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(character(len=*)) - type_str = "'Character '" - val_str = trim(val) - if (present(default)) then - default_str = intrinsic_to_string(default, 'a') - end if - class default - _FAIL("Unsupported type") - end select - - output_format = "(1x, " // type_str // ", 'Resource Parameter: '" // ", a"// ", a)" - - ! printrc = 0 - Only print non-default values - ! printrc = 1 - Print all values - if (present(default)) then - if (trim(val_str) /= trim(default_str) .or. printrc == 1) then - print output_format, trim(label), trim(val_str) - end if - else - print output_format, trim(label), trim(val_str) - end if - - contains - - logical function vector_contains_str(vector, string) - type(StringVector), intent(in) :: vector - character(len=*), intent(in) :: string - type(StringVectorIterator) :: iter - - iter = vector%begin() - - vector_contains_str = .false. - - if (vector%size() /= 0) then - do while (iter /= vector%end()) - if (trim(string) == iter%get()) then - vector_contains_str = .true. - return - end if - call iter%next() - end do - end if - - end function vector_contains_str - - end subroutine print_resource - - - function intrinsic_to_string(val, str_format, rc) result(formatted_str) - class(*), intent(in) :: val - character(len=*), intent(in) :: str_format - character(len=256) :: formatted_str - integer, optional, intent(out) :: rc - - select type(val) - type is(integer(int32)) - write(formatted_str, str_format) val - type is(integer(int64)) - write(formatted_str, str_format) val - type is(real(real32)) - write(formatted_str, str_format) val - type is(real(real64)) - write(formatted_str, str_format) val - type is(logical) - write(formatted_str, str_format) val - type is(character(len=*)) - formatted_str = trim(val) - class default - _FAIL( "Unsupported type in intrinsic_to_string") - end select - - end function intrinsic_to_string - - - integer function MAPL_GetNumSubtiles(STATE, RC) type (MAPL_MetaComp), intent(INOUT) :: STATE integer , optional, intent( OUT) :: RC From f5b1b0f1a01bfedb458540ba2365a59c027d01e2 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 19 Jan 2023 15:10:44 -0500 Subject: [PATCH 26/83] Create MAPL.profiler logger --- CHANGELOG.md | 1 + base/ApplicationSupport.F90 | 22 +++++++------ generic/MAPL_Generic.F90 | 13 +++++--- gridcomps/Cap/MAPL_Cap.F90 | 66 ++++++++++++++++++------------------- 4 files changed, 54 insertions(+), 48 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 28a8c6f7ff7..77cb0fff591 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -27,6 +27,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 Rather, these default values are encapsulated where they belong in `Sun_Mod` in `base/MAPL_sun_uc.F90` and are now explicitly named and commented on at the head of the module. This is a structural zero-diff change. +- Created `MAPL.profiler` logger and moved throughput, per-component, and global timers to use it ### Fixed diff --git a/base/ApplicationSupport.F90 b/base/ApplicationSupport.F90 index 0eac83a95c4..9cb744b7e7e 100644 --- a/base/ApplicationSupport.F90 +++ b/base/ApplicationSupport.F90 @@ -23,7 +23,7 @@ subroutine MAPL_Initialize(unusable,comm,logging_config,rc) character(:), allocatable :: logging_configuration_file integer :: comm_world,status - + _UNUSED_DUMMY(unusable) if (present(logging_config)) then @@ -55,7 +55,7 @@ subroutine MAPL_Finalize(unusable,comm,rc) integer :: comm_world,status _UNUSED_DUMMY(unusable) - + if (present(comm)) then comm_world = comm else @@ -137,7 +137,7 @@ subroutine initialize_pflogger(unusable,comm,logging_config,rc) if (rank == 0) then lgr => logging%get_logger('MAPL') - call lgr%warning('No configure file specified for logging layer. Using defaults.') + call lgr%warning('No configure file specified for logging layer. Using defaults.') end if end if @@ -158,6 +158,7 @@ subroutine report_global_profiler(unusable,comm,rc) integer :: npes, my_rank, ierror character(1) :: empty(0) class (BaseProfiler), pointer :: t_p + type(Logger), pointer :: lgr _UNUSED_DUMMY(unusable) if (present(comm)) then @@ -185,13 +186,14 @@ subroutine report_global_profiler(unusable,comm,rc) call MPI_Comm_Rank(world_comm, my_rank, ierror) if (my_rank == 0) then - report_lines = reporter%generate_report(t_p) - write(*,'(a,1x,i0)')'Report on process: ', my_rank - do i = 1, size(report_lines) - write(*,'(a)') report_lines(i) - end do - end if - call MPI_Barrier(world_comm, ierror) + report_lines = reporter%generate_report(t_p) + lgr => logging%get_logger('MAPL.profiler') + call lgr%info('Report on process: %i0', my_rank) + do i = 1, size(report_lines) + call lgr%info('%a', report_lines(i)) + end do + end if + call MPI_Barrier(world_comm, ierror) end subroutine report_global_profiler diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index d29db2dcce8..a8eb7bd9a81 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -2277,10 +2277,13 @@ subroutine report_generic_profile( rc ) type (MultiColumn) :: min_multi, mean_multi, max_multi, pe_multi, n_cyc_multi type (ESMF_VM) :: vm character(1) :: empty(0) + class(Logger), pointer :: lgr call ESMF_VmGetCurrent(vm, rc=status) _VERIFY(status) + lgr => logging%get_logger('MAPL.profiler') + ! Generate stats _across_ processes covered by this timer ! Requires consistent call trees for now. @@ -2325,12 +2328,12 @@ subroutine report_generic_profile( rc ) report = reporter%generate_report(state%t_profiler) - write(OUTPUT_UNIT,*)'' - write(OUTPUT_UNIT,*)'Times for component <' // trim(comp_name) // '>' + call lgr%info('') + call lgr%info('Times for component <%a~>', trim(comp_name)) do i = 1, size(report) - write(OUTPUT_UNIT,'(a)')report(i) + call lgr%info('%a', report(i)) end do - write(OUTPUT_UNIT,*)'' + call lgr%info('') end if _RETURN(ESMF_SUCCESS) @@ -4082,7 +4085,7 @@ subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & if(.not.MAPL_SunOrbitCreated(STATE%ORBIT)) then call ESMF_GridGet(STATE%GRID%ESMFGRID,name=gname,_RC) - FIX_SUN = (index(gname,"DP")>0) + FIX_SUN = (index(gname,"DP")>0) ! create the orbit object STATE%ORBIT = MAPL_SunOrbitCreateFromConfig (STATE%CF, STATE%CLOCK, FIX_SUN, _RC) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 624257ffdb5..31da5adba1f 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -26,11 +26,11 @@ module MAPL_CapMod character(:), allocatable :: name procedure(), nopass, pointer :: set_services => null() logical :: non_dso = .false. - integer :: comm_world + integer :: comm_world integer :: rank integer :: npes_member character(:), allocatable :: root_dso - + type (MAPL_CapOptions), allocatable :: cap_options ! misc logical :: mpi_already_initialized = .false. @@ -60,7 +60,7 @@ module MAPL_CapMod procedure :: get_cap_gc procedure :: get_cap_rc_file procedure :: get_egress_file - + end type MAPL_Cap interface MAPL_Cap @@ -85,7 +85,7 @@ function new_MAPL_Cap_from_set_services(name, set_services, unusable, cap_option class (KeywordEnforcer), optional, intent(in) :: unusable type ( MAPL_CapOptions), optional, intent(in) :: cap_options integer, optional, intent(out) :: rc - integer :: status + integer :: status cap%name = name cap%set_services => set_services @@ -112,7 +112,7 @@ function new_MAPL_Cap_from_set_services(name, set_services, unusable, cap_option rc=status) _VERIFY(status) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) end function new_MAPL_Cap_from_set_services @@ -123,7 +123,7 @@ function new_MAPL_Cap_from_dso(name, unusable, cap_options, rc) result(cap) class (KeywordEnforcer), optional, intent(in) :: unusable type ( MAPL_CapOptions), optional, intent(in) :: cap_options integer, optional, intent(out) :: rc - integer :: status + integer :: status cap%name = name @@ -148,12 +148,12 @@ function new_MAPL_Cap_from_dso(name, unusable, cap_options, rc) result(cap) rc=status) _VERIFY(status) - _RETURN(_SUCCESS) + _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) end function new_MAPL_Cap_from_dso - + ! 3. Run the ensemble (default is 1 member) ! 4. Finalize MPI if initialized locally. subroutine run(this, unusable, rc) @@ -162,7 +162,7 @@ subroutine run(this, unusable, rc) integer, optional, intent(out) :: rc integer :: status ! - + _UNUSED_DUMMY(unusable) @@ -172,7 +172,7 @@ subroutine run(this, unusable, rc) _RETURN(_SUCCESS) end subroutine run - + ! This layer splits the communicator to support running a ! multi-member ensemble. @@ -185,7 +185,7 @@ subroutine run_ensemble(this, unusable, rc) integer :: subcommunicator _UNUSED_DUMMY(unusable) - + subcommunicator = this%create_member_subcommunicator(this%comm_world, rc=status); _VERIFY(status) if (subcommunicator /= MPI_COMM_NULL) then call this%initialize_io_clients_servers(subcommunicator, rc = status); _VERIFY(status) @@ -195,7 +195,7 @@ subroutine run_ensemble(this, unusable, rc) end if _RETURN(_SUCCESS) - + end subroutine run_ensemble @@ -214,7 +214,7 @@ subroutine finalize_io_clients_servers(this, unusable, rc) end select call this%cap_server%finalize() _RETURN(_SUCCESS) - + end subroutine finalize_io_clients_servers subroutine initialize_io_clients_servers(this, comm, unusable, rc) @@ -241,14 +241,14 @@ subroutine initialize_io_clients_servers(this, comm, unusable, rc) _RETURN(_SUCCESS) end subroutine initialize_io_clients_servers - + ! This layer splits the communicator to support separate i/o servers ! and runs the model via a CapGridComp. subroutine run_member(this, rc) use MAPL_CFIOMod class (MAPL_Cap), intent(inout) :: this integer, optional, intent(out) :: rc - + integer :: status type(SplitCommunicator) :: split_comm @@ -257,7 +257,7 @@ subroutine run_member(this, rc) case('model') call this%run_model(comm=split_comm%get_subcommunicator(), rc=status); _VERIFY(status) end select - + _RETURN(_SUCCESS) end subroutine run_member @@ -273,7 +273,7 @@ subroutine run_model(this, comm, unusable, rc) integer(kind=INT64) :: start_tick, stop_tick, tick_rate integer :: status class(Logger), pointer :: lgr - + _UNUSED_DUMMY(unusable) call start_timer() @@ -336,14 +336,14 @@ subroutine report_throughput(rc) model_days_per_day = model_duration / wall_time - lgr => logging%get_logger('MAPL') + lgr => logging%get_logger('MAPL.profiler') call lgr%info("Model Throughput: %f12.3 days per day", model_days_per_day) end if - + end subroutine report_throughput end subroutine run_model - + subroutine initialize_cap_gc(this, unusable, n_run_phases, rc) class(MAPL_Cap), intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable @@ -357,7 +357,7 @@ subroutine initialize_cap_gc(this, unusable, n_run_phases, rc) if (this%non_dso) then call MAPL_CapGridCompCreate(this%cap_gc, this%get_cap_rc_file(), & this%name, this%get_egress_file(), n_run_phases=n_run_phases, root_set_services = this%set_services,rc=status) - else + else _ASSERT(this%cap_options%root_dso /= 'none',"No set services specified, must pass a dso") call MAPL_CapGridCompCreate(this%cap_gc, this%get_cap_rc_file(), & this%name, this%get_egress_file(), n_run_phases=n_run_phases, root_dso = this%cap_options%root_dso,rc=status) @@ -365,7 +365,7 @@ subroutine initialize_cap_gc(this, unusable, n_run_phases, rc) _VERIFY(status) _RETURN(_SUCCESS) end subroutine initialize_cap_gc - + subroutine step_model(this, rc) class(MAPL_Cap), intent(inout) :: this @@ -374,7 +374,7 @@ subroutine step_model(this, rc) call this%cap_gc%step(rc = status); _VERIFY(status) _RETURN(_SUCCESS) end subroutine step_model - + subroutine rewind_model(this, time, rc) class(MAPL_Cap), intent(inout) :: this type(ESMF_Time), intent(inout) :: time @@ -382,14 +382,14 @@ subroutine rewind_model(this, time, rc) integer :: status call this%cap_gc%rewind_clock(time,rc = status); _VERIFY(status) _RETURN(_SUCCESS) - end subroutine rewind_model + end subroutine rewind_model integer function create_member_subcommunicator(this, comm, unusable, rc) result(subcommunicator) class (MAPL_Cap), intent(inout) :: this integer, intent(in) :: comm class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - + type (SplitCommunicator) :: split_comm integer :: status @@ -397,7 +397,7 @@ integer function create_member_subcommunicator(this, comm, unusable, rc) result( !!$ external :: chdir _UNUSED_DUMMY(unusable) - + subcommunicator = MPI_COMM_NULL ! in case of failure this%splitter = SimpleCommSplitter(comm, this%cap_options%n_members, this%npes_member, base_name=this%cap_options%ensemble_subdir_prefix) split_comm = this%splitter%split(rc=status); _VERIFY(status) @@ -408,9 +408,9 @@ integer function create_member_subcommunicator(this, comm, unusable, rc) result( status = c_chdir(dir_name) _VERIFY(status) end if - + _RETURN(_SUCCESS) - + end function create_member_subcommunicator @@ -459,13 +459,13 @@ subroutine chdir(path, err) character(*) :: path integer, optional, intent(out) :: err integer :: loc_err - + loc_err = c_chdir(path//c_null_char) - + if (present(err)) err = loc_err - + end subroutine chdir - + subroutine finalize_mpi(this, unusable, rc) class (MAPL_Cap), intent(in) :: this class (KeywordEnforcer), optional, intent(in) :: unusable @@ -488,7 +488,7 @@ function get_npes_model(this) result(npes_model) integer :: npes_model npes_model = this%cap_options%npes_model end function get_npes_model - + function get_comm_world(this) result(comm_world) class(MAPL_Cap), intent(in) :: this integer :: comm_world From 49ff2bbe8935c0c2a60c0289070f0a0e8686128e Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 20 Jan 2023 10:53:27 -0500 Subject: [PATCH 27/83] Commit first successful compile run --- base/CMakeLists.txt | 2 +- base/MAPL_Resource.F90 | 28 ++++++++++++++++++---------- generic/MAPL_Generic.F90 | 7 +++---- 3 files changed, 22 insertions(+), 15 deletions(-) diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index cdfe87e40db..c885f862d59 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -53,7 +53,7 @@ set (srcs TimeStringConversion.F90 MAPL_ISO8601_DateTime_ESMF.F90 FieldUtilities.F90 - MAPL_ResourceMod.F90 + MAPL_Resource.F90 # Orphaned program: should not be in this library. # tstqsat.F90 ) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 972fd341f1d..9f4ccb56f67 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -21,8 +21,10 @@ module MAPL_ResourceMod !wdb Do I need ESMF and ESMF_Mod use ESMF use ESMFL_Mod - use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR use gFTL_StringVector + use MAPL_CommsMod + use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR + use MAPL_ExceptionHandling use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 !wdb end @@ -32,6 +34,7 @@ module MAPL_ResourceMod private public MAPL_GetResource_config_scalar + public MAPL_GetResource_config_array contains @@ -41,13 +44,13 @@ pure function get_labels_with_prefix(compname, label) result(labels_with_prefix) character(len=*), intent(in) :: compname, label character(len=ESMF_MAXSTR) :: labels_with_prefix(4), component_type - component_type = component_name(index(component_name, ":") + 1:) + component_type = compname(index(compname, ":") + 1:) ! The order to search for labels in resource files - labels_with_prefix(1) = trim(component_name)//"_"//trim(label) + labels_with_prefix(1) = trim(compname)//"_"//trim(label) labels_with_prefix(2) = trim(component_type)//"_"//trim(label) labels_with_prefix(3) = trim(label) - labels_with_prefix(4) = trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) + labels_with_prefix(4) = trim(compname)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) end function get_labels_with_prefix @@ -56,10 +59,11 @@ subroutine get_label_to_use(config, label, compname, label_is_present, label_to_ character(len=*), intent(in) :: label character(len=*), intent(in) :: compname logical, intent(out) :: label_is_present - character(len=ESMF_MAXSTR), intent(out) :: label_to_use + character(len=:), allocatable, intent(out) :: label_to_use integer, optional, intent(out) :: rc character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) + integer :: i integer :: status label_is_present = .false. @@ -78,12 +82,12 @@ subroutine get_label_to_use(config, label, compname, label_is_present, label_to_ end subroutine get_label_to_use - subroutine MAPL_GetResource_config_scalar(config, compname, val, label_to_find, default, rc) + subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, compname, rc) type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: compname class(*), intent(inout) :: val character(len=*), intent(in) :: label_to_find class(*), optional, intent(in) :: default + character(len=*), optional, intent(in) :: compname integer, optional, intent(out) :: rc integer :: status, printrc @@ -97,7 +101,12 @@ subroutine MAPL_GetResource_config_scalar(config, compname, val, label_to_find, _ASSERT(same_type_as(val, default), "Value and default must have same type") end if - call get_label_to_use(config, label_to_find, compname, label_is_present, label, _RC) + if (present(compname)) then + call get_label_to_use(config, label_to_find, compname, label_is_present, label, _RC) + else + label = label_to_find + call ESMF_ConfigFindLabel(config, label = label, isPresent = label_is_present, _RC) + end if ! No default and not in config, error if (.not. label_is_present .and. .not. default_is_present) then @@ -188,9 +197,8 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, class(*), optional, intent(in) :: default(:) integer, optional, intent(out) :: rc - character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) character(len=:), allocatable :: label_to_use - integer :: i, status, count + integer :: status, count logical :: label_is_present, default_is_present default_is_present = present(default) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 03122deed54..68e62d33776 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8432,15 +8432,14 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) integer :: status - call MAPL_GetResourceFromConfig_scalar(state%cf, state%compname, val, label, default, _RC) + call MAPL_GetResource_config_scalar(state%cf, val, label, default, state%compname, _RC) _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromMAPL_scalar - subroutine MAPL_GetResourceFromConfig_scalar(config, compname, val, label, default, rc) + subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) type(ESMF_Config), intent(inout) :: config - character(*), intent(in) :: compname character(len=*), intent(in) :: label class(*), intent(inout) :: val class(*), optional, intent(in) :: default @@ -8448,7 +8447,7 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, compname, val, label, defau integer :: status - call MAPL_GetResource_config_scalar(config, compname, val, label, default, _RC) + call MAPL_GetResource_config_scalar(config, val, label, default, _RC) _RETURN(ESMF_SUCCESS) From 6df02cbdfcf56f64f5966e9d783711e2a5e4d979 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 20 Jan 2023 12:37:46 -0500 Subject: [PATCH 28/83] test optional argument arrdes before using it --- CHANGELOG.md | 1 + base/NCIO.F90 | 81 +++++++++++++++++++++++++++++++-------------------- 2 files changed, 50 insertions(+), 32 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 28a8c6f7ff7..4e3697679f6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -30,6 +30,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Tested optiona arguments arrdes in MAPL_WriteVars - Added the correct values to halo corner of LatLon grid - Fixed range in halo of LatLonGridFactory - Corrected issue with native output having metadata saying it was bilinearly regridded. Now sets these files to have diff --git a/base/NCIO.F90 b/base/NCIO.F90 index b0660558c28..26913807f67 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -614,7 +614,7 @@ subroutine MAPL_VarWriteNCpar_R4_4d(formatter, name, A, ARRDES, oClients, RC) type(Netcdf4_Fileformatter) , intent(IN ) :: formatter character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:,:,:) - type(ArrDescr) , intent(INOUT) :: ARRDES + type(ArrDescr), optional , intent(INOUT) :: ARRDES type (ClientManager), optional, intent(inout) :: oClients integer, optional , intent( OUT) :: RC @@ -623,29 +623,39 @@ subroutine MAPL_VarWriteNCpar_R4_4d(formatter, name, A, ARRDES, oClients, RC) integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1,1], & - global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + if (present(arrdes)) then + if (arrdes%write_restart_by_oserver) then + _ASSERT(present(oClients), "output server is needed") + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1,1], & + global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + else + do K = 1,size(A,4) + do L = 1,size(A,3) + call MAPL_VarWrite(formatter, name, A(:,:,L,K), arrdes=arrdes, & + & oClients=oClients, lev=l, offset2=k, rc=status) + _VERIFY(status) + end do + end do + end if else - do K = 1,size(A,4) do L = 1,size(A,3) - call MAPL_VarWrite(formatter, name, A(:,:,L,K), arrdes=arrdes, & + call MAPL_VarWrite(formatter, name, A(:,:,L,K), & & oClients=oClients, lev=l, offset2=k, rc=status) _VERIFY(status) end do - end do - end if + enddo + endif + _RETURN(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R4_4d @@ -706,22 +716,29 @@ subroutine MAPL_VarWriteNCpar_R4_3d(formatter, name, A, ARRDES, oClients, RC) integer :: i1, j1, in, jn, global_dim(3) type(ArrayReference) :: ref - if (arrdes%write_restart_by_oserver) then - _ASSERT(present(oClients), "output server is needed") - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1], & - global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + if (present(arrdes)) then + if (arrdes%write_restart_by_oserver) then + _ASSERT(present(oClients), "output server is needed") + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1], & + global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + else + do l=1,size(a,3) + call MAPL_VarWrite(formatter,name,A(:,:,l), arrdes=arrdes,lev=l, rc=status) + _VERIFY(status) + enddo + endif else do l=1,size(a,3) - call MAPL_VarWrite(formatter,name,A(:,:,l), arrdes=arrdes,lev=l, rc=status) + call MAPL_VarWrite(formatter,name,A(:,:,l), lev=l, rc=status) _VERIFY(status) enddo endif From 400f6be8cec4d544985cc6171f0cde990025d42d Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 20 Jan 2023 13:56:18 -0500 Subject: [PATCH 29/83] Update comments --- base/MAPL_Resource.F90 | 15 ++++++++------- generic/MAPL_Generic.F90 | 2 ++ 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 9f4ccb56f67..27864192732 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -1,9 +1,6 @@ #include "MAPL_Exceptions.h" #include "MAPL_ErrLog.h" - -!wdb TODO COMMENT if not needed #include "unused_dummy.H" -!wdb end !============================================================================= @@ -17,8 +14,6 @@ module MAPL_ResourceMod ! !USES: -!wdb TODO what is needed - !wdb Do I need ESMF and ESMF_Mod use ESMF use ESMFL_Mod use gFTL_StringVector @@ -26,7 +21,6 @@ module MAPL_ResourceMod use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR use MAPL_ExceptionHandling use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 -!wdb end ! !PUBLIC MEMBER FUNCTIONS: @@ -38,7 +32,6 @@ module MAPL_ResourceMod contains - !wdb TODO where is ESMF_MAXSTR defined? ! MAPL searches for labels with certain prefixes as well as just the label itself pure function get_labels_with_prefix(compname, label) result(labels_with_prefix) character(len=*), intent(in) :: compname, label @@ -54,6 +47,8 @@ pure function get_labels_with_prefix(compname, label) result(labels_with_prefix) end function get_labels_with_prefix + ! If possible, find label or label with prefix. Out: logical to if label found, + ! version of label found, subroutine get_label_to_use(config, label, compname, label_is_present, label_to_use, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: label @@ -82,6 +77,7 @@ subroutine get_label_to_use(config, label, compname, label_is_present, label_to_ end subroutine get_label_to_use + ! Find value of scalar variable in config subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, compname, rc) type(ESMF_Config), intent(inout) :: config class(*), intent(inout) :: val @@ -101,6 +97,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c _ASSERT(same_type_as(val, default), "Value and default must have same type") end if + ! If compname is present, find label in some form in config. Else search + ! for exact label if (present(compname)) then call get_label_to_use(config, label_to_find, compname, label_is_present, label, _RC) else @@ -109,6 +107,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c end if ! No default and not in config, error + ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then if (present(rc)) rc = ESMF_FAILURE return @@ -189,6 +188,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c end subroutine MAPL_GetResource_config_scalar + ! Find value of array variable in config subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, default, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: compname @@ -210,6 +210,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, call get_label_to_use(config, label_to_find, compname, label_is_present, label_to_use, _RC) ! No default and not in config, error + ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then if (present(rc)) rc = ESMF_FAILURE return diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 68e62d33776..e16de4b4920 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8438,6 +8438,8 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) end subroutine MAPL_GetResourceFromMAPL_scalar + ! This is a pass-through routine. It maintains the interface for + ! MAPL_GetResource as is instead of moving this subroutine to another module. subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: label From eeb9f5fb3afe40abea18d6a1328d76268ae92486 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 20 Jan 2023 14:07:05 -0500 Subject: [PATCH 30/83] Update CHANGELOG.md --- CHANGELOG.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2b7fde4838b..8326318bc8b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0   can also provide the MEAN value (without EOT) via FORCE_MLSHA=.TRUE. optional argument. ### Changed - +- Moved most of the MAPL_GetResource generic subroutine to a new module, MAPL_ResourceMod, in base. + The specific subroutines remain in MAPL_GenericMod to maintain the interface in one module, but + most of the functionality is in MAPL_ResourceMod now. ### Fixed - Added the correct values to halo corner of LatLon grid From 205f4afb7b2286d9471ec35e3cc2f83035ee3c48 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 23 Jan 2023 16:52:44 -0500 Subject: [PATCH 31/83] change the offset type to INT64 for large file --- CHANGELOG.md | 1 + pfio/MultiGroupServer.F90 | 6 +++--- pfio/ServerThread.F90 | 8 ++++---- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 28a8c6f7ff7..99d376ca7b3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -30,6 +30,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Changed the type of output counters to INT64 for large file. - Added the correct values to halo corner of LatLon grid - Fixed range in halo of LatLonGridFactory - Corrected issue with native output having metadata saying it was bilinearly regridded. Now sets these files to have diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index ec8ef6ab7b2..7caa493c06f 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -597,8 +597,8 @@ subroutine start_back_writers(rc) integer, pointer :: g_1d(:), l_1d(:), g_2d(:,:), l_2d(:,:), g_3d(:,:,:), l_3d(:,:,:) integer, pointer :: g_4d(:,:,:,:), l_4d(:,:,:,:), g_5d(:,:,:,:,:), l_5d(:,:,:,:,:) - integer :: msize_word, d_rank, request_id - integer :: s0, e0, s1, e1, s2, e2, s3, e3, s4, e4, s5, e5 + integer :: d_rank, request_id + integer(kind=INT64) :: msize_word, s0, e0, s1, e1, s2, e2, s3, e3, s4, e4, s5, e5 type (StringAttributeMap) :: vars_map type (StringAttributeMapIterator) :: var_iter type (IntegerMessageMap) :: msg_map @@ -664,7 +664,7 @@ subroutine start_back_writers(rc) type is (CollectiveStageDataMessage) var_iter = vars_map%find(i_to_string(q%request_id)) if (var_iter == vars_map%end()) then - msize_word = word_size(q%type_kind)*product(q%global_count) + msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) allocate(buffer_v(msize_word), source = -1) call vars_map%insert(i_to_string(q%request_id), Attribute(buffer_v)) var_iter = vars_map%find(i_to_string(q%request_id)) diff --git a/pfio/ServerThread.F90 b/pfio/ServerThread.F90 index e09e8a94422..caa471eecf5 100644 --- a/pfio/ServerThread.F90 +++ b/pfio/ServerThread.F90 @@ -824,16 +824,16 @@ subroutine put_DataToFile(this, message, address, rc) case (1:) select case (message%type_kind) case (pFIO_INT32) - call c_f_pointer(address, values_int32_1d, [product(count)]) + call c_f_pointer(address, values_int32_1d, [product(int(count, INT64))]) call formatter%put_var(message%var_name, values_int32_1d, start=start, count=count, _RC) case (pFIO_INT64) - call c_f_pointer(address, values_int64_1d, [product(count)]) + call c_f_pointer(address, values_int64_1d, [product(int(count, INT64))]) call formatter%put_var(message%var_name, values_int64_1d, start=start, count=count, _RC) case (pFIO_REAL32) - call c_f_pointer(address, values_real32_1d, [product(count)]) + call c_f_pointer(address, values_real32_1d,[product(int(count, INT64))]) call formatter%put_var(message%var_name, values_real32_1d, start=start, count=count, _RC) case (pFIO_REAL64) - call c_f_pointer(address, values_real64_1d, [product(count)]) + call c_f_pointer(address, values_real64_1d,[product(int(count, INT64))]) call formatter%put_var(message%var_name, values_real64_1d, start=start, count=count, _RC) case default _FAIL( "not supported type") From 6bedbf87d7945bf6f90d9b870b757ea0afba2842 Mon Sep 17 00:00:00 2001 From: Darian Boggs <61847056+darianboggs@users.noreply.github.com> Date: Tue, 24 Jan 2023 10:38:26 -0500 Subject: [PATCH 32/83] Add _RETURN(_SUCCESS) to subroutine intrinsic_to_string Co-authored-by: Tom Clune --- base/MAPL_Resource.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 27864192732..e73a3d13bf3 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -405,7 +405,7 @@ function intrinsic_to_string(val, str_format, rc) result(formatted_str) class default _FAIL( "Unsupported type in intrinsic_to_string") end select - +_RETURN(_SUCCESS) end function intrinsic_to_string end module MAPL_ResourceMod From 3b49c856ecf9e9236a97b938f107c3787ec2068d Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Tue, 24 Jan 2023 21:43:52 -0500 Subject: [PATCH 33/83] Move component_name check; add _RETURN(_SUCCESS) --- base/MAPL_Resource.F90 | 112 ++++++++++++++++++++------------------- generic/MAPL_Generic.F90 | 4 +- 2 files changed, 60 insertions(+), 56 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index e73a3d13bf3..96b5032608f 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -20,6 +20,7 @@ module MAPL_ResourceMod use MAPL_CommsMod use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR use MAPL_ExceptionHandling + use MAPL_KeywordEnforcerMod use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, int32, int64 ! !PUBLIC MEMBER FUNCTIONS: @@ -33,28 +34,35 @@ module MAPL_ResourceMod contains ! MAPL searches for labels with certain prefixes as well as just the label itself - pure function get_labels_with_prefix(compname, label) result(labels_with_prefix) - character(len=*), intent(in) :: compname, label - character(len=ESMF_MAXSTR) :: labels_with_prefix(4), component_type - - component_type = compname(index(compname, ":") + 1:) - - ! The order to search for labels in resource files - labels_with_prefix(1) = trim(compname)//"_"//trim(label) - labels_with_prefix(2) = trim(component_type)//"_"//trim(label) - labels_with_prefix(3) = trim(label) - labels_with_prefix(4) = trim(compname)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) + pure function get_labels_with_prefix(label, component_name) result(labels_with_prefix) + character(len=*), intent(in) :: label + character(len=*), optional, intent(in) :: component_name + character(len=ESMF_MAXSTR) :: component_type + character(len=ESMF_MAXSTR) :: labels_with_prefix(4) + + if(present(commponent_name)) then + component_type = component_name(index(component_name, ":") + 1:) + + ! The order to search for labels in resource files + labels_with_prefix = [ trim(compname)//"_"//trim(label), & + trim(component_type)//"_"//trim(label), & + trim(label), & + trim(compname)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) ] + else + labels_with_prefix = '' + labels_with_prefix(1) = label + end if end function get_labels_with_prefix - ! If possible, find label or label with prefix. Out: logical to if label found, - ! version of label found, - subroutine get_label_to_use(config, label, compname, label_is_present, label_to_use, rc) + ! If possible, find label or label with prefix. Out: label found (logical) ! version of label found, + subroutine get_actual_label(config, label, label_is_present, actual_label, unusable, component_name, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: label - character(len=*), intent(in) :: compname logical, intent(out) :: label_is_present - character(len=:), allocatable, intent(out) :: label_to_use + character(len=:), allocatable, intent(out) :: actual_label + class(KeywordEnforcer), optional, intent(in) :: unusable + character(len=*), optional, intent(in) :: component_name integer, optional, intent(out) :: rc character(len=ESMF_MAXSTR), allocatable :: labels_to_try(:) @@ -62,34 +70,37 @@ subroutine get_label_to_use(config, label, compname, label_is_present, label_to_ integer :: status label_is_present = .false. - labels_to_try = get_labels_with_prefix(compname, label) - do i = 1, size(labels_to_try) - label_to_use = trim(labels_to_try(i)) - call ESMF_ConfigFindLabel(config, label = label_to_use, isPresent = label_is_present, _RC) + ! If component_name is present, find label in some form in config. Else search + ! for exact label - if (label_is_present) then - exit - end if + labels_to_try = get_labels_with_prefix(label, component_name) + + do i = 1, size(labels_to_try) + actual_label = trim(labels_to_try(i)) + if (len_trim(actual_label) == 0 ) cycle + call ESMF_ConfigFindLabel(config, label = actual_label, isPresent = label_is_present, _RC) + if (label_is_present) exit end do _RETURN(_SUCCESS) - end subroutine get_label_to_use + end subroutine get_actual_label ! Find value of scalar variable in config - subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, compname, rc) + subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, component_name, rc) type(ESMF_Config), intent(inout) :: config class(*), intent(inout) :: val - character(len=*), intent(in) :: label_to_find + character(len=*), intent(in) :: label + class(KeywordEnforcer), optional, intent(in) :: unusable class(*), optional, intent(in) :: default - character(len=*), optional, intent(in) :: compname + character(len=*), optional, intent(in) :: component_name integer, optional, intent(out) :: rc integer :: status, printrc logical :: default_is_present, label_is_present character(len=:), allocatable :: label_to_print - character(len=:), allocatable :: label + character(len=:), allocatable :: actual_label default_is_present = present(default) @@ -97,14 +108,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c _ASSERT(same_type_as(val, default), "Value and default must have same type") end if - ! If compname is present, find label in some form in config. Else search - ! for exact label - if (present(compname)) then - call get_label_to_use(config, label_to_find, compname, label_is_present, label, _RC) - else - label = label_to_find - call ESMF_ConfigFindLabel(config, label = label, isPresent = label_is_present, _RC) - end if + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) ! No default and not in config, error ! label or default must be present @@ -121,7 +125,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c val = default end select else - call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) end if type is(integer(int64)) if (default_is_present .and. .not. label_is_present) then @@ -130,7 +134,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c val = default end select else - call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) end if type is(real(real32)) if (default_is_present .and. .not. label_is_present) then @@ -139,7 +143,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c val = default end select else - call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) end if type is (real(real64)) if (default_is_present .and. .not. label_is_present) then @@ -148,7 +152,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c val = default end select else - call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) end if type is(character(len=*)) if (default_is_present .and. .not. label_is_present) then @@ -157,7 +161,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c val = trim(default) end select else - call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) end if type is(logical) if (default_is_present .and. .not. label_is_present) then @@ -166,7 +170,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c val = default end select else - call ESMF_ConfigGetAttribute(config, val, label = label, _RC) + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) end if class default _FAIL( "Unupported type") @@ -177,9 +181,9 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c ! Can set printrc to negative to not print at all if (MAPL_AM_I_Root() .and. printrc >= 0) then if (label_is_present) then - label_to_print = label + label_to_print = actual_label else - label_to_print = trim(label_to_find) + label_to_print = trim(label) end if call print_resource(printrc, label_to_print, val, default=default, _RC) end if @@ -189,15 +193,15 @@ subroutine MAPL_GetResource_config_scalar(config, val, label_to_find, default, c end subroutine MAPL_GetResource_config_scalar ! Find value of array variable in config - subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, default, rc) + subroutine MAPL_GetResource_config_array(config, compname, vals, label, default, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: compname - character(len=*), intent(in) :: label_to_find + character(len=*), intent(in) :: label class(*), intent(inout) :: vals(:) class(*), optional, intent(in) :: default(:) integer, optional, intent(out) :: rc - character(len=:), allocatable :: label_to_use + character(len=:), allocatable :: actual_label integer :: status, count logical :: label_is_present, default_is_present @@ -207,7 +211,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, _ASSERT(same_type_as(vals, default), "Value and default must have same type") end if - call get_label_to_use(config, label_to_find, compname, label_is_present, label_to_use, _RC) + call get_actual_label(config, label, compname, label_is_present, actual_label, _RC) ! No default and not in config, error ! label or default must be present @@ -226,7 +230,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, if (.not. label_is_present) vals = default end select else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) end if type is(integer(int64)) if (default_is_present .and. .not. label_is_present) then @@ -235,7 +239,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, vals = default end select else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) end if type is(real(real32)) if (default_is_present .and. .not. label_is_present) then @@ -244,7 +248,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, vals = default end select else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) end if type is (real(real64)) if (default_is_present .and. .not. label_is_present) then @@ -253,7 +257,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, vals = default end select else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) end if type is(character(len=*)) if (default_is_present .and. .not. label_is_present) then @@ -262,7 +266,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, vals = default end select else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) end if type is(logical) if (default_is_present .and. .not. label_is_present) then @@ -271,7 +275,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label_to_find, vals = default end select else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = label_to_use, _RC) + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) end if class default _FAIL( "Unsupported type") diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index e1285114557..2869d995584 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8294,7 +8294,7 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) integer :: status - call MAPL_GetResource_config_scalar(state%cf, val, label, default, state%compname, _RC) + call MAPL_GetResource_config_scalar(state%cf, val, label, default = default, component_name = state%compname, _RC) _RETURN(_SUCCESS) @@ -8311,7 +8311,7 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) integer :: status - call MAPL_GetResource_config_scalar(config, val, label, default, _RC) + call MAPL_GetResource_config_scalar(config, val, label, default = default, _RC) _RETURN(ESMF_SUCCESS) From 1597dfcc701f3fe054893b430c3af26ac490c8ae Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 25 Jan 2023 10:44:00 -0500 Subject: [PATCH 34/83] Fix unknown bug --- base/MAPL_Resource.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 96b5032608f..dad501d5644 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -227,7 +227,7 @@ subroutine MAPL_GetResource_config_array(config, compname, vals, label, default, if (default_is_present .and. .not. label_is_present) then select type(default) type is(integer(int32)) - if (.not. label_is_present) vals = default + vals = default end select else call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) From 9ebfe11f1e31f48fcba8895dd10bbb891d7c37bc Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 25 Jan 2023 11:11:24 -0500 Subject: [PATCH 35/83] Reorder arguments for MAPL_GetResource_config_array; add unusable --- base/MAPL_Resource.F90 | 5 +++-- generic/MAPL_Generic.F90 | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index dad501d5644..2beac95144b 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -193,12 +193,13 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, end subroutine MAPL_GetResource_config_scalar ! Find value of array variable in config - subroutine MAPL_GetResource_config_array(config, compname, vals, label, default, rc) + subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, compname, rc) type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: compname character(len=*), intent(in) :: label class(*), intent(inout) :: vals(:) + class(KeywordEnforcer), optional, intent(in) :: unusable class(*), optional, intent(in) :: default(:) + character(len=*), optional, intent(in) :: compname integer, optional, intent(out) :: rc character(len=:), allocatable :: actual_label diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 2869d995584..18671118883 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8326,7 +8326,7 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) integer :: status - call MAPL_GetResource_config_array(state%cf, state%compname, vals, label, default, _RC) + call MAPL_GetResource_config_array(state%cf, vals, label, default = default, component_name = state%compname, _RC) _RETURN(ESMF_SUCCESS) From 29de4b402ddbe8cda8fcc0c24a3468e568798f76 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 25 Jan 2023 11:15:40 -0500 Subject: [PATCH 36/83] Added check for compname --- base/MAPL_Resource.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 2beac95144b..1e0d3040bc4 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -212,6 +212,7 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, _ASSERT(same_type_as(vals, default), "Value and default must have same type") end if + _ASSERT(present(compname), "Component name is present but not present.") call get_actual_label(config, label, compname, label_is_present, actual_label, _RC) ! No default and not in config, error From 42eb05216e95e3452bfbce690bfe891a4f46e759 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 25 Jan 2023 11:51:30 -0500 Subject: [PATCH 37/83] Update StringVector version; eliminate unnecessary size check for StringVector --- base/MAPL_Resource.F90 | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 1e0d3040bc4..4890c9591e6 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -16,7 +16,7 @@ module MAPL_ResourceMod use ESMF use ESMFL_Mod - use gFTL_StringVector + use gFTL2_StringVector use MAPL_CommsMod use MAPL_Constants, only: MAPL_CF_COMPONENT_SEPARATOR use MAPL_ExceptionHandling @@ -377,15 +377,13 @@ logical function vector_contains_str(vector, string) vector_contains_str = .false. - if (vector%size() /= 0) then - do while (iter /= vector%end()) - if (trim(string) == iter%get()) then - vector_contains_str = .true. - return - end if - call iter%next() - end do - end if + do while (iter /= vector%end()) + if (trim(string) == iter%of()) then + vector_contains_str = .true. + return + end if + call iter%next() + end do end function vector_contains_str From 27177c6373ada27cc7d657a8c8dba4a65f6e2a81 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 25 Jan 2023 15:51:55 -0500 Subject: [PATCH 38/83] Correct incorrect component_name variables --- base/MAPL_Resource.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 4890c9591e6..7821c935363 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -40,14 +40,14 @@ pure function get_labels_with_prefix(label, component_name) result(labels_with_p character(len=ESMF_MAXSTR) :: component_type character(len=ESMF_MAXSTR) :: labels_with_prefix(4) - if(present(commponent_name)) then + if(present(component_name)) then component_type = component_name(index(component_name, ":") + 1:) ! The order to search for labels in resource files - labels_with_prefix = [ trim(compname)//"_"//trim(label), & + labels_with_prefix = [ trim(component_name)//"_"//trim(label), & trim(component_type)//"_"//trim(label), & trim(label), & - trim(compname)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) ] + trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) ] else labels_with_prefix = '' labels_with_prefix(1) = label @@ -193,13 +193,13 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, end subroutine MAPL_GetResource_config_scalar ! Find value of array variable in config - subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, compname, rc) + subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, component_name, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: label class(*), intent(inout) :: vals(:) class(KeywordEnforcer), optional, intent(in) :: unusable class(*), optional, intent(in) :: default(:) - character(len=*), optional, intent(in) :: compname + character(len=*), optional, intent(in) :: component_name integer, optional, intent(out) :: rc character(len=:), allocatable :: actual_label @@ -212,8 +212,8 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, _ASSERT(same_type_as(vals, default), "Value and default must have same type") end if - _ASSERT(present(compname), "Component name is present but not present.") - call get_actual_label(config, label, compname, label_is_present, actual_label, _RC) + _ASSERT(present(component_name), "Component name is present but not present.") + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) ! No default and not in config, error ! label or default must be present From 1e0cd8a7847c74c36b2832020162dbcea68a5197 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 25 Jan 2023 16:08:19 -0500 Subject: [PATCH 39/83] add more log info when data size is too big --- pfio/ForwardDataAndMessage.F90 | 4 +++- pfio/MessageVector.F90 | 9 ++++++++- pfio/MpiSocket.F90 | 5 ++++- 3 files changed, 15 insertions(+), 3 deletions(-) diff --git a/pfio/ForwardDataAndMessage.F90 b/pfio/ForwardDataAndMessage.F90 index 55819444dbf..f09cd3d67ec 100644 --- a/pfio/ForwardDataAndMessage.F90 +++ b/pfio/ForwardDataAndMessage.F90 @@ -56,7 +56,9 @@ subroutine serialize(this, buffer, rc) else buffer = buff_tmp endif - + if ( size(buffer, kind=8) > huge(0)) then + _ASSERT(.false., "need to increase oserver's number of front cores (nfront)") + endif _RETURN(_SUCCESS) end subroutine serialize diff --git a/pfio/MessageVector.F90 b/pfio/MessageVector.F90 index 4777b8eeacb..8ac8f8d1972 100644 --- a/pfio/MessageVector.F90 +++ b/pfio/MessageVector.F90 @@ -27,9 +27,10 @@ module pFIO_MessageVectorUtilMod contains - subroutine serialize_message_vector(msgVec,buffer) + subroutine serialize_message_vector(msgVec,buffer, rc) type (MessageVector),intent(in) :: msgVec integer, allocatable,intent(inout) :: buffer(:) + integer, optional, intent(out) :: rc integer, allocatable :: tmp(:) class (AbstractMessage),pointer :: msg integer :: n, i @@ -42,7 +43,13 @@ subroutine serialize_message_vector(msgVec,buffer) msg=>msgVec%at(i) tmp =[tmp, parser%encode(msg)] enddo + + if(size(tmp, kind=8) > huge(0)) then + _ASSERT( .false., " need to increase oserver's nfront") + endif + i = size(tmp)+1 + if (allocated(buffer)) deallocate(buffer) buffer =[i,tmp] diff --git a/pfio/MpiSocket.F90 b/pfio/MpiSocket.F90 index 3f1aeaa8918..6f29569021c 100644 --- a/pfio/MpiSocket.F90 +++ b/pfio/MpiSocket.F90 @@ -156,10 +156,13 @@ function put(this, request_id, local_reference, rc) result(handle) integer, pointer :: data(:) integer :: n_words + integer(kind=INT64) :: big_n tag = make_tag(request_id) - n_words = product(local_reference%shape) * word_size(local_reference%type_kind) + big_n = product(int(local_reference%shape, INT64)) * word_size(local_reference%type_kind) + _ASSERT( big_n < huge(0), "Increase the number of processors to decrease the local size of data to be sent") + n_words = big_n call c_f_pointer(local_reference%base_address, data, shape=[n_words]) if (n_words ==0) allocate(data(1)) call MPI_Isend(data, n_words, MPI_INTEGER, this%pair_remote_rank, tag, this%pair_comm, request, ierror) From d94e8c018984477f3c634086ab6933a2b6e4b47f Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 25 Jan 2023 17:06:52 -0500 Subject: [PATCH 40/83] Add _UNUSED_DUMMY to procedures; add missing _RETURN(_SUCCESS) statements --- base/MAPL_Resource.F90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 7821c935363..aaa251d0b68 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -69,6 +69,8 @@ subroutine get_actual_label(config, label, label_is_present, actual_label, unusa integer :: i integer :: status + _UNUSED_DUMMY(unusable) + label_is_present = .false. ! If component_name is present, find label in some form in config. Else search @@ -102,6 +104,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, character(len=:), allocatable :: label_to_print character(len=:), allocatable :: actual_label + _UNUSED_DUMMY(unusable) + default_is_present = present(default) if (default_is_present) then @@ -206,6 +210,8 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, integer :: status, count logical :: label_is_present, default_is_present + _UNUSED_DUMMY(unusable) + default_is_present = present(default) if (default_is_present) then @@ -366,6 +372,8 @@ subroutine print_resource(printrc, label, val, default, rc) print output_format, trim(label), trim(val_str) end if + _RETURN(_SUCCESS) + end subroutine print_resource logical function vector_contains_str(vector, string) @@ -409,7 +417,9 @@ function intrinsic_to_string(val, str_format, rc) result(formatted_str) class default _FAIL( "Unsupported type in intrinsic_to_string") end select -_RETURN(_SUCCESS) + + _RETURN(_SUCCESS) + end function intrinsic_to_string end module MAPL_ResourceMod From 10a0699b0a0fb8eaea10f0b32fb8cd9cbedcd1fd Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Thu, 26 Jan 2023 09:17:14 -0500 Subject: [PATCH 41/83] Update pfio/MessageVector.F90 Co-authored-by: Matthew Thompson --- pfio/MessageVector.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pfio/MessageVector.F90 b/pfio/MessageVector.F90 index 8ac8f8d1972..3935eaffe53 100644 --- a/pfio/MessageVector.F90 +++ b/pfio/MessageVector.F90 @@ -45,7 +45,7 @@ subroutine serialize_message_vector(msgVec,buffer, rc) enddo if(size(tmp, kind=8) > huge(0)) then - _ASSERT( .false., " need to increase oserver's nfront") + _FAIL("need to increase oserver's nfront") endif i = size(tmp)+1 From 0cb8ebaf42d0ac7d55791078f9898b197ea13330 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Thu, 26 Jan 2023 09:17:23 -0500 Subject: [PATCH 42/83] Update pfio/ForwardDataAndMessage.F90 Co-authored-by: Matthew Thompson --- pfio/ForwardDataAndMessage.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pfio/ForwardDataAndMessage.F90 b/pfio/ForwardDataAndMessage.F90 index f09cd3d67ec..a6a94a4dbcf 100644 --- a/pfio/ForwardDataAndMessage.F90 +++ b/pfio/ForwardDataAndMessage.F90 @@ -57,7 +57,7 @@ subroutine serialize(this, buffer, rc) buffer = buff_tmp endif if ( size(buffer, kind=8) > huge(0)) then - _ASSERT(.false., "need to increase oserver's number of front cores (nfront)") + _FAIL("need to increase oserver's number of front cores (nfront)") endif _RETURN(_SUCCESS) From 011083a0dab10cff4ab03eb83bf8477db933d00d Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 27 Jan 2023 15:42:27 -0500 Subject: [PATCH 43/83] Update select type blocks to use macros to reduce boilerplate code --- base/MAPL_Resource.F90 | 224 +++++++++++++---------------------------- 1 file changed, 71 insertions(+), 153 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index aaa251d0b68..fd595de4058 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -3,6 +3,55 @@ #include "unused_dummy.H" !============================================================================= +!FPP macros for repeated (type-dependent) code + +#ifdef SET_VAL +# undef SET_VAL +#endif + +#define SET_VAL(T) \ +type is (T) \ + if (default_is_present .and. .not. label_is_present) then \ + select type(default) \ + type is(T) \ + val = default \ + class default + _FAIL("Type of 'default' does not match type of 'val'.") + end select \ + else \ + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) \ + end if + +#ifdef SET_VALS +# undef SET_VALS +#endif + +#define SET_VALS(T) \ +type is (T) \ + if (default_is_present .and. .not. label_is_present) then \ + select type(default) \ + type is(T) \ + vals = default \ + class default + _FAIL("Type of 'default' does not match type of 'vals'.") + end select \ + else \ + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) \ + end if + +#ifdef SET_STRINGS +# undef SET_STRINGS +#endif + +#define SET_STRINGS(T, TS, TF) \ +type is (T) \ + type_str = TS \ + val_str = intrinsic_to_string(val, TF) \ + if (present(default)) then \ + default_str = intrinsic_to_string(default, TF) \ + end if + +!============================================================================= module MAPL_ResourceMod @@ -122,61 +171,13 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, end if select type(val) - type is(integer(int32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int32)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) - end if - type is(integer(int64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int64)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) - end if - type is(real(real32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(real(real32)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) - end if - type is (real(real64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(real(real64)) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) - end if - type is(character(len=*)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(character(len=*)) - val = trim(default) - end select - else - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) - end if - type is(logical) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(logical) - val = default - end select - else - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) - end if - class default + SET_VAL(integer(int32)) + SET_VAL(integer(int64)) + SET_VAL(real(real32)) + SET_VAL(real(real64)) + SET_VAL(character(len=*)) + SET_VAL(logical) + class default _FAIL( "Unupported type") end select @@ -231,61 +232,13 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, count = size(vals) select type(vals) - type is(integer(int32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int32)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) - end if - type is(integer(int64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(int64)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) - end if - type is(real(real32)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(real32)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) - end if - type is (real(real64)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(integer(real64)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) - end if - type is(character(len=*)) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(character(*)) - vals = default - end select - else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) - end if - type is(logical) - if (default_is_present .and. .not. label_is_present) then - select type(default) - type is(logical) - vals = default - end select - else - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) - end if - class default + SET_VALS(integer(int32)) + SET_VALS(integer(int64)) + SET_VALS(real(real32)) + SET_VALS(real(real64)) + SET_VALS(character(len=*)) + SET_VALS(logical) + class default _FAIL( "Unsupported type") end select @@ -315,52 +268,17 @@ subroutine print_resource(printrc, label, val, default, rc) end if select type(val) - type is(integer(int32)) - type_str = "'Integer*4 '" - type_format = '(i0.1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(integer(int64)) - type_str = "'Integer*8 '" - type_format = '(i0.1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(real(real32)) - type_str = "'Real*4 '" - type_format = '(f0.6)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(real(real64)) - type_str = "'Real*8 '" - type_format = '(f0.6)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(logical) - type_str = "'Logical '" - type_format = '(l1)' - val_str = intrinsic_to_string(val, type_format) - if (present(default)) then - default_str = intrinsic_to_string(default, type_format) - end if - type is(character(len=*)) - type_str = "'Character '" - val_str = trim(val) - if (present(default)) then - default_str = intrinsic_to_string(default, 'a') - end if - class default + SET_STRINGS(integer(int32), "'Integer*4 '", '(i0.1)') + SET_STRINGS(integer(int64), "'Integer*8 '", '(i0.1)') + SET_STRINGS(real(real32), "'Real*4 '" , '(f0.6)') + SET_STRINGS(real(real64), "'Real*8 '" , '(f0.6)') + SET_STRINGS(logical, "'Logical '" , '(l1)' ) + SET_STRINGS(character(len=*),"'Character '", '(a)') + class default _FAIL("Unsupported type") end select - output_format = "(1x, " // type_str // ", 'Resource Parameter: '" // ", a"// ", a)" + output_format = "(1x, " // type_str // ", 'Resource Parameter: '" // ", a"// ", a)a" ! printrc = 0 - Only print non-default values ! printrc = 1 - Print all values From d37a39ff78ed2561247dff52d9c950fb7f1bd681 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 30 Jan 2023 12:19:51 -0500 Subject: [PATCH 44/83] Modify macro line terminators --- base/MAPL_Resource.F90 | 50 +++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index fd595de4058..90f433ddfd8 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -10,16 +10,16 @@ #endif #define SET_VAL(T) \ -type is (T) \ - if (default_is_present .and. .not. label_is_present) then \ - select type(default) \ - type is(T) \ - val = default \ - class default - _FAIL("Type of 'default' does not match type of 'val'.") - end select \ - else \ - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) \ +type is (T) ;\ + if (default_is_present .and. .not. label_is_present) then ;\ + select type(default) ;\ + type is(T) ;\ + val = default ;\ + class default ;\ + _FAIL("Type of 'default' does not match type of 'val'.") ;\ + end select ;\ + else ;\ + call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) ;\ end if #ifdef SET_VALS @@ -27,16 +27,16 @@ #endif #define SET_VALS(T) \ -type is (T) \ - if (default_is_present .and. .not. label_is_present) then \ - select type(default) \ - type is(T) \ - vals = default \ - class default - _FAIL("Type of 'default' does not match type of 'vals'.") - end select \ - else \ - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) \ +type is (T) ;\ + if (default_is_present .and. .not. label_is_present) then ;\ + select type(default) ;\ + type is(T) ;\ + vals = default ;\ + class default ;\ + _FAIL("Type of 'default' does not match type of 'vals'.") ;\ + end select ;\ + else ;\ + call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) ;\ end if #ifdef SET_STRINGS @@ -44,11 +44,11 @@ #endif #define SET_STRINGS(T, TS, TF) \ -type is (T) \ - type_str = TS \ - val_str = intrinsic_to_string(val, TF) \ - if (present(default)) then \ - default_str = intrinsic_to_string(default, TF) \ +type is (T) ;\ + type_str = TS ;\ + val_str = intrinsic_to_string(val, TF) ;\ + if (present(default)) then ;\ + default_str = intrinsic_to_string(default, TF) ;\ end if !============================================================================= From 2ef87d32bd4aabd8dc5af010ec3402aa45133163 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 30 Jan 2023 14:26:42 -0500 Subject: [PATCH 45/83] reduce a copy of large attribute --- pfio/MultiGroupServer.F90 | 7 +++++-- pfio/UnlimitedEntity.F90 | 11 +++++++++++ 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index 7caa493c06f..9d286513337 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -607,6 +607,7 @@ subroutine start_back_writers(rc) class (*), pointer :: x_ptr(:) integer , allocatable :: buffer_v(:) type (Attribute), pointer :: attr_ptr + type (Attribute) :: attr_tmp type (c_ptr) :: address type (ForwardDataAndMessage), target :: f_d_m type (FileMetaData) :: fmd @@ -666,9 +667,11 @@ subroutine start_back_writers(rc) if (var_iter == vars_map%end()) then msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) allocate(buffer_v(msize_word), source = -1) - call vars_map%insert(i_to_string(q%request_id), Attribute(buffer_v)) - var_iter = vars_map%find(i_to_string(q%request_id)) + attr_tmp = Attribute(buffer_v) deallocate(buffer_v) + call vars_map%insert(i_to_string(q%request_id),attr_tmp) + call attr_tmp%destroy() + var_iter = vars_map%find(i_to_string(q%request_id)) call msg_map%insert(q%request_id, q) endif attr_ptr => var_iter%value() diff --git a/pfio/UnlimitedEntity.F90 b/pfio/UnlimitedEntity.F90 index a8f3c706c27..a5ebc58327f 100644 --- a/pfio/UnlimitedEntity.F90 +++ b/pfio/UnlimitedEntity.F90 @@ -55,6 +55,7 @@ module pFIO_UnlimitedEntityMod procedure :: serialize procedure :: get_string procedure :: is_empty + procedure :: destroy end type UnlimitedEntity ! This derived type is a workaround for sporadic Intel Fortran @@ -253,6 +254,16 @@ subroutine set(this, value, rc) _RETURN(_SUCCESS) end subroutine set + subroutine destroy(this, rc) + class (UnlimitedEntity), intent(inout) :: this + integer, optional, intent(out) :: rc + if(allocated(this%value)) deallocate(this%value) + if(allocated(this%values)) deallocate(this%values) + if(allocated(this%shape)) deallocate(this%shape) + _RETURN(_SUCCESS) + end subroutine destroy + + ! get string or scalar ! get string or scalar function get_value(this, rc) result(value) class (UnlimitedEntity), target, intent(in) :: this From 883a98ed8e98bdd9ac34ce945d8ab04304724bcb Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 30 Jan 2023 20:59:43 -0500 Subject: [PATCH 46/83] Update CMakeLists.txt to use gFTLv2; updated macros --- base/CMakeLists.txt | 3 ++- base/MAPL_Resource.F90 | 48 +++++++++++++++++++++--------------------- 2 files changed, 26 insertions(+), 25 deletions(-) diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index c885f862d59..4f281e674fa 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -61,7 +61,8 @@ set (srcs esma_add_library( ${this} SRCS ${srcs} - DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 PFLOGGER::pflogger GFTL_SHARED::gftl-shared + DEPENDENCIES MAPL.shared MAPL.constants MAPL.profiler MAPL.pfio MAPL_cfio_r4 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 TYPE ${MAPL_LIBRARY_TYPE}) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 90f433ddfd8..61be45cec14 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -9,46 +9,46 @@ # undef SET_VAL #endif -#define SET_VAL(T) \ +#define SET_VAL(T, VAL) \ type is (T) ;\ if (default_is_present .and. .not. label_is_present) then ;\ select type(default) ;\ type is(T) ;\ - val = default ;\ + VAL = default ;\ class default ;\ - _FAIL("Type of 'default' does not match type of 'val'.") ;\ + _FAIL("Type of 'default' does not match type of 'VAL'.") ;\ end select ;\ else ;\ - call ESMF_ConfigGetAttribute(config, val, label = actual_label, _RC) ;\ + call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, _RC) ;\ end if #ifdef SET_VALS # undef SET_VALS #endif -#define SET_VALS(T) \ +#define SET_VALS(T, VALS) \ type is (T) ;\ if (default_is_present .and. .not. label_is_present) then ;\ select type(default) ;\ type is(T) ;\ - vals = default ;\ + VALS = default ;\ class default ;\ - _FAIL("Type of 'default' does not match type of 'vals'.") ;\ + _FAIL("Type of 'default' does not match type of 'VALS'.") ;\ end select ;\ else ;\ - call ESMF_ConfigGetAttribute(config, valuelist = vals, count = count, label = actual_label, _RC) ;\ + call ESMF_ConfigGetAttribute(config, valuelist = VALS, count = count, label = actual_label, _RC) ;\ end if #ifdef SET_STRINGS # undef SET_STRINGS #endif -#define SET_STRINGS(T, TS, TF) \ +#define SET_STRINGS(T, TSTR, TFMT) \ type is (T) ;\ - type_str = TS ;\ - val_str = intrinsic_to_string(val, TF) ;\ + type_str = TSTR ;\ + val_str = intrinsic_to_string(val, TFMT) ;\ if (present(default)) then ;\ - default_str = intrinsic_to_string(default, TF) ;\ + default_str = intrinsic_to_string(default, TFMT) ;\ end if !============================================================================= @@ -171,12 +171,12 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, end if select type(val) - SET_VAL(integer(int32)) - SET_VAL(integer(int64)) - SET_VAL(real(real32)) - SET_VAL(real(real64)) - SET_VAL(character(len=*)) - SET_VAL(logical) + SET_VAL(integer(int32), val) + SET_VAL(integer(int64), val) + SET_VAL(real(real32), val) + SET_VAL(real(real64), val) + SET_VAL(character(len=*), val) + SET_VAL(logical, val) class default _FAIL( "Unupported type") end select @@ -232,12 +232,12 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, count = size(vals) select type(vals) - SET_VALS(integer(int32)) - SET_VALS(integer(int64)) - SET_VALS(real(real32)) - SET_VALS(real(real64)) - SET_VALS(character(len=*)) - SET_VALS(logical) + SET_VALS(integer(int32), vals) + SET_VALS(integer(int64), vals) + SET_VALS(real(real32), vals) + SET_VALS(real(real64), vals) + SET_VALS(character(len=*), vals) + SET_VALS(logical, vals) class default _FAIL( "Unsupported type") end select From 61c1b9d78c00d6a9e78266db55e5e29d5a013605 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 30 Jan 2023 21:56:27 -0500 Subject: [PATCH 47/83] Fix character string array initialization --- base/MAPL_Resource.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 61be45cec14..ea132f8bf85 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -93,10 +93,10 @@ pure function get_labels_with_prefix(label, component_name) result(labels_with_p component_type = component_name(index(component_name, ":") + 1:) ! The order to search for labels in resource files - labels_with_prefix = [ trim(component_name)//"_"//trim(label), & - trim(component_type)//"_"//trim(label), & - trim(label), & - trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) ] + labels_with_prefix(1) = trim(component_name)//"_"//trim(label) + labels_with_prefix(2) = trim(component_type)//"_"//trim(label) + labels_with_prefix(3) = trim(label) + labels_with_prefix(4) = trim(component_name)//MAPL_CF_COMPONENT_SEPARATOR//trim(label) else labels_with_prefix = '' labels_with_prefix(1) = label From 42a9fe6347e6fbe348aeba53a6bb57b9ee885955 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 31 Jan 2023 13:01:26 -0500 Subject: [PATCH 48/83] Add shavemantissa f2py code --- CHANGELOG.md | 1 + MAPL_cfio/CMakeLists.txt | 20 +++++++++++++++++++ MAPL_cfio/ShaveMantissa_py.F90 | 25 +++++++++++++++++++++++ MAPL_cfio/shavemantissa.py | 36 ++++++++++++++++++++++++++++++++++ 4 files changed, 82 insertions(+) create mode 100644 MAPL_cfio/ShaveMantissa_py.F90 create mode 100644 MAPL_cfio/shavemantissa.py diff --git a/CHANGELOG.md b/CHANGELOG.md index 28a8c6f7ff7..10f7eea7939 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 for more details. Provides the TRUE local solar hour angle (i.e., with equation of time included), but can also provide the MEAN value (without EOT) via `FORCE_MLSHA=.TRUE.` optional argument. +- Add `shavemantissa` f2py code. This is used by AeroApps. ### Changed diff --git a/MAPL_cfio/CMakeLists.txt b/MAPL_cfio/CMakeLists.txt index e6cfd498a7f..ac0ed525738 100644 --- a/MAPL_cfio/CMakeLists.txt +++ b/MAPL_cfio/CMakeLists.txt @@ -54,3 +54,23 @@ if (precision MATCHES "r8") target_compile_options (${lib} PRIVATE $<$:${flag}>) endforeach () endif () + +if (USE_F2PY) + if (precision STREQUAL "r4") + find_package(F2PY2) + if (F2PY2_FOUND) + esma_add_f2py2_module(ShaveMantissa_ + SOURCES ShaveMantissa_py.F90 ShaveMantissa.c + DESTINATION lib/Python/${this} + INCLUDEDIRS ${CMAKE_CURRENT_BINARY_DIR} ${CMAKE_BINARY_DIR}/lib ${include_${this}} + ) + add_dependencies(ShaveMantissa_ ${this}) + + # Install the Python files + install ( + FILES shavemantissa.py + DESTINATION lib/Python/${this} + ) + endif () + endif () +endif () diff --git a/MAPL_cfio/ShaveMantissa_py.F90 b/MAPL_cfio/ShaveMantissa_py.F90 new file mode 100644 index 00000000000..023e0dddc5b --- /dev/null +++ b/MAPL_cfio/ShaveMantissa_py.F90 @@ -0,0 +1,25 @@ +subroutine Shave32 ( a_shaved, a, n, xbits, has_undef, undef, chunksize, rc ) + +! +! Simple cover for f2py. +! + implicit NONE + integer, intent(in) :: n ! array size + real(kind=4), intent(in) :: a(n) ! array to be shaved, usually 2D + integer, intent(in) :: xbits ! number of mantissa bits to zero (out of 24) + integer, intent(in) :: has_undef ! set to 1 if undef is present, 0 otherwise + real(kind=4), intent(in) :: undef ! undef value + integer, intent(in) :: chunksize ! find mid-range over chunksizes + + real(kind=4), intent(out) :: a_shaved(n) ! shaved array + integer, intent(out) :: rc ! error code + +! --- + + integer, external :: ShaveMantissa32 + + rc = ShaveMantissa32(a_shaved,a,n,xbits,has_undef,undef,chunksize) + +end subroutine Shave32 + + diff --git a/MAPL_cfio/shavemantissa.py b/MAPL_cfio/shavemantissa.py new file mode 100644 index 00000000000..318d363c13b --- /dev/null +++ b/MAPL_cfio/shavemantissa.py @@ -0,0 +1,36 @@ +""" + SImple python interface to the ShaveMantissa function +""" + +MISSING = 1.0E15 + +from ShaveMantissa_ import shave32 + +def shave(a,xbits=12,has_undef=0,undef=MISSING,chunksize=-1): + """ + Shaves bits from mantissa of float point array for better netCDF4 compression + using gzip. + + a_shaved = shave(a,...) + + xbits --- number of bits to shave + has_undef --- set to 1 if undefs are present + undef --- undef value + chunksize --- for scaling of array to be shaved: find mid-range value + over chunksizes. If negative, set to len(a) + + Typically this function is used for a single vertical slice at time. + + + """ + + n = len(a) + if chunksize<0: chunksize = n + + a_shaved, rc = shave32(a,xbits,has_undef,undef,chunksize) + + if rc: + raise ValueError, 'shave: error on return from ShaveMantissa_.shave32: %d'%rc + + return a_shaved + From 525fdc75f52213450e42bf9da85cd68277699fdb Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 1 Feb 2023 10:28:56 -0500 Subject: [PATCH 49/83] Remove comment --- gridcomps/Cap/MAPL_Cap.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/gridcomps/Cap/MAPL_Cap.F90 b/gridcomps/Cap/MAPL_Cap.F90 index 31da5adba1f..438107c6a54 100644 --- a/gridcomps/Cap/MAPL_Cap.F90 +++ b/gridcomps/Cap/MAPL_Cap.F90 @@ -306,7 +306,6 @@ subroutine run_model(this, comm, unusable, rc) _VERIFY(status) call stop_timer() - ! W.J note : below reporting will be remove soon call report_throughput() _RETURN(_SUCCESS) From 36af93e95d1212fbfd5b6ffabe43a3bf5c9e8bff Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 1 Feb 2023 15:27:06 -0500 Subject: [PATCH 50/83] fixes #1941 --- CHANGELOG.md | 1 + gridcomps/History/MAPL_HistoryGridComp.F90 | 13 ++- griddedio/GriddedIO.F90 | 13 ++- pfio/CMakeLists.txt | 5 +- pfio/pFIO.F90 | 1 - shared/CMakeLists.txt | 4 + {pfio => shared}/DownBit.F90 | 89 ++++++++++++++----- shared/MaplShared.F90 | 1 + .../ShaveMantissa.c | 43 ++++----- .../ShaveMantissa.h | 4 +- 10 files changed, 120 insertions(+), 54 deletions(-) rename {pfio => shared}/DownBit.F90 (69%) rename pfio/pFIO_ShaveMantissa.c => shared/ShaveMantissa.c (79%) rename pfio/pFIO_ShaveMantissa.h => shared/ShaveMantissa.h (73%) diff --git a/CHANGELOG.md b/CHANGELOG.md index 28a8c6f7ff7..6cee76a40c9 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 +- Created layout independent version of the "DownBit"/"pFIO_ShaveMantissa" routines when running in MPI codes - Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This provides a convenient local solar hour angle diagnostic which will be used to detect local solar noon via the `EXAMPLE OF USE` in the subroutine header. See `DESCRIPTION` in code diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index b5a5e179ba4..522ec9a1473 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -39,7 +39,7 @@ module MAPL_HistoryGridCompMod use MAPL_GriddedIOitemVectorMod use MAPL_GriddedIOitemMod use pFIO_ClientManagerMod, only: o_Clients - use pFIO_DownbitMod, only: pFIO_DownBit + use MAPL_DownbitMod use pFIO_ConstantsMod use HistoryTrajectoryMod use MAPL_StringTemplate @@ -5444,11 +5444,16 @@ subroutine shavebits( state, list, rc) integer :: m, fieldRank, status type(ESMF_Field) :: field real, pointer :: ptr1d(:), ptr2d(:,:), ptr3d(:,:,:) + type(ESMF_VM) :: vm + integer :: mpi_comm if (list%nbits_to_keep >=MAPL_NBITS_UPPER_LIMIT) then _RETURN(ESMF_SUCCESS) endif + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) + do m=1,list%field_set%nfields call ESMF_StateGet(state, trim(list%field_set%fields(3,m)),field,rc=status ) _VERIFY(STATUS) @@ -5456,17 +5461,17 @@ subroutine shavebits( state, list, rc) if (fieldRank ==1) then call ESMF_FieldGet(field, farrayptr=ptr1d, rc=status) _VERIFY(STATUS) - call pFIO_DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,rc=status) + call DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(STATUS) elseif (fieldRank ==2) then call ESMF_FieldGet(field, farrayptr=ptr2d, rc=status) _VERIFY(STATUS) - call pFIO_DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,rc=status) + call DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(STATUS) elseif (fieldRank ==3) then call ESMF_FieldGet(field, farrayptr=ptr3d, rc=status) _VERIFY(STATUS) - call pFIO_DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,rc=status) + call DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(STATUS) else _FAIL('The field rank is not implmented') diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index a875388e015..cea3383893f 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -22,6 +22,7 @@ module MAPL_GriddedIOMod use gFTL_StringVector use gFTL_StringStringMap use MAPL_FileMetadataUtilsMod + use MAPL_DownbitMod use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL64 use ieee_arithmetic, only: isnan => ieee_is_nan @@ -872,6 +873,12 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) integer, allocatable :: localStart(:),globalStart(:),globalCount(:) integer, allocatable :: gridLocalStart(:),gridGlobalStart(:),gridGlobalCount(:) class (AbstractGridFactory), pointer :: factory + real, allocatable :: temp_2d(:,:), temp_3d(:,:,:) + type(ESMF_VM) :: vm + integer :: mpi_comm + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) factory => get_factory(this%output_grid,rc=status) _VERIFY(status) @@ -888,7 +895,8 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) call ESMF_FieldGet(Field,farrayPtr=ptr2d,rc=status) _VERIFY(status) if (this%nbits_to_keep < MAPL_NBITS_UPPER_LIMIT) then - call pFIO_DownBit(ptr2d,ptr2d,this%nbits_to_keep,undef=MAPL_undef,rc=status) + allocate(temp_2d,source=ptr2d) + call DownBit(temp_2d,ptr2d,this%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(status) end if else @@ -903,7 +911,8 @@ subroutine stageData(this, field, fileName, tIndex, oClients, rc) call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) _VERIFY(status) if (this%nbits_to_keep < MAPL_NBITS_UPPER_LIMIT) then - call pFIO_DownBit(ptr3d,ptr3d,this%nbits_to_keep,undef=MAPL_undef,rc=status) + allocate(temp_3d,source=ptr3d) + call DownBit(temp_3d,ptr3d,this%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) _VERIFY(status) end if else diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 1557e979e0b..840662c1252 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -10,8 +10,6 @@ endif() set (srcs # pFIO Files - pFIO_ShaveMantissa.c - DownBit.F90 pFIO_Constants.F90 UnlimitedEntity.F90 Attribute.F90 @@ -132,7 +130,8 @@ endforeach() ecbuild_add_executable ( TARGET pfio_open_close.x SOURCES pfio_open_close.F90 - LIBS ${this} ) + LIBS ${this}) + set_target_properties (pfio_open_close.x PROPERTIES Fortran_MODULE_DIRECTORY ${include_${this}}) ecbuild_add_executable ( diff --git a/pfio/pFIO.F90 b/pfio/pFIO.F90 index 9f3c96d15b2..395a60a339b 100644 --- a/pfio/pFIO.F90 +++ b/pfio/pFIO.F90 @@ -28,7 +28,6 @@ module pFIO use pFIO_ArrayReferenceMod use pFIO_StringAttributeMapMod use pFIO_StringVariableMapMod - use pFIO_DownBitMod use pFIO_LocalMemReferenceMod use pFIO_FormatterPtrVectorMod use pFIO_StringVectorUtilMod diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index dfb33d1d6eb..e61ae7a52b3 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -25,6 +25,8 @@ set (srcs FileSystemUtilities.F90 DSO_Utilities.F90 MAPL_ISO8601_DateTime.F90 + DownBit.F90 + ShaveMantissa.c # Fortran submodules Interp/Interp.F90 Interp/Interp_implementation.F90 Shmem/Shmem.F90 Shmem/Shmem_implementation.F90 @@ -39,6 +41,8 @@ endif () 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}") if (PFUNIT_FOUND) diff --git a/pfio/DownBit.F90 b/shared/DownBit.F90 similarity index 69% rename from pfio/DownBit.F90 rename to shared/DownBit.F90 index 96760f9a852..579e62d7c9e 100644 --- a/pfio/DownBit.F90 +++ b/shared/DownBit.F90 @@ -1,20 +1,23 @@ -module pFIO_DownbitMod +#include "MAPL_Generic.h" +module MAPL_DownbitMod use, intrinsic :: iso_c_binding, only: c_f_pointer, c_loc, c_ptr + use mpi + use MAPL_ExceptionHandling implicit none private - public :: pFIO_DownBit + public :: DownBit - interface pFIO_DownBit - module procedure pFIO_DownBit1D - module procedure pFIO_DownBit2D - module procedure pFIO_DownBit3D - end interface pFIO_DownBit + interface DownBit + module procedure DownBit1D + module procedure DownBit2D + module procedure DownBit3D + end interface DownBit contains - subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit3D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE @@ -27,6 +30,7 @@ subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -55,13 +59,13 @@ subroutine pFIO_DownBit3D ( x, xr, nbits_to_keep, undef, flops, rc ) integer :: k do k = lbound(x,3), ubound(x,3) - call pFIO_DownBit2D ( x(:,:,k), xr(:,:,k), nbits_to_keep, & - undef=undef, flops=flops, rc=rc ) + call DownBit2D ( x(:,:,k), xr(:,:,k), nbits_to_keep, & + undef=undef, flops=flops, mpi_comm=mpi_comm, rc=rc ) end do - end subroutine pFIO_DownBit3D + end subroutine DownBit3D - subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit2D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE @@ -73,6 +77,7 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -114,13 +119,20 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) ! !EOP !------------------------------------------------------------------------------ - integer :: E, xbits, has_undef + integer :: E, xbits, has_undef, passed_minmax real :: scale, xmin, xmax, tol, undef_ logical :: shave_mantissa - integer, external :: pFIO_ShaveMantissa32 + integer, external :: MAPL_ShaveMantissa32 + real :: min_value, max_value + integer :: useable_mpi_comm,status rc = 0 + if (present(mpi_comm)) then + useable_mpi_comm = mpi_comm + else + useable_mpi_comm = MPI_COMM_NULL + end if ! Defaults for optinal arguments ! ------------------------------ if ( present(undef) ) then @@ -143,7 +155,9 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) xr = x ! compiled r8 this will convert to r4. xbits = 24 - nbits_to_keep - rc = pFIO_ShaveMantissa32 ( xr, xr, size(x), xbits, has_undef, undef_, size(x) ) + call compute_min_max(xr,min_value,max_value,undef_,useable_mpi_comm,_RC) + if (useable_mpi_comm/=MPI_COMM_NULL) passed_minmax = 1 + rc = MAPL_ShaveMantissa32 ( xr, xr, size(x), xbits, has_undef, undef_, size(x), passed_minmax, min_value, max_value ) return ! Slow, flops in FORTRAN (GRIB inspired) @@ -180,9 +194,9 @@ subroutine pFIO_DownBit2D ( x, xr, nbits_to_keep, undef, flops, rc ) end if - end subroutine pFIO_DownBit2D + end subroutine DownBit2D - subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) + subroutine DownBit1D ( x, xr, nbits_to_keep, undef, flops, mpi_comm, rc ) implicit NONE ! ! !INPUT PARAMETERS: @@ -192,6 +206,7 @@ subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) real, OPTIONAL, intent(in) :: undef ! missing value logical, OPTIONAL, intent(in) :: flops ! if true, uses slower float point ! based algorithm + integer, optional, intent(in) :: mpi_comm ! ! !OUTPUT PARAMETERS: ! @@ -208,8 +223,38 @@ subroutine pFIO_DownBit1D ( x, xr, nbits_to_keep, undef, flops, rc ) xr_ptr = c_loc(xr(1)) call c_f_pointer(xr_ptr, xr_tmp,[size(x),1]) - call pFIO_Downbit2d(x_tmp(:,:), xr_tmp(:,:), nbits_to_keep, undef=undef, flops=flops, rc=rc) - - end subroutine pFIO_Downbit1D - -end module pFIO_DownbitMod + call Downbit2d(x_tmp(:,:), xr_tmp(:,:), nbits_to_keep, undef=undef, flops=flops, mpi_comm=mpi_comm, rc=rc) + + end subroutine Downbit1D + + subroutine compute_min_max(array,min_value,max_value,undef_value,mpi_comm,rc) + real, intent(in) :: array(:,:) + real, intent(out) :: min_value + real, intent(out) :: max_value + real, intent(in ) :: undef_value + integer, intent(in ) :: mpi_comm + integer, optional, intent(out) :: rc + + real :: local_min_value, local_max_value + logical, allocatable :: undef_mask(:,:) + integer :: status + + allocate(undef_mask(size(array,1),size(array,2))) + undef_mask = .false. + where(array /= undef_value) undef_mask = .true. + + local_min_value = minval(array,mask=undef_mask) + local_max_value = maxval(array,mask=undef_mask) + if (mpi_comm /= MPI_COMM_NULL) then + call MPI_AllReduce(local_min_value,min_value,1,MPI_FLOAT,MPI_MIN,mpi_comm,status) + _VERIFY(status) + call MPI_AllReduce(local_max_value,max_value,1,MPI_FLOAT,MPI_MAX,mpi_comm,status) + _VERIFY(status) + else + min_value = local_min_value + max_value = local_max_value + end if + _RETURN(_SUCCESS) + end subroutine + +end module MAPL_DownbitMod diff --git a/shared/MaplShared.F90 b/shared/MaplShared.F90 index b48e69f3b0d..404e987803a 100644 --- a/shared/MaplShared.F90 +++ b/shared/MaplShared.F90 @@ -20,5 +20,6 @@ module MaplShared use mapl_Constants use mapl_CommGroupDescriptionMod use mapl_AbstractCommSplitterMod + use mapl_DownbitMod end module MaplShared diff --git a/pfio/pFIO_ShaveMantissa.c b/shared/ShaveMantissa.c similarity index 79% rename from pfio/pFIO_ShaveMantissa.c rename to shared/ShaveMantissa.c index 145fb9617f1..5d84136d73a 100644 --- a/pfio/pFIO_ShaveMantissa.c +++ b/shared/ShaveMantissa.c @@ -2,7 +2,7 @@ #include #include #include -#include "pFIO_ShaveMantissa.h" /* protype */ +#include "ShaveMantissa.h" /* protype */ #define MAXBITS 20 @@ -22,7 +22,7 @@ //======================================== -float32 pfio_SetOffset(float32 minv, float32 maxv) +float32 MAPL_SetOffset(float32 minv, float32 maxv) { float32 midv, mnabs, range; @@ -43,7 +43,7 @@ float32 pfio_SetOffset(float32 minv, float32 maxv) // // !INTERFACE: */ -int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int has_undef, float32 undef, int32 chunksize ) +int MAPL_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int has_undef, float32 undef, int32 chunksize, int passed_minmax, float32 arr_min, float32 arr_max ) /* // !INPUT PARAMETERS: @@ -101,7 +101,7 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int // was not copying input to output arrays. // 10Mar2009 Suarez Used a union for the shaving. Also changed the // SKIP checks and protected the max and min. -// 24oct2009 da Silva Changed abs() to fabs() in pfio_SetOffset; moved float32 +// 24oct2009 da Silva Changed abs() to fabs() in MAPL_SetOffset; moved float32 // defs to header so that it can be used with prototype. // 28oct2010 da Silva Changed another occurence of abs() -> fabs() //EOP @@ -125,14 +125,14 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int if ( len < 0 || xbits < 1 ) { fprintf(stderr, - "ShaveMantissa32: Bad length of mask bits: len= %d, xbits= %d\n", + "MAPL_ShaveMantissa32: Bad length of mask bits: len= %d, xbits= %d\n", len, xbits ); return 1; } if ( xbits > MAXBITS ) { fprintf(stderr, - "ShaveMantissa32: Shaving too many bits: %d; maximum allowed is %d\n", + "MAPL_ShaveMantissa32: Shaving too many bits: %d; maximum allowed is %d\n", xbits, MAXBITS ); return 2; } @@ -155,7 +155,7 @@ int pFIO_ShaveMantissa32 ( float32 a[], float32 ain[], int32 len, int xbits, int b = a; if(ain!=a) { if(labs(ain-a) Date: Thu, 2 Feb 2023 08:38:33 -0500 Subject: [PATCH 51/83] Update build like UFS CI test --- .circleci/config.yml | 2 +- CHANGELOG.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index de7b95929ac..b0bbe2fdcc1 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -82,7 +82,7 @@ workflows: baselibs_version: *baselibs_version repo: MAPL mepodevelop: false - extra_cmake_options: "-DBUILD_WITH_FLAP=OFF -DBUILD_WITH_PFLOGGER=OFF -DBUILD_SHARED_MAPL=OFF" + extra_cmake_options: "-DBUILD_WITH_FLAP=OFF -DBUILD_WITH_PFLOGGER=OFF -DBUILD_WITH_FARGPARSE=OFF -DUSE_EXTDATA2G=OFF -DBUILD_SHARED_MAPL=OFF" run_unit_tests: true ctest_options: "-LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" diff --git a/CHANGELOG.md b/CHANGELOG.md index 5ce73c54469..b7165ed4a51 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,6 +31,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Moved most of the MAPL_GetResource generic subroutine to a new module, MAPL_ResourceMod, in base. The specific subroutines remain in MAPL_GenericMod to maintain the interface in one module, but most of the functionality is in MAPL_ResourceMod now. +- Update "build like UFS" CI test ### Fixed From 46fe6a2c3f8d5a50a787aa8b981333fc1f5a06d0 Mon Sep 17 00:00:00 2001 From: Patricia Castellanos Date: Thu, 2 Feb 2023 12:48:37 -0500 Subject: [PATCH 52/83] PC - some constants were defined after where they were needed. Also MAPL_UNDEF was missing --- Python/MAPL/constants.py | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Python/MAPL/constants.py b/Python/MAPL/constants.py index faeb9580a4e..431ebe07af1 100644 --- a/Python/MAPL/constants.py +++ b/Python/MAPL/constants.py @@ -6,12 +6,15 @@ MAPL_DEGREES_TO_RADIANS = MAPL_PI / 180.0 MAPL_RADIANS_TO_DEGREES = 180.0 / MAPL_PI +MAPL_UNDEF = 1.0e15 MAPL_PSDRY = 98305.0 # dry surface pressure [Pa] MAPL_SECONDS_PER_SIDEREAL_DAY = 86164.0 #s MAPL_GRAV = 9.80665 # m^2/s MAPL_RADIUS = 6371.0E3 # m MAPL_OMEGA = 2.0*MAPL_PI/MAPL_SECONDS_PER_SIDEREAL_DAY # 1/s +MAPL_RUNIV = 8314.47 # J/(Kmole K) +MAPL_H2OMW = 18.015 # kg/Kmole MAPL_EARTH_ECCENTRICITY = 8.1819190842622E-2 # -- MAPL_EARTH_SEMIMAJOR_AXIS = 6378137 # m MAPL_KM_PER_DEG = (1.0/(MAPL_RADIUS/1000.)) * MAPL_RADIANS_TO_DEGREES @@ -48,9 +51,7 @@ MAPL_STFBOL = 5.6734E-8 # W/(m^2 K^4) MAPL_AVOGAD = 6.023E26 # 1/kmol -MAPL_RUNIV = 8314.47 # J/(Kmole K) -MAPL_H2OMW = 18.015 # kg/Kmole MAPL_O3MW = 47.9982 # kg/Kmole MAPL_ALHL = 2.4665E6 # J/kg @15C MAPL_ALHF = 3.3370E5 # J/kg From b682ce61fdd279b37448e58fd631ad1b356d90c1 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 2 Feb 2023 14:59:09 -0500 Subject: [PATCH 53/83] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3d28b843c60..058146493b9 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 included), but can also provide the MEAN value (without EOT) via `FORCE_MLSHA=.TRUE.` optional argument. - Add `shavemantissa` f2py code. This is used by AeroApps. + - NOTE: If you do not have a need for this code, build with `-DUSE_F2PY=OFF`. Note that even if you try to build the f2py code, it might fail anyway due to issues with the Python stack on the machine. ESMA_cmake has code that "tests" if f2py works. If it doesn't, it should failover gracefully. ### Changed From 5611f582c0d3c672090f2a9e68c7131bd537b8cd Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 2 Feb 2023 17:04:51 -0500 Subject: [PATCH 54/83] Fixes #1952. Remove _VERIFY from History GC --- CHANGELOG.md | 1 + gridcomps/History/MAPL_HistoryCollection.F90 | 45 +- gridcomps/History/MAPL_HistoryGridComp.F90 | 1407 ++++++----------- .../History/MAPL_HistoryTrajectoryMod.F90 | 259 ++- 4 files changed, 591 insertions(+), 1121 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b7165ed4a51..a4cbe0a1635 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -32,6 +32,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 The specific subroutines remain in MAPL_GenericMod to maintain the interface in one module, but most of the functionality is in MAPL_ResourceMod now. - Update "build like UFS" CI test +- Converted the History Gridded Component to use `_RC` macro ### Fixed diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 0a63f2d548b..33befb7b704 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -156,44 +156,29 @@ subroutine AddGrid(this,output_grids,resolution,rc) im_world=resolution(1) jm_world=resolution(2) - cfg = MAPL_ConfigCreate(rc=status) - _VERIFY(status) + cfg = MAPL_ConfigCreate(_RC) if (resolution(2)==resolution(1)*6) then - call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) else - call MAPL_MakeDecomposition(nx,ny,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,_RC) end if - call MAPL_ConfigSetAttribute(cfg,value=nx, label=trim(tlabel)//".NX:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=ny, label=trim(tlabel)//".NY:",rc=status) - _VERIFY(status) + call MAPL_ConfigSetAttribute(cfg,value=nx, label=trim(tlabel)//".NX:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=ny, label=trim(tlabel)//".NY:",_RC) if (resolution(2)==resolution(1)*6) then - call MAPL_ConfigSetAttribute(cfg,value="Cubed-Sphere", label=trim(tlabel)//".GRID_TYPE:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=6, label=trim(tlabel)//".NF:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",rc=status) - _VERIFY(status) + call MAPL_ConfigSetAttribute(cfg,value="Cubed-Sphere", label=trim(tlabel)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=6, label=trim(tlabel)//".NF:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",_RC) else - call MAPL_ConfigSetAttribute(cfg,value="LatLon", label=trim(tlabel)//".GRID_TYPE:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value=jm_world,label=trim(tlabel)//".JM_WORLD:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value='PC', label=trim(tlabel)//".POLE:",rc=status) - _VERIFY(status) - call MAPL_ConfigSetAttribute(cfg,value='DC', label=trim(tlabel)//".DATELINE:",rc=status) - _VERIFY(status) + call MAPL_ConfigSetAttribute(cfg,value="LatLon", label=trim(tlabel)//".GRID_TYPE:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=im_world,label=trim(tlabel)//".IM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cfg,value=jm_world,label=trim(tlabel)//".JM_WORLD:",_RC) + call MAPL_ConfigSetAttribute(cfg,value='PC', label=trim(tlabel)//".POLE:",_RC) + call MAPL_ConfigSetAttribute(cfg,value='DC', label=trim(tlabel)//".DATELINE:",_RC) end if - output_grid = grid_manager%make_grid(cfg,prefix=trim(tlabel)//'.',rc=status) - _VERIFY(status) + output_grid = grid_manager%make_grid(cfg,prefix=trim(tlabel)//'.',_RC) - factory => grid_manager%get_factory(output_grid,rc=status) - _VERIFY(status) + factory => grid_manager%get_factory(output_grid,_RC) this%output_grid_label = factory%generate_grid_name() lgrid => output_grids%at(trim(this%output_grid_label)) if (.not.associated(lgrid)) call output_grids%insert(this%output_grid_label,output_grid) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 522ec9a1473..a2ed99c4df7 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -151,35 +151,28 @@ subroutine SetServices ( gc, rc ) ! Register services for this component ! ------------------------------------ - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_INITIALIZE, Initialize, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_RUN, Run, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_FINALIZE, Finalize, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_FINALIZE, Finalize, _RC) - call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_WRITERESTART, RecordRestart, rc=status) - _VERIFY(status) + call MAPL_GridCompSetEntryPoint ( gc, ESMF_METHOD_WRITERESTART, RecordRestart, _RC) ! Allocate an instance of the private internal state... !------------------------------------------------------ - allocate(internal_state, stat=status) - _VERIFY(status) + allocate(internal_state, _STAT) ! and save its pointer in the GC !------------------------------- wrap%ptr => internal_state call ESMF_GridCompSetInternalState(gc, wrap, status) - _VERIFY(status) ! Generic Set Services ! -------------------- - call MAPL_GenericSetServices ( gc,RC=STATUS ) - _VERIFY(STATUS) + call MAPL_GenericSetServices ( gc,_RC ) _RETURN(ESMF_SUCCESS) @@ -434,12 +427,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _UNUSED_DUMMY(dumexport) - call MAPL_GetObjectFromGC ( gc, GENSTATE, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GetObjectFromGC ( gc, GENSTATE, _RC) ! Retrieve the pointer to the state call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr call ESMF_UserCompGetInternalState(GC, 'MAPL_LocStreamList', & @@ -448,13 +439,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) lsaddr_ptr => lswrap%ptr%lsaddr_ptr end if - call ESMF_GridCompGet(gc, vm=vm, rc=status) - _VERIFY(status) + call ESMF_GridCompGet(gc, vm=vm, _RC) - call ESMF_VMGetCurrent(vm, rc=status) - _VERIFY(status) - call ESMF_VMGet (VM, localpet=MYPE, petcount=NPES, RC=STATUS) - _VERIFY(STATUS) + call ESMF_VMGetCurrent(vm, _RC) + call ESMF_VMGet (VM, localpet=MYPE, petcount=NPES, _RC) IntState%mype = mype IntState%npes = npes @@ -462,10 +450,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get Clock StartTime for Default ref_date, ref_time ! -------------------------------------------------- - call ESMF_ClockGet ( clock, calendar=cal, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, currTime=CurrTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, StartTime=StartTime,rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_TimeGet ( StartTime, TimeString=string ,rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_ClockGet ( clock, calendar=cal, _RC ) + call ESMF_ClockGet ( clock, currTime=CurrTime, _RC ) + call ESMF_ClockGet ( clock, StartTime=StartTime,_RC ) + call ESMF_TimeGet ( StartTime, TimeString=string ,_RC ) read(string( 1: 4),'(i4.4)') year read(string( 6: 7),'(i2.2)') month @@ -477,7 +465,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) nymd0 = year*10000 + month*100 + day nhms0 = hour*10000 + minute*100 + second - call ESMF_TimeGet ( CurrTime, TimeString=string ,rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_TimeGet ( CurrTime, TimeString=string ,_RC ) read(string( 1: 4),'(i4.4)') year read(string( 6: 7),'(i2.2)') month @@ -497,17 +485,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Read User-Supplied History Lists from Config File ! ------------------------------------------------- - call ESMF_GridCompGet( gc, config=config, rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_GridCompGet( gc, config=config, _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%expsrc, & - label ='EXPSRC:', default='', rc=status ) - _VERIFY(STATUS) + label ='EXPSRC:', default='', _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%expid, & - label ='EXPID:', default='', rc=status ) - _VERIFY(STATUS) + label ='EXPID:', default='', _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%expdsc, & - label ='EXPDSC:', default='', rc=status ) - _VERIFY(STATUS) + label ='EXPDSC:', default='', _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%global_atts%institution, & label ='INSTITUTION:', default='NASA Global Modeling and Assimilation Office', _RC) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%global_atts%references, & @@ -522,18 +507,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label ='SOURCE:', & default=trim(INTSTATE%expsrc) // ' experiment_id: ' // trim(INTSTATE%expid), _RC) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%CoresPerNode, & - label ='CoresPerNode:', default=min(npes,8), rc=status ) - _VERIFY(STATUS) + label ='CoresPerNode:', default=min(npes,8), _RC ) call ESMF_ConfigGetAttribute ( config, value=disableSubVmChecks, & - label ='DisableSubVmChecks:', default=.false., rc=status ) - _VERIFY(STATUS) + label ='DisableSubVmChecks:', default=.false., _RC ) call ESMF_ConfigGetAttribute ( config, value=INTSTATE%AvoidRootNodeThreshold, & - label ='AvoidRootNodeThreshold:', default=1024, rc=status ) - _VERIFY(STATUS) + label ='AvoidRootNodeThreshold:', default=1024, _RC ) call ESMF_ConfigGetAttribute(config, value=cFileOrder, & - label='FileOrder:', default='ABC', rc=status) - _VERIFY(STATUS) + label='FileOrder:', default='ABC', _RC) call ESMF_ConfigGetAttribute(config, value=intState%allow_overwrite, & label='Allow_Overwrite:', default=.false., _RC) create_mode = PFIO_NOCLOBBER ! defaut no overwrite @@ -550,21 +531,16 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_ConfigGetAttribute(config, value=intstate%integer_time,label="IntegerTime:", default=.false.,_RC) call ESMF_ConfigGetAttribute(config, value=IntState%collectionWriteSplit, & - label = 'CollectionWriteSplit:', default=0, rc=status) - _VERIFY(status) + label = 'CollectionWriteSplit:', default=0, _RC) call ESMF_ConfigGetAttribute(config, value=IntState%serverSizeSplit, & - label = 'ServerSizeSplit:', default=0, rc=status) - _VERIFY(status) + label = 'ServerSizeSplit:', default=0, _RC) call o_Clients%split_server_pools(n_server_split = IntState%serverSizeSplit, & - n_hist_split = IntState%collectionWriteSplit,rc=status) - _VERIFY(status) + n_hist_split = IntState%collectionWriteSplit,_RC) call ESMF_ConfigGetAttribute(config, value=snglcol, & - label='SINGLE_COLUMN:', default=0, rc=status) - _VERIFY(STATUS) + label='SINGLE_COLUMN:', default=0, _RC) call ESMF_ConfigGetAttribute(config, value=intstate%version, & - label='VERSION:', default=0, rc=status) - _VERIFY(STATUS) + label='VERSION:', default=0, _RC) if( MAPL_AM_I_ROOT() ) then print * print *, 'EXPSRC:',trim(INTSTATE%expsrc) @@ -581,12 +557,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) print *, '-------------------------' endif - call ESMF_ConfigFindLabel ( config,'COLLECTIONS:',rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigFindLabel ( config,'COLLECTIONS:',_RC ) tend = .false. nlist = 0 - allocate(IntState%list(nlist), stat=status) - _VERIFY(STATUS) + allocate(IntState%list(nlist), _STAT) do while (.not.tend) call ESMF_ConfigGetAttribute ( config,value=tmpstring,default='',rc=STATUS) !ALT: we don't check return status!!! if (tmpstring /= '') then @@ -596,16 +570,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call IntState%collections%push_back(collection) nlist = nlist + 1 - allocate( list(nlist), stat=status ) - _VERIFY(STATUS) + allocate( list(nlist), _STAT ) list(1:nlist-1)=IntState%list list(nlist)%collection = tmpstring list(nlist)%filename = list(nlist)%collection deallocate(IntState%list) IntState%list => list end if - call ESMF_ConfigNextLine ( config,tableEnd=tend,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( config,tableEnd=tend,_RC ) enddo if (nlist == 0) then @@ -619,40 +591,32 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) integer :: nl character(len=60) :: grid_type - call ESMF_ConfigFindLabel ( config,'GRID_LABELS:',rc=STATUS ) - _VERIFY(status) + call ESMF_ConfigFindLabel ( config,'GRID_LABELS:',_RC ) tend = .false. do while (.not.tend) call ESMF_ConfigGetAttribute ( config,value=tmpstring,default='',rc=STATUS) !ALT: we don't check return status!!! if (tmpstring /= '') then call IntState%output_grids%insert(trim(tmpString), output_grid) end if - call ESMF_ConfigNextLine ( config,tableEnd=tend,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( config,tableEnd=tend,_RC ) enddo iter = IntState%output_grids%begin() do while (iter /= IntState%output_grids%end()) key => iter%key() - call ESMF_ConfigGetAttribute(config, value=grid_type, label=trim(key)//".GRID_TYPE:",rc=status) - _VERIFY(status) - call ESMF_ConfigFindLabel(config,trim(key)//".NX:",isPresent=hasNX,rc=status) - _VERIFY(status) - call ESMF_ConfigFindLabel(config,trim(key)//".NY:",isPresent=hasNY,rc=status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(config, value=grid_type, label=trim(key)//".GRID_TYPE:",_RC) + call ESMF_ConfigFindLabel(config,trim(key)//".NX:",isPresent=hasNX,_RC) + call ESMF_ConfigFindLabel(config,trim(key)//".NY:",isPresent=hasNY,_RC) if ((.not.hasNX) .and. (.not.hasNY)) then if (trim(grid_type)=='Cubed-Sphere') then - call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,reduceFactor=6,_RC) else - call MAPL_MakeDecomposition(nx,ny,rc=status) - _VERIFY(status) + call MAPL_MakeDecomposition(nx,ny,_RC) end if - call MAPL_ConfigSetAttribute(config, value=nx,label=trim(key)//".NX:",rc=status) - call MAPL_ConfigSetAttribute(config, value=ny,label=trim(key)//".NY:",rc=status) + call MAPL_ConfigSetAttribute(config, value=nx,label=trim(key)//".NX:",_RC) + call MAPL_ConfigSetAttribute(config, value=ny,label=trim(key)//".NY:",_RC) end if - output_grid = grid_manager%make_grid(config, prefix=key//'.', rc=status) - _VERIFY(status) + output_grid = grid_manager%make_grid(config, prefix=key//'.', _RC) call IntState%output_grids%set(key, output_grid) call iter%next() end do @@ -660,8 +624,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if if (intstate%version >= 2) then - call ESMF_ConfigFindLabel(config, 'FIELD_SETS:', rc=status) - _VERIFY(status) + call ESMF_ConfigFindLabel(config, 'FIELD_SETS:', _RC) table_end = .false. do while (.not. table_end) call ESMF_ConfigGetAttribute ( config, value=tmpstring,default='',rc=STATUS) !ALT: we don't check return status!!! @@ -671,28 +634,23 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call intstate%field_sets%insert(trim(tmpString), field_set) deallocate(field_set) end if - call ESMF_ConfigNextLine ( config,tableEnd=table_end,rc=STATUS ) - _VERIFY(STATUS) + 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() field_set => field_set_iter%value() - call parse_fields(config, key, field_set, rc=status) - _VERIFY(status) + call parse_fields(config, key, field_set, _RC) call field_set_iter%next() end do end if - allocate(IntState%Regrid(nlist), stat=STATUS) - _VERIFY(STATUS) - allocate( Vvarn(nlist), stat=STATUS) - _VERIFY(STATUS) - allocate(INTSTATE%STAMPOFFSET(nlist), stat=status) - _VERIFY(STATUS) + allocate(IntState%Regrid(nlist), _STAT) + allocate( Vvarn(nlist), _STAT) + allocate(INTSTATE%STAMPOFFSET(nlist), _STAT) ! We are parsing HISTORY config file to split each collection into separate RC ! ---------------------------------------------------------------------------- @@ -700,16 +658,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( MAPL_AM_I_ROOT(vm) ) then call ESMF_ConfigGetAttribute(config, value=HIST_CF, & - label="HIST_CF:", default="HIST.rc", RC=STATUS ) - _VERIFY(STATUS) - unitr = GETFILE(HIST_CF, FORM='formatted', RC=status) - _VERIFY(STATUS) + label="HIST_CF:", default="HIST.rc", _RC ) + unitr = GETFILE(HIST_CF, FORM='formatted', _RC) ! for each collection do n = 1, nlist rewind(unitr) string = trim( list(n)%collection ) // '.' - unitw = GETFILE(trim(string)//'rcx', FORM='formatted', RC=status) + unitw = GETFILE(trim(string)//'rcx', FORM='formatted', _RC) match = .false. contLine = .false. @@ -732,18 +688,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end do 1234 continue - call free_file(unitw, rc=status) - _VERIFY(STATUS) + call free_file(unitw, _RC) end do - call free_file(unitr, rc=status) - _VERIFY(STATUS) + call free_file(unitr, _RC) end if - call ESMF_VMbarrier(vm, RC=status) - _VERIFY(STATUS) + call ESMF_VMbarrier(vm, _RC) ! Initialize History Lists ! ------------------------ @@ -764,20 +717,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%splitField = .false. list(n)%regex = .false. - cfg = ESMF_ConfigCreate(rc=STATUS) - _VERIFY(STATUS) + cfg = ESMF_ConfigCreate(_RC) - call ESMF_ConfigLoadFile(cfg, filename = trim(string)//'rcx', rc=status) - _VERIFY(STATUS) + call ESMF_ConfigLoadFile(cfg, filename = trim(string)//'rcx', _RC) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%template, default="", & - label=trim(string) // 'template:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'template:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%format,default='flat', & - label=trim(string) // 'format:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'format:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%mode,default='instantaneous', & - label=trim(string) // 'mode:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'mode:' ,_RC ) ! Fill the global attributes @@ -786,8 +734,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%global_atts%filename = list(n)%filename call ESMF_ConfigGetAttribute ( cfg, value=list(n)%global_atts%descr, & default=INTSTATE%expdsc, & - label=trim(string) // 'descr:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'descr:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=list(n)%global_atts%comment, & default=INTSTATE%global_atts%comment, & label=trim(string) // 'comment:' ,_RC) @@ -808,69 +755,53 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label=trim(string) // 'source:' ,_RC) call ESMF_ConfigGetAttribute ( cfg, mntly, default=0, & - label=trim(string) // 'monthly:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'monthly:',_RC ) list(n)%monthly = (mntly /= 0) call ESMF_ConfigGetAttribute ( cfg, spltFld, default=0, & - label=trim(string) // 'splitField:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'splitField:',_RC ) list(n)%splitField = (spltFld /= 0) call ESMF_ConfigGetAttribute ( cfg, useRegex, default=0, & - label=trim(string) // 'UseRegex:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'UseRegex:',_RC ) list(n)%regex = (useRegex /= 0) call ESMF_ConfigGetAttribute ( cfg, list(n)%frequency, default=060000, & - label=trim(string) // 'frequency:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'frequency:',_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%acc_interval, default=list(n)%frequency, & - label=trim(string) // 'acc_interval:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'acc_interval:',_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%ref_date, default=nymdc, & - label=trim(string) // 'ref_date:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'ref_date:',_RC ) _ASSERT(is_valid_date(list(n)%ref_date),'Invalid ref_date') call ESMF_ConfigGetAttribute ( cfg, list(n)%ref_time, default=000000, & - label=trim(string) // 'ref_time:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'ref_time:',_RC ) _ASSERT(is_valid_time(list(n)%ref_time),'Invalid ref_time') call ESMF_ConfigGetAttribute ( cfg, list(n)%end_date, default=-999, & - label=trim(string) // 'end_date:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'end_date:',_RC ) if (list(n)%end_date /= -999) then _ASSERT(is_valid_date(list(n)%end_date),'Invalid end_date') end if call ESMF_ConfigGetAttribute ( cfg, list(n)%end_time, default=-999, & - label=trim(string) // 'end_time:',rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'end_time:',_RC ) if (list(n)%end_time /= -999) then _ASSERT(is_valid_time(list(n)%end_time),'Invalid end_time') end if call ESMF_ConfigGetAttribute ( cfg, list(n)%duration, default=list(n)%frequency, & - label=trim(string) // 'duration:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'duration:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%verbose, default=0, & - label=trim(string) // 'verbose:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'verbose:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%vscale, default=1.0, & - label=trim(string) // 'vscale:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'vscale:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%vunit, default="", & - label=trim(string) // 'vunit:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'vunit:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%nbits_to_keep, default=MAPL_NBITS_NOT_SET, & - label=trim(string) // 'nbits:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'nbits:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%deflate, default=0, & - label=trim(string) // 'deflate:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'deflate:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, list(n)%quantize_algorithm_string, default='NONE', & - label=trim(string) // 'quantize_algorithm:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'quantize_algorithm:' ,_RC ) ! Uppercase the algorithm string just to allow for any case uppercase_algorithm = ESMF_UtilStringUpperCase(list(n)%quantize_algorithm_string,_RC) @@ -888,8 +819,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end select call ESMF_ConfigGetAttribute ( cfg, list(n)%quantize_level, default=0, & - label=trim(string) // 'quantize_level:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'quantize_level:' ,_RC ) ! If nbits_to_keep < MAPL_NBITS_UPPER_LIMIT (24) and quantize_algorithm greater than 0, then a user might be doing different ! shaving algorithms. We do not allow this @@ -909,8 +839,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) tm_default = -1 call ESMF_ConfigGetAttribute ( cfg, list(n)%tm, default=tm_default, & - label=trim(string) // 'tm:', rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'tm:', _RC ) call ESMF_ConfigFindLabel ( cfg, label=trim(string) // 'conservative:',isPresent=has_conservative_keyword,_RC) call ESMF_ConfigFindLabel ( cfg, label=trim(string) // 'regrid_method:',isPresent=has_regrid_keyword,_RC) @@ -919,8 +848,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%regrid_method = REGRID_METHOD_BILINEAR if (has_conservative_keyword) then call ESMF_ConfigGetAttribute ( cfg, list(n)%regrid_method, default=0, & - label=trim(string) // 'conservative:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'conservative:' ,_RC ) if (list(n)%regrid_method==0) then list(n)%regrid_method=REGRID_METHOD_BILINEAR else if (list(n)%regrid_method==1) then @@ -929,23 +857,21 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if if (has_regrid_keyword) then call ESMF_ConfigGetAttribute ( cfg, regrid_method, default="REGRID_METHOD_BILINEAR", & - label=trim(string) // 'regrid_method:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'regrid_method:' ,_RC ) list(n)%regrid_method = regrid_method_string_to_int(trim(regrid_method)) end if ! Get an optional file containing a 1-D track for the output call ESMF_ConfigGetAttribute(cfg, value=list(n)%trackFile, default="", & - label=trim(string) // 'track_file:', rc=status) + label=trim(string) // 'track_file:', _RC) if (trim(list(n)%trackfile) /= '') list(n)%timeseries_output = .true. call ESMF_ConfigGetAttribute(cfg, value=list(n)%recycle_track, default=.false., & - label=trim(string) // 'recycle_track:', rc=status) + label=trim(string) // 'recycle_track:', _RC) ! Handle "backwards" mode: this is hidden (i.e. not documented) feature ! Defaults to .false. call ESMF_ConfigGetAttribute ( cfg, reverse, default=0, & - label=trim(string) // 'backwards:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'backwards:' ,_RC ) list(n)%backwards = (reverse /= 0) ! Disable streams when frequencies, times are negative @@ -959,8 +885,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) old_fields_style = .true. ! unless if (intstate%version >= 2) then call ESMF_ConfigGetAttribute ( cfg, value=field_set_name, label=trim(string)//'field_set:', & - & default='', rc=status) - _VERIFY(status) + & default='', _RC) if (field_set_name /= '') then ! field names already parsed old_fields_style = .false. field_set => intstate%field_sets%at(trim(field_set_name)) @@ -979,10 +904,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Decide on orientation of output ! ------------------------------- - call ESMF_ConfigFindLabel(cfg,trim(string)//'positive:',isPresent=isPresent,rc=status) + call ESMF_ConfigFindLabel(cfg,trim(string)//'positive:',isPresent=isPresent,_RC) if (isPresent) then - call ESMF_ConfigGetAttribute(cfg,value=list(n)%positive,rc=status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(cfg,value=list(n)%positive,_RC) _ASSERT(list(n)%positive=='down'.or.list(n)%positive=='up',"positive value for collection must be down or up") else list(n)%positive = 'down' @@ -996,12 +920,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) len = ESMF_ConfigGetLen( cfg, label=trim(trim(string) // 'levels:'), rc = status ) LEVS: if( status == ESMF_SUCCESS ) then - call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'levels:'), rc = status ) - _VERIFY(STATUS) + call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'levels:'),_RC) j = 0 do i = 1, len - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) cycle j = j + 1 @@ -1023,8 +945,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) INQUIRE ( FILE=trim(tmpstring), EXIST=fileExists ) _ASSERT(fileExists,'needs informative message') - unit = GETFILE(trim(tmpstring), form='formatted', rc=status) - _VERIFY(STATUS) + unit = GETFILE(trim(tmpstring), form='formatted', _RC) if (MAPL_Am_I_Root(vm)) then k=0 @@ -1036,11 +957,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if - call MAPL_CommsBcast(vm, DATA=k, N=1, ROOT=MAPL_Root, RC=status) - _VERIFY(STATUS) + call MAPL_CommsBcast(vm, DATA=k, N=1, ROOT=MAPL_Root, _RC) allocate( list(n)%levels(k), stat = status ) - _VERIFY(STATUS) if (MAPL_Am_I_Root(vm)) then rewind(unit) @@ -1050,8 +969,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if call MAPL_CommsBcast(vm, DATA=list(n)%levels, N=k, & - ROOT=MAPL_Root, RC=status) - _VERIFY(STATUS) + ROOT=MAPL_Root, _RC) call FREE_FILE(UNIT) end if @@ -1060,7 +978,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if(isFileName) cycle allocate( levels(j), stat = status ) - _VERIFY(STATUS) i1 = index(tmpstring(:),",") if( i1.eq.1 ) tmpstring = adjustl( tmpstring(2:) ) j1 = index(tmpstring(:),",")-1 @@ -1068,13 +985,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) read(tmpstring,*) levels(j) if( j.eq.1 ) then allocate( list(n)%levels(j), stat = status ) - _VERIFY(STATUS) list(n)%levels(j) = levels(j) else levels(1:j-1) = list(n)%levels(:) deallocate( list(n)%levels ) allocate( list(n)%levels(j), stat = status ) - _VERIFY(STATUS) list(n)%levels(:) = levels(:) endif deallocate( levels ) @@ -1083,11 +998,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get an interpolating variable ! ----------------------------- - call ESMF_ConfigFindLabel ( cfg,trim(string) // 'vvars:',isPresent=isPresent,rc=STATUS ) + call ESMF_ConfigFindLabel ( cfg,trim(string) // 'vvars:',isPresent=isPresent,_RC ) VINTRP: if(isPresent) then - call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(1), rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(1), _RC) i = index(list(n)%vvars(1)( 1:),"'") j = index(list(n)%vvars(1)(i+1:),"'")+i if( i.ne.0 ) then @@ -1096,11 +1010,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%vvars(1) = adjustl( list(n)%vvars(1) ) endif - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(2),rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=list(n)%vvars(2),_RC) else list(n)%vvars(2) = tmpstring endif @@ -1132,7 +1044,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( .not.found ) then list(n)%field_set%nfields = list(n)%field_set%nfields + 1 - allocate( fields(4, list(n)%field_set%nfields), stat=status ) + allocate( fields(4, list(n)%field_set%nfields), _STAT ) fields(1,1:list(n)%field_set%nfields-1) = list(n)%field_set%fields(1,:) fields(2,1:list(n)%field_set%nfields-1) = list(n)%field_set%fields(2,:) fields(3,1:list(n)%field_set%nfields-1) = list(n)%field_set%fields(3,:) @@ -1141,8 +1053,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) fields(2, list(n)%field_set%nfields ) = list(n)%vvars (2) fields(3, list(n)%field_set%nfields ) = Vvar fields(4, list(n)%field_set%nfields ) = BLANK - deallocate( list(n)%field_set%fields, stat=status ) - _VERIFY(STATUS) + deallocate( list(n)%field_set%fields, _STAT ) list(n)%field_set%fields => fields endif end if @@ -1158,8 +1069,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) select case (intstate%version) case(1:) call ESMF_ConfigGetAttribute ( cfg, tmpString, default='' , & - label=trim(string) // 'grid_label:' ,rc=status ) - _VERIFY(status) + label=trim(string) // 'grid_label:' ,_RC ) if (len_trim(tmpString) == 0) then list(n)%output_grid_label='' else @@ -1180,8 +1090,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) cubeFormat = 0 j = 0 do i = 1,2 - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) cycle j = j + 1 _ASSERT(j<=2,'needs informative message') @@ -1191,8 +1100,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if( j1.gt.0 ) tmpstring = adjustl( tmpstring(1:j1) ) read(tmpstring,*) resolution(j) enddo - call list(n)%AddGrid(IntState%output_grids,resolution,rc=status) - _VERIFY(status) + call list(n)%AddGrid(IntState%output_grids,resolution,_RC) else list(n)%output_grid_label='' end if @@ -1204,36 +1112,30 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) newFormat = cubeFormat if (cubeFormat /= 0) then call ESMF_ConfigGetAttribute ( cfg, newFormat, default=cubeFormat, & - label=trim(string) // 'cubeFormat:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'cubeFormat:' ,_RC ) end if list(n)%useNewFormat = (newFormat /= 0) ! Force history so that time averaged collections are timestamped with write time call ESMF_ConfigGetAttribute(cfg, list(n)%ForceOffsetZero, default=.false., & - label=trim(string)//'timestampEnd:', rc=status) - _VERIFY(status) + label=trim(string)//'timestampEnd:', _RC) ! Force history so that time averaged collections are timestamped at the begining of the accumulation interval call ESMF_ConfigGetAttribute(cfg, list(n)%timeStampStart, default=.false., & - label=trim(string)//'timestampStart:', rc=status) - _VERIFY(status) + label=trim(string)//'timestampStart:', _RC) ! Get an optional chunk size ! -------------------------- len = ESMF_ConfigGetLen(cfg, label=trim(trim(string) // 'chunksize:'), rc = status) if ( status == ESMF_SUCCESS ) then - call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'chunksize:'), rc =status) - _VERIFY(STATUS) + call ESMF_ConfigFindLabel( cfg, label=trim(trim(string) // 'chunksize:'), _RC) chnksz = 4 if (list(n)%useNewFormat) then chnksz = 5 end if allocate( list(n)%chunksize(chnksz), stat = status) - _VERIFY(STATUS) j=0 do i=1,len - call ESMF_ConfigGetAttribute( cfg,value=tmpstring, rc=status) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute( cfg,value=tmpstring, _RC) if (trim(tmpstring) == ',' ) cycle j = j + 1 _ASSERT(j<=6,'needs informative message') @@ -1248,17 +1150,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get an optional tile file for regridding the output ! --------------------------------------------------- call ESMF_ConfigGetAttribute ( cfg, value=tilefile, default="", & - label=trim(string) // 'regrid_exch:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'regrid_exch:' ,_RC ) call ESMF_ConfigGetAttribute ( cfg, value=gridname, default="", & - label=trim(string) // 'regrid_name:' ,rc=status ) - _VERIFY(STATUS) + label=trim(string) // 'regrid_name:' ,_RC ) NULLIFY(IntState%Regrid(n)%PTR) if (tilefile /= '' .OR. gridname /= '') then - allocate(IntState%Regrid(n)%PTR, stat=status) - _VERIFY(STATUS) + allocate(IntState%Regrid(n)%PTR, _STAT) IntState%Regrid(n)%PTR%tilefile = tilefile IntState%Regrid(n)%PTR%gridname = gridname end if @@ -1302,7 +1201,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) RingTime = startOfThisMonth else sec = MAPL_nsecf( list(n)%frequency ) - call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, _RC ) RingTime = RefTime end if @@ -1316,16 +1215,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) RingTime = RingTime + (INT((currTime - RingTime)/frequency)+1)*frequency endif if ( list(n)%backwards ) then - list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, rc=status ) + list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, _RC ) else - list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%his_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) if( list(n)%duration.ne.0 ) then if (.not.list(n)%monthly) then sec = MAPL_nsecf( list(n)%duration ) - call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, S=sec, StartTime=StartTime, _RC ) else Frequency = oneMonth !ALT keep the values from above @@ -1337,21 +1235,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) RingTime = RingTime + (INT((currTime - RingTime)/frequency)+1)*frequency endif if ( list(n)%backwards ) then - list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, rc=status ) + list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, _RC ) else - list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) if (list(n)%monthly .and. (currTime == RingTime)) then - call ESMF_AlarmRingerOn( list(n)%his_alarm,rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOn( list(n)%his_alarm,_RC ) end if else ! this alarm should never ring, but it is checked if ringing list(n)%seg_alarm = ESMF_AlarmCreate( clock=clock, enabled=.false., & - ringTime=currTime, name='historyNewSegment', rc=status ) - _VERIFY(STATUS) + ringTime=currTime, name='historyNewSegment', _RC ) endif ! Mon Alarm based on 1st of Month 00Z @@ -1370,17 +1265,16 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) M = REF_TIME(5), & S = REF_TIME(6), calendar=cal, rc=rc ) - call ESMF_TimeIntervalSet( Frequency, MM=1, calendar=cal, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, MM=1, calendar=cal, _RC ) RingTime = RefTime do while ( RingTime < currTime ) RingTime = RingTime + Frequency enddo if ( list(n)%backwards ) then - list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, rc=status ) + list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, _RC ) else - list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%mon_alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) if(list(n)%monthly) then !ALT this is temporary workaround. It has a memory leak ! we need to at least destroy his_alarm before assignment @@ -1408,24 +1302,20 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) S = REF_TIME(6), calendar=cal, rc=rc ) if ( list(n)%backwards ) then - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, _RC ) else - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, sticky=.false., rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=RingTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) else if ( list(n)%backwards ) then - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, _RC ) else - list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, sticky=.false., rc=status ) + list(n)%end_alarm = ESMF_AlarmCreate( clock=clock, RingTime=CurrTime, sticky=.false., _RC ) endif - _VERIFY(STATUS) - call ESMF_AlarmRingerOff(list(n)%end_alarm, rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOff(list(n)%end_alarm, _RC ) endif - call ESMF_ConfigDestroy(cfg, rc=status) - _VERIFY(STATUS) + call ESMF_ConfigDestroy(cfg, _RC) enddo LISTLOOP if( MAPL_AM_I_ROOT() ) print * @@ -1433,8 +1323,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! START OF PARSER STUFF size0 = 1 !size( export ) nstatelist = 0 - allocate( statelist(size0), stat=status ) - _VERIFY(STATUS) + allocate( statelist(size0), _STAT ) statelist(1) = '' @@ -1452,13 +1341,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if enddo if(k.eq.nstatelist+1) then - allocate( tmplist (nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( tmplist (nstatelist), _STAT ) tmplist = statelist nstatelist = k deallocate( statelist ) - allocate( statelist(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( statelist(nstatelist), _STAT ) if (k > 1) statelist(1:k-1) = tmplist statelist(k) = list(n)%field_set%fields(2,m) deallocate( tmplist ) @@ -1475,14 +1362,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get Output Export States ! ------------------------ - allocate ( exptmp(size0), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp(size0), _STAT ) exptmp(1) = import - allocate ( export(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( export(nstatelist), _STAT ) errorFound = .false. - allocate ( stateListAvail(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( stateListAvail(nstatelist), _STAT ) stateListAvail = .true. if (disableSubVmChecks) then !ALT: setting disableSubVmChecks to .true. automatically assumes that subVm = .false. @@ -1495,10 +1379,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) enddo else do n=1,nstatelist - call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),rc=status ) + call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),_RC ) call ESMF_VMAllReduce(vm, sendData=status, recvData=globalStatus, & reduceflag=ESMF_REDUCE_MAX, rc=localStatus) - _VERIFY(localStatus) if( STATUS/= ESMF_SUCCESS ) then stateListAvail(n) = .false. @@ -1518,8 +1401,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! ---------------------------------------------- list(:)%subVm = .false. do n=1,nlist - allocate( list(n)%expSTATE(list(n)%field_set%nfields), stat=status ) - _VERIFY(STATUS) + allocate( list(n)%expSTATE(list(n)%field_set%nfields), _STAT ) do m=1,list(n)%field_set%nfields ! when we allow regex; some syntax resembles math expressions if (list(n)%regex .or. & @@ -1540,13 +1422,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Important: the next modifies the field's list ! first we check if any regex expressions need to expanded !--------------------------------------------------------- - call wildCardExpand(rc=status) - _VERIFY(status) + call wildCardExpand(_RC) do n=1,nlist m=list(n)%field_set%nfields - allocate(list(n)%r4(m), list(n)%r8(m), list(n)%r8_to_r4(m), stat=status) - _VERIFY(STATUS) + allocate(list(n)%r4(m), list(n)%r8(m), list(n)%r8_to_r4(m), _STAT) end do PARSER: do n=1,nlist @@ -1564,18 +1444,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) endif enddo - allocate(list(n)%tmpfields(list(n)%field_set%nfields), stat=status) - _VERIFY(STATUS) - allocate(list(n)%ReWrite(list(n)%field_set%nfields), stat=status) - _VERIFY(STATUS) + allocate(list(n)%tmpfields(list(n)%field_set%nfields), _STAT) + allocate(list(n)%ReWrite(list(n)%field_set%nfields), _STAT) list(n)%tmpfields='' list(n)%ReWrite= .FALSE. call MAPL_SetExpression(list(n)%field_set%nfields,list(n)%field_set%fields,list(n)%tmpfields,list(n)%rewrite, & list(n)%nPExtraFields, & - list(n)%PExtraFields, list(n)%PExtraGridComp, import,rc=STATUS) - _VERIFY(STATUS) + list(n)%PExtraFields, list(n)%PExtraGridComp, import,_RC) ENDDO PARSER @@ -1594,8 +1471,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) size0 = 1 !size( export ) nstatelist = 0 - allocate( statelist(size0), stat=status ) - _VERIFY(STATUS) + allocate( statelist(size0), _STAT ) statelist(1) = '' @@ -1611,13 +1487,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if enddo if(k.eq.nstatelist+1) then - allocate( tmplist (nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( tmplist (nstatelist), _STAT ) tmplist = statelist nstatelist = k deallocate( statelist ) - allocate( statelist(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate( statelist(nstatelist), _STAT ) if (k > 1) statelist(1:k-1) = tmplist statelist(k) = list(n)%field_set%fields(2,m) deallocate( tmplist ) @@ -1628,15 +1502,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get Output Export States ! ------------------------ - allocate ( exptmp (size0), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp (size0), _STAT ) exptmp(1) = import ! deallocate ( export ) - allocate ( export(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( export(nstatelist), _STAT ) errorFound = .false. - allocate ( stateListAvail(nstatelist), stat=status ) - _VERIFY(STATUS) + allocate ( stateListAvail(nstatelist), _STAT ) stateListAvail = .true. if (disableSubVmChecks) then !ALT: setting disableSubVmChecks to .true. automatically assumes that subVm = .false. @@ -1649,10 +1520,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) enddo else do n=1,nstatelist - call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),rc=status ) + call MAPL_ExportStateGet ( exptmp,statelist(n),export(n),_RC ) call ESMF_VMAllReduce(vm, sendData=status, recvData=globalStatus, & reduceflag=ESMF_REDUCE_MAX, rc=localStatus) - _VERIFY(localStatus) if( STATUS/= ESMF_SUCCESS ) then stateListAvail(n) = .false. @@ -1683,8 +1553,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! ---------------------------------------------- list(:)%subVm = .false. do n=1,nlist - allocate( list(n)%expSTATE(list(n)%field_set%nfields), stat=status ) - _VERIFY(STATUS) + allocate( list(n)%expSTATE(list(n)%field_set%nfields), _STAT ) do m=1,list(n)%field_set%nfields do k=1,nstatelist if( trim(list(n)%field_set%fields(2,m)) .eq. trim(statelist(k)) ) then @@ -1714,8 +1583,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) errorFound = .true. else if (index(list(n)%field_set%fields(1,m),'%') ==0) then - call MAPL_AllocateCoupling(Field, rc=status) - _VERIFY(STATUS) + call MAPL_AllocateCoupling(Field, _RC) end if end IF @@ -1725,8 +1593,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _ASSERT(.not. errorFound,'needs informative message') - allocate(INTSTATE%AVERAGE (nlist), stat=status) - _VERIFY(STATUS) + allocate(INTSTATE%AVERAGE (nlist), _STAT) IntState%average = .false. do n=1, nlist @@ -1739,14 +1606,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) else sec = MAPL_nsecf(list(n)%acc_interval) / 2 endif - call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, rc=status ) - _VERIFY(STATUS) + call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, _RC ) end do nactual = npes if (.not. disableSubVmChecks) then - allocate(allPes(npes), stat=status) - _VERIFY(STATUS) + allocate(allPes(npes), _STAT) minactual = npes do n=1, nlist NULLIFY(list(n)%peAve) @@ -1754,12 +1619,10 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) localPe(1) = mype if (list(n)%subVm) localPe(1) = -1 call ESMF_VMAllGather(vm, sendData=localPe, recvData=allPEs, & - count=1, rc=status) - _VERIFY(STATUS) + count=1, _RC) nactual = count(allPEs >= 0) minactual = min(minactual, nactual) - allocate(list(n)%peAve(nactual), stat=status) - _VERIFY(STATUS) + allocate(list(n)%peAve(nactual), _STAT) list(n)%peAve = pack(allPEs, allPEs>=0) end do @@ -1767,26 +1630,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) deallocate(allPEs) end if - allocate(INTSTATE%CCS(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%GIM(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%CIM(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%SRCS(nlist), stat=status) - _VERIFY(STATUS) - allocate(INTSTATE%DSTS(nlist), stat=status) - _VERIFY(STATUS) -! allocate(INTSTATE%GEX(nlist), stat=status) -! _VERIFY(STATUS) -! allocate(INTSTATE%GCNameList(nlist), stat=status) -! _VERIFY(STATUS) + allocate(INTSTATE%CCS(nlist), _STAT) + allocate(INTSTATE%GIM(nlist), _STAT) + allocate(INTSTATE%CIM(nlist), _STAT) + allocate(INTSTATE%SRCS(nlist), _STAT) + allocate(INTSTATE%DSTS(nlist), _STAT) +! allocate(INTSTATE%GEX(nlist), _STAT) +! allocate(INTSTATE%GCNameList(nlist), _STAT) ! Initialize Logical for Grads Control File ! ----------------------------------------- - allocate( INTSTATE%LCTL(nlist), stat=status ) - _VERIFY(STATUS) + allocate( INTSTATE%LCTL(nlist), _STAT ) do n=1,nlist if (list(n)%disabled) cycle if( list(n)%format == 'flat' ) then @@ -1802,8 +1657,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) IntState%GIM(n) = ESMF_StateCreate ( name=trim(list(n)%filename), & stateIntent = ESMF_STATEINTENT_IMPORT, & - rc=status ) - _VERIFY(STATUS) + _RC ) select case (list(n)%mode) case ("instantaneous") @@ -1823,20 +1677,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! query a field from export (arbitrary first field in the stream) for grid_in _ASSERT(size(export(list(n)%expSTATE)) > 0,'needs informative message') call MAPL_StateGet( export(list(n)%expSTATE(1)), & - trim(list(n)%field_set%fields(1,1)), field, rc=status ) - _VERIFY(STATUS) + trim(list(n)%field_set%fields(1,1)), field, _RC ) IntState%Regrid(n)%PTR%state_out = ESMF_StateCreate ( name=trim(list(n)%filename)//'regrid_in', & stateIntent = ESMF_STATEINTENT_IMPORT, & - rc=status ) - _VERIFY(STATUS) + _RC ) ! get grid name, layout, dims - call ESMF_FieldGet(field, grid=grid_in, rc=status) - _VERIFY(STATUS) - call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, rc=status) - _VERIFY(STATUS) - call ESMF_DistGridGet(distgrid, delayout=layout, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, grid=grid_in, _RC) + call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, _RC) + call ESMF_DistGridGet(distgrid, delayout=layout, _RC) IntState%Regrid(n)%PTR%noxform = .false. @@ -1857,16 +1706,13 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! set the pointer to LocStream call ESMF_AttributeGet(grid_in, name='TILEGRID_LOCSTREAM_ADDR', & - value=ADDR, rc=status) - _VERIFY(STATUS) + value=ADDR, _RC) call c_MAPL_LocStreamRestorePtr(exch, ADDR) ! Get the attached grid - call MAPL_LocStreamGet(EXCH, ATTACHEDGRID=GRID_ATTACHED, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamGet(EXCH, ATTACHEDGRID=GRID_ATTACHED, _RC) - call ESMF_GridGet(grid_attached, name=attachedName, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid_attached, name=attachedName, _RC) if (attachedName == IntState%Regrid(n)%PTR%gridname) then ! T2G @@ -1889,10 +1735,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) _ASSERT(associated(LSADDR_PTR),'needs informative message') do i = 1, size(LSADDR_PTR) call c_MAPL_LocStreamRestorePtr(locStream, LSADDR_PTR(i)) - call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(grid, name=tmpstr, rc=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, _RC) + call ESMF_GridGet(grid, name=tmpstr, _RC) if (tmpstr == IntState%Regrid(n)%PTR%gridname) then found = .true. exit @@ -1916,8 +1760,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) !>>> ! get gridnames from exch - call MAPL_LocStreamGet(exch, GRIDNAMES = GNAMES, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamGet(exch, GRIDNAMES = GNAMES, _RC) ngrids = size(gnames) _ASSERT(ngrids==2,'needs informative message') @@ -1937,10 +1780,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) found = .false. do i = 1, size(LSADDR_PTR) call c_MAPL_LocStreamRestorePtr(locStream, LSADDR_PTR(i)) - call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, RC=STATUS) - _VERIFY(STATUS) - call ESMF_GridGet(grid, name=tmpstr, rc=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(locStream, ATTACHEDGRID=GRID, _RC) + call ESMF_GridGet(grid, name=tmpstr, _RC) if (tmpstr == gnames(NG)) then found = .true. exit @@ -1956,19 +1797,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) LocStreamIn=exch, & NAME='historyXFORMnative', & UseFCollect=.true., & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) ! get the name and layout of attached grid - call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, rc=status) - _VERIFY(STATUS) - call ESMF_DistGridGet(distgrid, delayout=layout, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid_in, name=gridname, distgrid=distgrid, _RC) + call ESMF_DistGridGet(distgrid, delayout=layout, _RC) call MAPL_LocStreamCreate(IntState%Regrid(n)%PTR%locIn, & layout, FILENAME=IntState%Regrid(n)%PTR%TILEFILE, & - NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, RC=STATUS) - _VERIFY(STATUS) + NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, _RC) end if end if @@ -1982,8 +1819,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call MAPL_LocStreamCreate(IntState%Regrid(n)%PTR%locIn, & layout, FILENAME=IntState%Regrid(n)%PTR%TILEFILE, & - NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, RC=STATUS) - _VERIFY(STATUS) + NAME='history_in', MASK=(/MAPL_Ocean/), grid=grid_in, _RC) end if @@ -1992,8 +1828,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (.not. ontiles) then ! get gridnames from loc_in call MAPL_LocStreamGet(IntState%Regrid(n)%PTR%locIn, & - GRIDNAMES = GNAMES, RC=STATUS) - _VERIFY(STATUS) + GRIDNAMES = GNAMES, _RC) ! query loc_in for ngrids ngrids = size(gnames) _ASSERT(ngrids==2,'needs informative message') @@ -2026,21 +1861,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) grid_out=pgrid call MAPL_LocStreamCreate(IntState%Regrid(n)%PTR%locOut, & layout, FILENAME=IntState%Regrid(n)%PTR%TILEFILE, & - NAME='history_out', MASK=(/MAPL_Ocean/), Grid=grid_out, RC=STATUS) - _VERIFY(STATUS) + NAME='history_out', MASK=(/MAPL_Ocean/), Grid=grid_out, _RC) endif ! query ntiles call MAPL_LocStreamGet(IntState%Regrid(n)%PTR%locOut, & - NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_out, rc=status) - _VERIFY(STATUS) + NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_out, _RC) if (.not.INTSTATE%Regrid(n)%PTR%noxform) then ! query ntiles call MAPL_LocStreamGet(IntState%Regrid(n)%PTR%locIn, & - NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_in, rc=status) - _VERIFY(STATUS) + NT_LOCAL = IntState%Regrid(n)%PTR%ntiles_in, _RC) ! create XFORM call MAPL_LocStreamCreateXform ( XFORM=INTSTATE%Regrid(n)%PTR%XFORM, & @@ -2048,8 +1880,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) LocStreamIn=INTSTATE%Regrid(n)%PTR%LocIn, & NAME='historyXFORM', & UseFCollect=.true., & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) end if endif @@ -2057,25 +1888,18 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Handle possible extra fields needed for the parser if (list(n)%nPExtraFields > 0) then - allocate ( exptmp (1), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp (1), _STAT ) exptmp(1) = import do m=1,list(n)%nPExtraFields - call MAPL_ExportStateGet(exptmp,list(n)%PExtraGridComp(m),parser_state,rc=status) - _VERIFY(STATUS) - call MAPL_StateGet(parser_state,list(n)%PExtraFields(m),parser_field,rc=status) - _VERIFY(STATUS) - call MAPL_AllocateCoupling(parser_field, rc=status) - _VERIFY(STATUS) - f = MAPL_FieldCreate(parser_field, name=list(n)%PExtraFields(m), rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet(exptmp,list(n)%PExtraGridComp(m),parser_state,_RC) + call MAPL_StateGet(parser_state,list(n)%PExtraFields(m),parser_field,_RC) + call MAPL_AllocateCoupling(parser_field, _RC) + f = MAPL_FieldCreate(parser_field, name=list(n)%PExtraFields(m), _RC) if (IntState%average(n)) then - call MAPL_StateAdd(IntState%CIM(N), f, rc=status) - _VERIFY(STATUS) + call MAPL_StateAdd(IntState%CIM(N), f, _RC) else - call MAPL_StateAdd(IntState%GIM(N), f, rc=status) - _VERIFY(STATUS) + call MAPL_StateAdd(IntState%GIM(N), f, _RC) end if end do @@ -2363,39 +2187,33 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call MAPL_StateCreateFromSpec(IntState%GIM(n), & IntState%DSTS(n)%SPEC, & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) ! create CC if (nactual == npes) then IntState%CCS(n) = ESMF_CplCompCreate ( & NAME = list(n)%collection, & contextFlag = ESMF_CONTEXT_PARENT_VM, & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) else IntState%CCS(n) = ESMF_CplCompCreate ( & NAME = list(n)%collection, & petList = list(n)%peAve, & contextFlag = ESMF_CONTEXT_OWN_VM, & - RC=STATUS ) - _VERIFY(STATUS) + _RC ) end if ! CCSetServ call ESMF_CplCompSetServices (IntState%CCS(n), & - GenericCplSetServices, RC=STATUS ) - _VERIFY(STATUS) + GenericCplSetServices, _RC ) call MAPL_CplCompSetVarSpecs(IntState%CCS(n), & INTSTATE%SRCS(n)%SPEC,& - INTSTATE%DSTS(n)%SPEC,RC=STATUS) - _VERIFY(STATUS) + INTSTATE%DSTS(n)%SPEC,_RC) if (list(n)%monthly) then call MAPL_CplCompSetAlarm(IntState%CCS(n), & - list(n)%his_alarm, RC=STATUS) - _VERIFY(STATUS) + list(n)%his_alarm, _RC) end if ! CCInitialize @@ -2414,12 +2232,12 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) exportState=INTSTATE%GIM(n), & clock=CLOCK, & userRC=STATUS) + _VERIFY(STATUS) if (status == ESMF_RC_FILE_READ) then list(n)%partial = .true. STATUS = ESMF_SUCCESS call WRITE_PARALLEL("DEBUG: no cpl restart found, producing partial month") end if - _VERIFY(STATUS) end if end if end if @@ -2439,19 +2257,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) !ALT do this all the time if (list(n)%format == 'CFIO') then write(string,'(a,i3.0)') 'STREAM',n - list(n)%bundle = ESMF_FieldBundleCreate(NAME=string, RC=STATUS) - _VERIFY(STATUS) + list(n)%bundle = ESMF_FieldBundleCreate(NAME=string, _RC) if(associated(list(n)%levels)) then LM = size(list(n)%levels) else call ESMF_StateGet(INTSTATE%GIM(n), & - trim(list(n)%field_set%fields(3,1)), field, rc=status ) - _VERIFY(STATUS) - call ESMF_FieldGet(field, grid=grid, rc=status ) - _VERIFY(STATUS) - call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) + trim(list(n)%field_set%fields(3,1)), field, _RC ) + call ESMF_FieldGet(field, grid=grid, _RC ) + call MAPL_GridGet(GRID, globalCellCountPerDim=COUNTS, _RC) LM = counts(3) endif @@ -2465,28 +2279,20 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) do m=1,list(n)%field_set%nfields call ESMF_StateGet( state_out, & - trim(list(n)%field_set%fields(3,m)), field, rc=status ) - _VERIFY(STATUS) - - call MAPL_FieldBundleAdd( list(n)%bundle, field, rc=status ) - _VERIFY(STATUS) - - call ESMF_FieldGet(field, Array=array, grid=bgrid, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array, rank=rank, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array, localarrayList=larrayList, rc=status) - _VERIFY(STATUS) + trim(list(n)%field_set%fields(3,m)), field, _RC ) + + call MAPL_FieldBundleAdd( list(n)%bundle, field, _RC ) + + call ESMF_FieldGet(field, Array=array, grid=bgrid, _RC) + call ESMF_ArrayGet(array, rank=rank, _RC) + call ESMF_ArrayGet(array, localarrayList=larrayList, _RC) larray => lArrayList(1) ! alias - call ESMF_GridGet(bgrid, distgrid=bdistgrid, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(bgrid, distgrid=bdistgrid, _RC) !ALT: we need the rank of the distributed grid ! MAPL (and GEOS-5) grid are distributed along X-Y ! tilegrids are distributed only along "tile" dimension - call ESMF_DistGridGet(bdistgrid, dimCount=distRank, rc=status) - _VERIFY(STATUS) - call ESMF_LocalArrayGet(larray, totalCount=counts, rc=status) - _VERIFY(STATUS) + call ESMF_DistGridGet(bdistgrid, dimCount=distRank, _RC) + call ESMF_LocalArrayGet(larray, totalCount=counts, _RC) if(list(n)%field_set%fields(3,m)/=vvarn(n)) then nslices = 1 @@ -2522,29 +2328,19 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%format == 'CFIO') then call Get_Tdim (list(n), clock, tm) if (associated(list(n)%levels) .and. list(n)%vvars(1) /= "") then - list(n)%vdata = VerticalData(levels=list(n)%levels,vcoord=list(n)%vvars(1),vscale=list(n)%vscale,vunit=list(n)%vunit,rc=status) - _VERIFY(status) + list(n)%vdata = VerticalData(levels=list(n)%levels,vcoord=list(n)%vvars(1),vscale=list(n)%vscale,vunit=list(n)%vunit,_RC) else if (associated(list(n)%levels) .and. list(n)%vvars(1) == "") then - list(n)%vdata = VerticalData(levels=list(n)%levels,rc=status) - _VERIFY(status) + list(n)%vdata = VerticalData(levels=list(n)%levels,_RC) else - list(n)%vdata = VerticalData(positive=list(n)%positive,rc=status) - _VERIFY(status) + list(n)%vdata = VerticalData(positive=list(n)%positive,_RC) end if - call list(n)%mGriddedIO%set_param(deflation=list(n)%deflate,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(quantize_algorithm=list(n)%quantize_algorithm,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(quantize_level=list(n)%quantize_level,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(chunking=list(n)%chunkSize,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(nbits_to_keep=list(n)%nbits_to_keep,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(regrid_method=list(n)%regrid_method,rc=status) - _VERIFY(status) - call list(n)%mGriddedIO%set_param(itemOrder=intState%fileOrderAlphabetical,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%set_param(deflation=list(n)%deflate,_RC) + call list(n)%mGriddedIO%set_param(quantize_algorithm=list(n)%quantize_algorithm,_RC) + call list(n)%mGriddedIO%set_param(quantize_level=list(n)%quantize_level,_RC) + call list(n)%mGriddedIO%set_param(chunking=list(n)%chunkSize,_RC) + call list(n)%mGriddedIO%set_param(nbits_to_keep=list(n)%nbits_to_keep,_RC) + call list(n)%mGriddedIO%set_param(regrid_method=list(n)%regrid_method,_RC) + call list(n)%mGriddedIO%set_param(itemOrder=intState%fileOrderAlphabetical,_RC) if (list(n)%monthly) then nextMonth = currTime - oneMonth dur = nextMonth - currTime @@ -2554,19 +2350,15 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%timeInfo = TimeData(clock,tm,MAPL_nsecf(list(n)%frequency),IntState%stampoffset(n),integer_time=intstate%integer_time) end if if (list(n)%timeseries_output) then - list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),rc=status) - _VERIFY(status) - call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,rc=status) - _VERIFY(status) + list(n)%trajectory = HistoryTrajectory(trim(list(n)%trackfile),_RC) + call list(n)%trajectory%initialize(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,recycle_track=list(n)%recycle_track,_RC) else global_attributes = list(n)%global_atts%define_collection_attributes(_RC) if (trim(list(n)%output_grid_label)/='') then pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) - call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,ogrid=pgrid,vdata=list(n)%vdata,global_attributes=global_attributes,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,ogrid=pgrid,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) else - call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,global_attributes=global_attributes,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%CreateFileMetaData(list(n)%items,list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,global_attributes=global_attributes,_RC) end if collection_id = o_Clients%add_hist_collection(list(n)%mGriddedIO%metadata, mode = create_mode) call list(n)%mGriddedIO%set_param(write_collection_id=collection_id) @@ -2628,8 +2420,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) integer :: im_world, jm_world,dims(3) pgrid => IntState%output_grids%at(trim(list(n)%output_grid_label)) if (associated(pgrid)) then - call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,RC=status) - _VERIFY(status) + call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,_RC) print *, ' Output RSLV: ',dims(1),dims(2) end if end block @@ -2679,8 +2470,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) deallocate(stateListAvail) deallocate( statelist ) - call MAPL_GenericInitialize( gc, import, dumexport, clock, rc=status ) - _VERIFY(status) + call MAPL_GenericInitialize( gc, import, dumexport, clock, _RC ) _RETURN(ESMF_SUCCESS) @@ -2712,11 +2502,10 @@ subroutine wildCardExpand(rc) fld_set => list(n)%field_set nfields = fld_set%nfields - allocate(needSplit(nfields), regexList(nfields), stat=status) - _VERIFY(status) + allocate(needSplit(nfields), regexList(nfields), _STAT) regexList = "" - allocate(newItems, stat=status); _VERIFY(status) + allocate(newItems, _STAT) needSplit = .false. @@ -2725,15 +2514,12 @@ subroutine wildCardExpand(rc) do while(iter /= list(n)%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - expand = hasRegex(fldName=item%xname, rc=status) - _VERIFY(status) + expand = hasRegex(fldName=item%xname, _RC) if (.not.expand) call newItems%push_back(item) else if (item%itemType == ItemTypeVector) then ! Lets' not allow regex expand for vectors - expand = hasRegex(fldName=item%xname, rc=status) - _VERIFY(status) - expand = expand.or.hasRegex(fldName=item%yname, rc=status) - _VERIFY(status) + expand = hasRegex(fldName=item%xname, _RC) + expand = expand.or.hasRegex(fldName=item%yname, _RC) if (.not.expand) call newItems%push_back(item) end if @@ -2745,10 +2531,9 @@ subroutine wildCardExpand(rc) if (nregex /= 0) then nfields = nfields - nregex - allocate(newExpState(nfields), stat=status) - _VERIFY(status) - allocate(newFieldSet, stat=status); _VERIFY(status) - allocate(fields(4,nfields), stat=status); _VERIFY(status) + allocate(newExpState(nfields), _STAT) + allocate(newFieldSet, _STAT) + allocate(fields(4,nfields), _STAT) do k = 1, size(fld_set%fields,1) fields(k,:) = pack(fld_set%fields(k,:), mask=.not.needSplit) end do @@ -2766,20 +2551,17 @@ subroutine wildCardExpand(rc) expState = export(list(n)%expSTATE(k)) call MAPL_WildCardExpand(state=expState, regexStr=regexList(k), & - fieldNames=fieldNames, RC=status) - _VERIFY(STATUS) + fieldNames=fieldNames, _RC) do i=1,size(fieldNames) fldName = fieldNames(i) call appendFieldSet(newFieldSet, fldName, & stateName=stateName, & aliasName=fldName, & - specialName='', rc=status) + specialName='', _RC) - _VERIFY(status) ! append expState - call appendArray(newExpState,idx=list(n)%expState(k),rc=status) - _VERIFY(status) + call appendArray(newExpState,idx=list(n)%expState(k),_RC) item%itemType = ItemTypeScalar item%xname = trim(fldName) @@ -2866,21 +2648,16 @@ subroutine MAPL_WildCardExpand(state, regexStr, fieldNames, rc) integer :: nmatches(2, ESMF_MAXSTR) character(len=ESMF_MAXSTR), allocatable :: tmpFldNames(:) - call ESMF_StateGet(state, itemcount=nitems, rc=status) - _VERIFY(status) + call ESMF_StateGet(state, itemcount=nitems, _RC) - allocate(itemNameList(nitems), itemtypeList(nitems), stat=status) - _VERIFY(status) + allocate(itemNameList(nitems), itemtypeList(nitems), _STAT) call ESMF_StateGet(state,itemNameList=itemNameList,& - itemTypeList=itemTypeList,RC=STATUS) - _VERIFY(STATUS) + itemTypeList=itemTypeList,_RC) call regcomp(regex,trim(regexStr),'xmi',status=status) - _VERIFY(STATUS) if (.not.allocated(fieldNames)) then - allocate(fieldNames(0), stat=status) - _VERIFY(status) + allocate(fieldNames(0), _STAT) end if count = size(fieldNames) @@ -2897,8 +2674,7 @@ subroutine MAPL_WildCardExpand(state, regexStr, fieldNames, rc) count = count + 1 ! logic to grow the list - allocate(tmpFldNames(count), stat=status) - _VERIFY(status) + allocate(tmpFldNames(count), _STAT) tmpFldNames(1:count-1) = fieldNames call move_alloc(tmpFldNames, fieldNames) @@ -2941,10 +2717,9 @@ subroutine splitUngriddedFields(rc) end if fld_set => list(n)%field_set nfields = fld_set%nfields - allocate(needSplit(nfields), fldList(nfields), stat=status) - _VERIFY(status) + allocate(needSplit(nfields), fldList(nfields), _STAT) - allocate(newItems, stat=status); _VERIFY(status) + allocate(newItems, _STAT) needSplit = .false. @@ -2954,17 +2729,14 @@ subroutine splitUngriddedFields(rc) split = .false. item => iter%get() if (item%itemType == ItemTypeScalar) then - split = hasSplitableField(fldName=item%xname, rc=status) - _VERIFY(status) + split = hasSplitableField(fldName=item%xname, _RC) if (.not.split) call newItems%push_back(item) else if (item%itemType == ItemTypeVector) then ! Lets' not allow field split for vectors (at least for now); ! it is easy to implement; just tedious - split = hasSplitableField(fldName=item%xname, rc=status) - _VERIFY(status) - split = split.or.hasSplitableField(fldName=item%yname, rc=status) - _VERIFY(status) + split = hasSplitableField(fldName=item%xname, _RC) + split = split.or.hasSplitableField(fldName=item%yname, _RC) if (.not.split) call newItems%push_back(item) _ASSERT(.not. split, 'split field vectors of not allowed yet') @@ -2980,11 +2752,10 @@ subroutine splitUngriddedFields(rc) if (nsplit /= 0) then nfields = nfields - nsplit - allocate(newExpState(nfields), stat=status) - _VERIFY(status) + allocate(newExpState(nfields), _STAT) - allocate(newFieldSet, stat=status); _VERIFY(status) - allocate(fields(4,nfields), stat=status); _VERIFY(status) + allocate(newFieldSet, _STAT) + allocate(fields(4,nfields), _STAT) do k = 1, size(fld_set%fields,1) ! 4 fields(k,:) = pack(fld_set%fields(k,:), mask=.not.needSplit) end do @@ -3001,27 +2772,23 @@ subroutine splitUngriddedFields(rc) stateName = fld_set%fields(2,k) aliasName = fld_set%fields(3,k) - call MAPL_FieldSplit(fldList(k), splitFields, aliasName=aliasName, RC=status) - _VERIFY(STATUS) + call MAPL_FieldSplit(fldList(k), splitFields, aliasName=aliasName, _RC) expState = export(list(n)%expSTATE(k)) do i=1,size(splitFields) call ESMF_FieldGet(splitFields(i), name=fldName, & - rc=status) - _VERIFY(status) + _RC) alias = fldName call appendFieldSet(newFieldSet, fldName, & stateName=stateName, & aliasName=alias, & - specialName='', rc=status) + specialName='', _RC) - _VERIFY(status) ! append expState - call appendArray(newExpState,idx=list(n)%expState(k),rc=status) - _VERIFY(status) + call appendArray(newExpState,idx=list(n)%expState(k),_RC) item%itemType = ItemTypeScalar item%xname = trim(alias) @@ -3104,16 +2871,13 @@ function hasSplitField(fld, rc) result(okToSplit) okToSplit = .false. fldRank = 0 - call ESMF_FieldGet(fld, status=fieldStatus, rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(fld, status=fieldStatus, _RC) if (fieldStatus /= ESMF_FIELDSTATUS_COMPLETE) then - call MAPL_AllocateCoupling(fld, rc=status) - _VERIFY(STATUS) + call MAPL_AllocateCoupling(fld, _RC) end if - call ESMF_FieldGet(fld,dimCount=fldRank,rc=status) - _VERIFY(status) + call ESMF_FieldGet(fld,dimCount=fldRank,_RC) _ASSERT(fldRank < 5, "unsupported rank") @@ -3121,12 +2885,10 @@ function hasSplitField(fld, rc) result(okToSplit) okToSplit = .true. else if (fldRank == 3) then ! split ONLY if X and Y are "gridded" and Z is "ungridded" - call ESMF_AttributeGet(fld, name='DIMS', value=dims, rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(fld, name='DIMS', value=dims, _RC) if (dims == MAPL_DimsHorzOnly) then call ESMF_AttributeGet(fld, name='UNGRIDDED_DIMS', & - isPresent=has_ungrd, rc=status) - _VERIFY(STATUS) + isPresent=has_ungrd, _RC) if (has_ungrd) then okToSplit = .true. end if @@ -3154,7 +2916,7 @@ subroutine appendArray(array, idx, rc) k = size(array) n = k + 1 - allocate(tmp(n), stat=status) ; _VERIFY(status) + allocate(tmp(n), _STAT) tmp(1:k) = array tmp(n) = idx @@ -3185,15 +2947,14 @@ subroutine appendFieldSet(fldset, fldName, stateName, aliasName, specialName, rc _ASSERT(mm == 4, 'wrong size for fields') k = size(fldset%fields, 2) nn = k + 1 - allocate(flds(mm,nn), stat=status) ; _VERIFY(status) + allocate(flds(mm,nn), _STAT) flds(:,1:k) = fldset%fields flds(1,nn) = fldName flds(2,nn) = stateName flds(3,nn) = aliasName flds(4,nn) = specialName - deallocate( fldSet%fields, stat=status ) - _VERIFY(STATUS) + deallocate( fldSet%fields, _STAT ) fldset%fields => flds fldSet%nfields = nn @@ -3242,8 +3003,7 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) else usable_collection_name = "unknown" end if - call ESMF_ConfigFindLabel ( cfg, label=label//':', rc=status) - _VERIFY(status) + call ESMF_ConfigFindLabel ( cfg, label=label//':', _RC) table_end = .false. m = 0 @@ -3262,16 +3022,13 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) print * endif endif - _VERIFY(STATUS) export_name = extract_unquoted_item(export_name) ! Get GC Name ! ------------ - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=component_name,rc=STATUS) - _VERIFY(STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=component_name,_RC) else component_name = tmpstring endif @@ -3280,9 +3037,9 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) ! Get Possible ALIAS Name ! ----------------------- - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=export_alias,default=export_name,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=export_alias,default=export_name,_RC) else if( trim(tmpstring) /= ' ' ) then export_alias = tmpstring @@ -3298,9 +3055,9 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) ! Get Possible COUPLER Function ! ----------------------------- - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=coupler_function_name,default=BLANK,rc=STATUS) + call ESMF_ConfigGetAttribute ( cfg,value=coupler_function_name,default=BLANK,_RC) else if( trim(tmpstring) /= ' ' ) then coupler_function_name = tmpstring @@ -3310,12 +3067,10 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) endif coupler_function_name = extract_unquoted_item(coupler_function_name) ! convert to uppercase - tmpstring = ESMF_UtilStringUpperCase(coupler_function_name,rc=status) - _VERIFY(status) + tmpstring = ESMF_UtilStringUpperCase(coupler_function_name,_RC) ! ------------- - call ESMF_ConfigNextLine ( cfg,tableEnd=table_end,rc=STATUS ) - _VERIFY(STATUS) + call ESMF_ConfigNextLine ( cfg,tableEnd=table_end,_RC ) vectorDone=.false. idx = index(export_name,";") @@ -3326,8 +3081,7 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) item%itemType = ItemTypeVector end if VECTORPAIR: do while(.not.vectorDone) - allocate( fields(4,m), stat=status ) - _VERIFY(STATUS) + allocate( fields(4,m), _STAT ) idx = index(export_name,";") if (idx == 0) then @@ -3357,8 +3111,7 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) fields(4,m) = coupler_function_name deallocate (field_set%fields) endif - allocate( field_set%fields(4,m), stat=status) - _VERIFY(STATUS) + allocate( field_set%fields(4,m), _STAT) field_set%fields = fields deallocate (fields) if (.not.vectorDone) then @@ -3450,7 +3203,6 @@ subroutine Run ( gc, import, export, clock, rc ) !---------------------------------- call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr ! the collections @@ -3462,14 +3214,12 @@ subroutine Run ( gc, import, export, clock, rc ) ! Retrieve the pointer to the generic state !------------------------------------------ - call MAPL_GetObjectFromGC ( gc, GENSTATE, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GetObjectFromGC ( gc, GENSTATE, _RC) ! Get clocks' direction FWD = .not. ESMF_ClockIsReverse(clock) - allocate(Ignore (nlist), stat=status) - _VERIFY(STATUS) + allocate(Ignore (nlist), _STAT) Ignore = .false. ! decide if clock direction and collections' backwards mode agree @@ -3485,13 +3235,11 @@ subroutine Run ( gc, import, export, clock, rc ) call MAPL_TimerOn(GENSTATE,"-ParserRun") if( (.not.list(n)%disabled .and. IntState%average(n)) ) then call MAPL_RunExpression(IntState%CIM(n),list(n)%field_set%fields,list(n)%tmpfields, & - list(n)%ReWrite,list(n)%field_set%nfields,RC=STATUS) - _VERIFY(STATUS) + list(n)%ReWrite,list(n)%field_set%nfields,_RC) end if if( (.not.list(n)%disabled) .and. (.not.IntState%average(n)) ) then call MAPL_RunExpression(IntState%GIM(n),list(n)%field_set%fields,list(n)%tmpfields, & - list(n)%ReWrite,list(n)%field_set%nfields,RC=STATUS) - _VERIFY(STATUS) + list(n)%ReWrite,list(n)%field_set%nfields,_RC) end if call MAPL_TimerOff(GENSTATE,"-ParserRun") endif @@ -3504,8 +3252,7 @@ subroutine Run ( gc, import, export, clock, rc ) !@ do n=1,nlist !@ do m=1,list(n)%field_set%nfields !@ if (list(n)%r8_to_r4(m)) then -!@ call MAPL_FieldCopy(from=list(n)%r8(m), to=list(n)%r4(m), rc=status) -!@ _VERIFY(status) +!@ call MAPL_FieldCopy(from=list(n)%r8(m), to=list(n)%r4(m), _RC) !@ end if !@ end do !@ end do @@ -3521,8 +3268,7 @@ subroutine Run ( gc, import, export, clock, rc ) do m=1,list(n)%field_set%nfields if (list(n)%r8_to_r4(m)) then call MAPL_FieldCopy(from=list(n)%r8(m), & - to=list(n)%r4(m), rc=status) - _VERIFY(status) + to=list(n)%r4(m), _RC) end if end do @@ -3530,7 +3276,7 @@ subroutine Run ( gc, import, export, clock, rc ) importState=INTSTATE%CIM(n), & exportState=INTSTATE%GIM(n), & clock=CLOCK, & - userRC=STATUS) + userRC) _VERIFY(STATUS) end if end do @@ -3539,10 +3285,8 @@ subroutine Run ( gc, import, export, clock, rc ) ! Check for History Output ! ------------------------ - allocate(Writing (nlist), stat=status) - _VERIFY(STATUS) - allocate(filename(nlist), stat=status) - _VERIFY(STATUS) + allocate(Writing (nlist), _STAT) + allocate(filename(nlist), _STAT) allocate(NewSeg (nlist), __STAT__) newSeg = .false. @@ -3559,20 +3303,17 @@ subroutine Run ( gc, import, export, clock, rc ) endif ! if(Writing(n)) then -! call ESMF_AlarmRingerOff( list(n)%his_alarm,rc=status ) -! _VERIFY(STATUS) +! call ESMF_AlarmRingerOff( list(n)%his_alarm,_RC ) ! end if if (Ignore(n)) then ! "Exersise" the alarms and then do nothing Writing(n) = .false. ! if (ESMF_AlarmIsRinging ( list(n)%his_alarm )) then -! call ESMF_AlarmRingerOff( list(n)%his_alarm,rc=status ) -! _VERIFY(STATUS) +! call ESMF_AlarmRingerOff( list(n)%his_alarm,_RC ) ! end if if (ESMF_AlarmIsRinging ( list(n)%seg_alarm )) then - call ESMF_AlarmRingerOff( list(n)%seg_alarm,rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOff( list(n)%seg_alarm,_RC ) end if end if @@ -3581,8 +3322,7 @@ subroutine Run ( gc, import, export, clock, rc ) do m=1,list(n)%field_set%nfields if (list(n)%r8_to_r4(m)) then call MAPL_FieldCopy(from=list(n)%r8(m), & - to=list(n)%r4(m), rc=status) - _VERIFY(status) + to=list(n)%r4(m), _RC) end if end do end if @@ -3593,8 +3333,7 @@ subroutine Run ( gc, import, export, clock, rc ) NewSeg(n) = ESMF_AlarmIsRinging ( list(n)%seg_alarm ) if( NewSeg(n)) then - call ESMF_AlarmRingerOff( list(n)%seg_alarm,rc=status ) - _VERIFY(STATUS) + call ESMF_AlarmRingerOff( list(n)%seg_alarm,_RC ) endif end do @@ -3615,8 +3354,7 @@ subroutine Run ( gc, import, export, clock, rc ) call get_DateStamp ( clock, DateStamp=DateStamp, & OFFSET = INTSTATE%STAMPOFFSET(n), & - rc=status ) - _VERIFY(STATUS) + _RC ) if (trim(INTSTATE%expid) == "") then fntmpl = trim(list(n)%filename) @@ -3633,8 +3371,7 @@ subroutine Run ( gc, import, export, clock, rc ) call fill_grads_template ( filename(n), fntmpl, & experiment_id=trim(INTSTATE%expid), & - nymd=nymd, nhms=nhms, rc=status ) ! here is where we get the actual filename of file we will write - _VERIFY(STATUS) + nymd=nymd, nhms=nhms, _RC ) ! here is where we get the actual filename of file we will write if(list(n)%monthly .and. list(n)%partial) then filename(n)=trim(filename(n)) // '-partial' @@ -3649,8 +3386,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! instead we compute the differece between ! thisMonth and lastMonth and as a new timeInterval - call ESMF_ClockGet(clock,currTime=current_time,rc=status) - _VERIFY(status) + call ESMF_ClockGet(clock,currTime=current_time,_RC) call ESMF_TimeIntervalSet( oneMonth, MM=1, _RC) lastMonth = current_time - oneMonth dur = current_time - lastMonth @@ -3662,10 +3398,8 @@ subroutine Run ( gc, import, export, clock, rc ) if (list(n)%timeseries_output) then if (list(n)%unit.eq.0) then if (mapl_am_i_root()) write(6,*)"Sampling to new file: ",trim(filename(n)) - call list(n)%trajectory%close_file_handle(rc=status) - _VERIFY(status) - call list(n)%trajectory%create_file_handle(filename(n),rc=status) - _VERIFY(status) + call list(n)%trajectory%close_file_handle(_RC) + call list(n)%trajectory%create_file_handle(filename(n),_RC) list(n)%currentFile = filename(n) list(n)%unit = -1 end if @@ -3677,8 +3411,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 - call list(n)%mGriddedIO%modifyTime(oClients=o_Clients,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%modifyTime(oClients=o_Clients,_RC) list(n)%currentFile = filename(n) list(n)%unit = -1 else @@ -3718,7 +3451,7 @@ subroutine Run ( gc, import, export, clock, rc ) IntState%Regrid(n)%PTR%LocNative, & IntState%Regrid(n)%PTR%ntiles_in, & IntState%Regrid(n)%PTR%ntiles_out,& - rc=status) + _RC) else call RegridTransform(IntState%GIM(n), & IntState%Regrid(n)%PTR%xform, & @@ -3727,7 +3460,7 @@ subroutine Run ( gc, import, export, clock, rc ) IntState%Regrid(n)%PTR%LocOut, & IntState%Regrid(n)%PTR%ntiles_in, & IntState%Regrid(n)%PTR%ntiles_out,& - rc=status) + _RC) end if else if (IntState%Regrid(n)%PTR%noxform) then @@ -3735,17 +3468,16 @@ subroutine Run ( gc, import, export, clock, rc ) STATE_OUT=state_out, & LS_OUT=IntState%Regrid(n)%PTR%LocOut, & NTILES_OUT=IntState%Regrid(n)%PTR%ntiles_out, & - rc=status) + _RC) else call RegridTransformT2G(STATE_IN=IntState%GIM(n), & XFORM=IntState%Regrid(n)%PTR%xform, & STATE_OUT=state_out, & LS_OUT=IntState%Regrid(n)%PTR%LocOut, & NTILES_OUT=IntState%Regrid(n)%PTR%ntiles_out, & - rc=status) + _RC) end if end if - _VERIFY(STATUS) else state_out = INTSTATE%GIM(n) end if @@ -3753,8 +3485,7 @@ subroutine Run ( gc, import, export, clock, rc ) if (.not.list(n)%timeseries_output) then IOTYPE: if (list(n)%unit < 0) then ! CFIO - call list(n)%mGriddedIO%bundlepost(list(n)%currentFile,oClients=o_Clients,rc=status) - _VERIFY(status) + call list(n)%mGriddedIO%bundlepost(list(n)%currentFile,oClients=o_Clients,_RC) else @@ -3765,14 +3496,12 @@ subroutine Run ( gc, import, export, clock, rc ) INTSTATE%LCTL(n) = .false. endif - call shavebits(state_out, list(n), rc=status) - _VERIFY(STATUS) + call shavebits(state_out, list(n), _RC) do m=1,list(n)%field_set%nfields call MAPL_VarWrite ( list(n)%unit, STATE=state_out, & NAME=trim(list(n)%field_set%fields(3,m)), & - forceWriteNoRestart=.true., rc=status ) - _VERIFY(STATUS) + forceWriteNoRestart=.true., _RC ) enddo call WRITE_PARALLEL("Wrote GrADS Output for File: "//trim(filename(n))) @@ -3818,10 +3547,8 @@ subroutine Run ( gc, import, export, clock, rc ) WRITELOOP: do n=1,nlist if (list(n)%timeseries_output) then - call ESMF_ClockGet(clock,currTime=current_time,rc=status) - _VERIFY(status) - call list(n)%trajectory%append_file(current_time,rc=status) - _VERIFY(status) + call ESMF_ClockGet(clock,currTime=current_time,_RC) + call list(n)%trajectory%append_file(current_time,_RC) end if if( Writing(n) .and. list(n)%unit < 0) then @@ -3872,13 +3599,11 @@ subroutine Finalize ( gc, import, export, clock, rc ) ! Begin... - call MAPL_GetObjectFromGC ( gc, GENSTATE, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GetObjectFromGC ( gc, GENSTATE, _RC) ! Retrieve the pointer to the state call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr list => IntState%list nlist = size(list) @@ -3891,8 +3616,7 @@ subroutine Finalize ( gc, import, export, clock, rc ) if (list(n)%disabled) cycle IF (list(n)%format == 'CFIO') then if( MAPL_CFIOIsCreated(list(n)%mcfio) ) then - CALL MAPL_CFIOdestroy (list(n)%mcfio, rc=STATUS) - _VERIFY(STATUS) + CALL MAPL_CFIOdestroy (list(n)%mcfio, _RC) end if ELSE if( list(n)%unit.ne.0 ) call FREE_FILE( list(n)%unit ) @@ -3915,17 +3639,14 @@ subroutine Finalize ( gc, import, export, clock, rc ) #if 0 do n=1,nlist IF (IntState%average(n)) then - call MAPL_StateDestroy(IntState%gim(n), rc=status) - _VERIFY(STATUS) - call MAPL_StateDestroy(IntState%cim(n), rc=status) - _VERIFY(STATUS) + call MAPL_StateDestroy(IntState%gim(n), _RC) + call MAPL_StateDestroy(IntState%cim(n), _RC) end IF enddo #endif - call MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, RC=status ) - _VERIFY(STATUS) + call MAPL_GenericFinalize ( GC, IMPORT, EXPORT, CLOCK, _RC ) _RETURN(ESMF_SUCCESS) @@ -3985,12 +3706,12 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid 'DTDT' , 'PHYSICS' , & 'DTDT' , 'GWD' / - call ESMF_ClockGet ( clock, currTime=CurrTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, StopTime=StopTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, StartTime=StartTime, rc=STATUS ) ; _VERIFY(STATUS) - call ESMF_ClockGet ( clock, Calendar=cal, rc=STATUS ) ; _VERIFY(STATUS) + call ESMF_ClockGet ( clock, currTime=CurrTime, _RC ) + call ESMF_ClockGet ( clock, StopTime=StopTime, _RC ) + call ESMF_ClockGet ( clock, StartTime=StartTime, _RC ) + call ESMF_ClockGet ( clock, Calendar=cal, _RC ) - call ESMF_TimeGet ( CurrTime, timeString=TimeString, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeGet ( CurrTime, timeString=TimeString, _RC ) read(timestring( 1: 4),'(i4.4)') year read(timestring( 6: 7),'(i2.2)') month @@ -4000,7 +3721,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid ti = StopTime-CurrTime freq = MAPL_nsecf( list%frequency ) - call ESMF_TimeIntervalSet( Frequency, S=freq, StartTime=StartTime, rc=status ) ; _VERIFY(STATUS) + call ESMF_TimeIntervalSet( Frequency, S=freq, StartTime=StartTime, _RC ) nsteps = ti/Frequency + 1 @@ -4021,13 +3742,10 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid ! Get Global Horizontal Dimensions ! -------------------------------- - call ESMF_StateGet ( state,trim(list%field_set%fields(3,1)),field,rc=status ) - _VERIFY(STATUS) - call ESMF_FieldGet ( field, grid=grid, rc=status ) - _VERIFY(STATUS) + call ESMF_StateGet ( state,trim(list%field_set%fields(3,1)),field,_RC ) + call ESMF_FieldGet ( field, grid=grid, _RC ) - call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) - _VERIFY(STATUS) + call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, _RC) ZERO = 0 IM = DIMS(1) @@ -4035,8 +3753,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid LM = DIMS(3) if (LM == 0) LM = 1 ! needed for tilegrids - call ESMF_GridGet(grid, name=gridname, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid, name=gridname, _RC) if (gridname(1:10) == 'tile_grid_') then DLON = 1.0 @@ -4060,15 +3777,13 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid Name = "Latitude" , & Location = ESMF_STAGGERLOC_CENTER , & Units = MAPL_UnitsRadians , & - RC = STATUS ) - _VERIFY(STATUS) + _RC) call ESMFL_GridCoordGet( GRID, LONS , & Name = "Longitude" , & Location = ESMF_STAGGERLOC_CENTER , & Units = MAPL_UnitsRadians , & - RC = STATUS ) - _VERIFY(STATUS) + _RC) !ALT: Note: the LATS(1,1) and LONS(1,1) are correct ONLY on root if( MAPL_AM_I_ROOT() ) then @@ -4090,8 +3805,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid integer :: dims(3) pgrid => output_grids%at(trim(list%output_grid_label)) if (associated(pgrid)) then - call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,RC=status) - _VERIFY(status) + call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,_RC) IM = dims(1) JM = dims(2) DLON = 360._REAL64/float(IM) @@ -4108,18 +3822,14 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid ! Compute Vertical Dimension for each Field (Augment nfield for VDIMS > LM) ! ------------------------------------------------------------------------- - allocate( vdim(list%field_set%nfields), stat=status ) - _VERIFY(STATUS) + allocate( vdim(list%field_set%nfields), _STAT ) vdim = 0 nfield = list%field_set%nfields do m = 1,list%field_set%nfields call ESMFL_StateGetFieldArray( state,trim(list%field_set%fields(3,m)),array,status ) - _VERIFY(STATUS) - call ESMF_ArrayGet( array, localarrayList=larrayList, rc=status ) - _VERIFY(STATUS) + call ESMF_ArrayGet( array, localarrayList=larrayList, _RC ) call ESMF_LocalArrayGet( larrayList(1), RANK=rank, totalLBound=lbounds, & - totalUBound=ubounds, rc=status ) - _VERIFY(STATUS) + totalUBound=ubounds, _RC ) if( rank==3 ) then vdim(m) = ubounds(3)-lbounds(3)+1 if( vdim(m).gt.LM ) nfield = nfield+1 @@ -4246,17 +3956,14 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) equivalence ( string(15),minute ) equivalence ( string(18),second ) - call ESMF_ClockGet ( clock, name=clockname, currTime=currentTime, rc=status) - _VERIFY(STATUS) + call ESMF_ClockGet ( clock, name=clockname, currTime=currentTime, _RC) if (present(offset)) then - call ESMF_TimeIntervalGet( OFFSET, S=noffset, rc=status ) - _VERIFY(STATUS) + call ESMF_TimeIntervalGet( OFFSET, S=noffset, _RC ) if( noffset /= 0 ) then LPERP = ( index( trim(clockname),'_PERPETUAL' ).ne.0 ) if( LPERP ) then - call ESMF_ClockGetAlarm ( clock, AlarmName='PERPETUAL', alarm=PERPETUAL, rc=status ) - _VERIFY(STATUS) + call ESMF_ClockGetAlarm ( clock, AlarmName='PERPETUAL', alarm=PERPETUAL, _RC ) if( ESMF_AlarmIsRinging(PERPETUAL) ) then ! ! Month has already been set back to PERPETUAL Month, therefore @@ -4267,14 +3974,14 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) DD = DD, & H = H , & M = M , & - S = S, rc=status ) + S = S, _RC ) MM = MM + 1 call ESMF_TimeSet ( CurrentTime, YY = YY, & MM = MM, & DD = DD, & H = H , & M = M , & - S = S, rc=status ) + S = S, _RC ) #ifdef DEBUG if( MAPL_AM_I_ROOT() ) write(6,"(a,2x,i4.4,'/',i2.2,'/',i2.2,2x,'Time: ',i2.2,':',i2.2,':',i2.2)") "Inside HIST GetDate: ",YY,MM,DD,H,M,S #endif @@ -4284,8 +3991,7 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) currentTime = currentTime - offset end if - call ESMF_TimeGet (currentTime, timeString=TimeString, rc=status) - _VERIFY(STATUS) + call ESMF_TimeGet (currentTime, timeString=TimeString, _RC) if(present(DateStamp)) then DateStamp = year//month//day//'_'//hour//minute//second //'z' @@ -4321,57 +4027,41 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, type (ESMF_StateItem_Flag), pointer :: ITEMTYPES_IN(:), ITEMTYPES_OUT(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES_IN(:), ITEMNAMES_OUT(:) - allocate(tile_in (ntiles_in ), stat=status) - _VERIFY(STATUS) - allocate(tile_out(ntiles_out), stat=status) - _VERIFY(STATUS) + allocate(tile_in (ntiles_in ), _STAT) + allocate(tile_out(ntiles_out), _STAT) - call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, RC=STATUS) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, _RC) + call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, _RC) _ASSERT(ITEMCOUNT_IN == ITEMCOUNT_OUT,'needs informative message') ITEMCOUNT = ITEMCOUNT_IN _ASSERT(ITEMCOUNT>0,'needs informative message') - allocate(ITEMNAMES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_IN(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_IN(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_IN, ITEMNAMELIST=ITEMNAMES_IN, & - ITEMTYPELIST=ITEMTYPES_IN, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_IN, _RC) - allocate(ITEMNAMES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_OUT(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_OUT(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_OUT, ITEMNAMELIST=ITEMNAMES_OUT, & - ITEMTYPELIST=ITEMTYPES_OUT, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_OUT, _RC) DO I=1, ITEMCOUNT _ASSERT(ITEMTYPES_IN (I) == ESMF_StateItem_Field,'needs informative message') _ASSERT(ITEMTYPES_OUT(I) == ESMF_StateItem_Field,'needs informative message') - call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_in , rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_out, rc=status) - _VERIFY(STATUS) - - call ESMF_ArrayGet(array_in , rank=rank_in , rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, rank=rank_out, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, _RC) + call ESMF_FieldGet(field, Array=array_in , _RC) + call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, _RC) + call ESMF_FieldGet(field, Array=array_out, _RC) + + call ESMF_ArrayGet(array_in , rank=rank_in , _RC) + call ESMF_ArrayGet(array_out, rank=rank_out, _RC) _ASSERT(rank_in == rank_out,'needs informative message') _ASSERT(rank_in >=2, 'Rank is less than 2') _ASSERT(rank_in <= 3,'Rank is greater than 3') @@ -4380,15 +4070,11 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, LM = 1 LL = 1 LU = 1 - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , _RC) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, _RC) else - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , _RC) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, _RC) LM = size(ptr3d_in,3) LL = lbound(ptr3d_in,3) LU = ubound(ptr3d_in,3) @@ -4403,14 +4089,11 @@ subroutine RegridTransform(STATE_IN, XFORM, STATE_OUT, LS_IN, LS_OUT, NTILES_IN, ptr2d_out => ptr3d_out(:,:,L) end if - call MAPL_LocStreamTransform(LS_IN, TILE_IN, PTR2d_IN, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_IN, TILE_IN, PTR2d_IN, _RC) - call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, _RC ) - call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, _RC) ENDDO @@ -4467,69 +4150,48 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ type (ESMF_StateItem_Flag), pointer :: ITEMTYPES_IN(:), ITEMTYPES_OUT(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES_IN(:), ITEMNAMES_OUT(:) - allocate(tt_in (ntiles_in ), stat=status) - _VERIFY(STATUS) - allocate(tile_out(ntiles_out), stat=status) - _VERIFY(STATUS) + allocate(tt_in (ntiles_in ), _STAT) + allocate(tile_out(ntiles_out), _STAT) - call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, RC=STATUS) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, _RC) + call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, _RC) _ASSERT(ITEMCOUNT_IN == ITEMCOUNT_OUT,'needs informative message') ITEMCOUNT = ITEMCOUNT_IN _ASSERT(ITEMCOUNT>0,'needs informative message') - allocate(ITEMNAMES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_IN(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_IN(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_IN, ITEMNAMELIST=ITEMNAMES_IN, & - ITEMTYPELIST=ITEMTYPES_IN, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_IN, _RC) - allocate(ITEMNAMES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_OUT(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_OUT(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_OUT, ITEMNAMELIST=ITEMNAMES_OUT, & - ITEMTYPELIST=ITEMTYPES_OUT, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_OUT, _RC) - call MAPL_LocStreamGet(LS_NTV, ATTACHEDGRID=GRID, RC=STATUS) - _VERIFY(STATUS) - call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, RC=STATUS) - _VERIFY(STATUS) - allocate(G2d_in(COUNTS(1),COUNTS(2)), stat=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(LS_NTV, ATTACHEDGRID=GRID, _RC) + call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, _RC) + allocate(G2d_in(COUNTS(1),COUNTS(2)), _STAT) - call MAPL_LocStreamGet(LS_ntv, NT_LOCAL = sizett, rc=status) - _VERIFY(STATUS) - allocate(tt(sizett), stat=status) - _VERIFY(STATUS) + call MAPL_LocStreamGet(LS_ntv, NT_LOCAL = sizett, _RC) + allocate(tt(sizett), _STAT) DO I=1, ITEMCOUNT _ASSERT(ITEMTYPES_IN (I) == ESMF_StateItem_Field,'needs informative message') _ASSERT(ITEMTYPES_OUT(I) == ESMF_StateItem_Field,'needs informative message') - call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_in , rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_out, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, _RC) + call ESMF_FieldGet(field, Array=array_in , _RC) + call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, _RC) + call ESMF_FieldGet(field, Array=array_out, _RC) - call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, rank=rank_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, _RC) + call ESMF_ArrayGet(array_out, rank=rank_out, _RC) _ASSERT(rank_in+1 == rank_out,'needs informative message') _ASSERT(rank_in >=1, 'Rank is less than 1') @@ -4538,55 +4200,43 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ KM = 1 if (rank_in == 1) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , _RC) tile_in => ptr1d_in else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p1dr8_in)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p1dr8_in)), _STAT) end if tile1d = p1dr8_in tile_in => tile1d end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, _RC) out2d => ptr2d_out LM = 1 else if (rank_in == 2) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p2dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p2dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, _RC) LM = size(ptr3d_out,3) else if (rank_in == 3) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p3dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p3dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, _RC) LM = size(ptr4d_out,3) KM = size(ptr4d_out,4) else @@ -4614,21 +4264,16 @@ subroutine RegridTransformT2G2G(STATE_IN, XFORM, XFORMntv, STATE_OUT, LS_IN, LS_ end if ! T2T - call MAPL_LocStreamTransform( tt, XFORMntv, tile_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tt, XFORMntv, tile_in, _RC ) ! T2G - call MAPL_LocStreamTransform(LS_NTV, G2d_IN, tt, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_NTV, G2d_IN, tt, _RC) ! G2T - call MAPL_LocStreamTransform(LS_IN, TT_IN, G2d_IN, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_IN, TT_IN, G2d_IN, _RC) ! T2T - call MAPL_LocStreamTransform( tile_out, XFORM, tt_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tile_out, XFORM, tt_in, _RC ) ! T2G - call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_OUT, PTR2d_OUT, TILE_OUT, _RC) ENDDO END DO @@ -4682,109 +4327,82 @@ subroutine RegridTransformT2G(STATE_IN, XFORM, STATE_OUT, LS_OUT, NTILES_OUT, RC character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES_IN(:), ITEMNAMES_OUT(:) if (present(XFORM)) then - allocate(tile_out(ntiles_out), stat=status) - _VERIFY(STATUS) + allocate(tile_out(ntiles_out), _STAT) end if - call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, RC=STATUS) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN, ITEMCOUNT=ITEMCOUNT_IN, _RC) + call ESMF_StateGet(STATE_OUT, ITEMCOUNT=ITEMCOUNT_OUT, _RC) _ASSERT(ITEMCOUNT_IN == ITEMCOUNT_OUT,'needs informative message') ITEMCOUNT = ITEMCOUNT_IN _ASSERT(ITEMCOUNT>0,'needs informative message') - allocate(ITEMNAMES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_IN(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_IN(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_IN(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_IN, ITEMNAMELIST=ITEMNAMES_IN, & - ITEMTYPELIST=ITEMTYPES_IN, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_IN, _RC) - allocate(ITEMNAMES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) - allocate(ITEMTYPES_OUT(ITEMCOUNT),STAT=STATUS) - _VERIFY(STATUS) + allocate(ITEMNAMES_OUT(ITEMCOUNT),_STAT) + allocate(ITEMTYPES_OUT(ITEMCOUNT),_STAT) call ESMF_StateGet(STATE_OUT, ITEMNAMELIST=ITEMNAMES_OUT, & - ITEMTYPELIST=ITEMTYPES_OUT, RC=STATUS) - _VERIFY(STATUS) + ITEMTYPELIST=ITEMTYPES_OUT, _RC) DO I=1, ITEMCOUNT _ASSERT(ITEMTYPES_IN (I) == ESMF_StateItem_Field,'needs informative message') _ASSERT(ITEMTYPES_OUT(I) == ESMF_StateItem_Field,'needs informative message') - call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_in , rc=status) - _VERIFY(STATUS) - call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, rc=status) - _VERIFY(STATUS) - call ESMF_FieldGet(field, Array=array_out, rc=status) - _VERIFY(STATUS) - - call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, rc=status) - _VERIFY(STATUS) - call ESMF_ArrayGet(array_out, rank=rank_out, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(STATE_IN , ITEMNAMES_IN (i), field, _RC) + call ESMF_FieldGet(field, Array=array_in , _RC) + call ESMF_StateGet(STATE_OUT, ITEMNAMES_OUT(i), field, _RC) + call ESMF_FieldGet(field, Array=array_out, _RC) + + call ESMF_ArrayGet(array_in , rank=rank_in , typekind=tk, _RC) + call ESMF_ArrayGet(array_out, rank=rank_out, _RC) _ASSERT(rank_out == rank_in + 1,'needs informative message') KM = 1 if (rank_in == 1) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr1d_in , _RC) tile_in => ptr1d_in else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p1dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p1dr8_in)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p1dr8_in)), _STAT) end if tile1d = p1dr8_in tile_in => tile1d end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr2d_out, _RC) out2d => ptr2d_out LM = 1 else if (rank_in == 2) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr2d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p2dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p2dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p2dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr3d_out, _RC) LM = size(ptr3d_out,3) else if (rank_in == 3) then if (tk == ESMF_TypeKind_R4) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=ptr3d_in , _RC) else if (tk == ESMF_TypeKind_R8) then - call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_in , localDE=0, farrayptr=p3dr8_in , _RC) if (.not. associated(tile1d)) then - allocate(tile1d(size(p3dr8_in,1)), stat=status) - _VERIFY(STATUS) + allocate(tile1d(size(p3dr8_in,1)), _STAT) end if end if - call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, rc=status) - _VERIFY(STATUS) + call ESMF_ArrayGet(array_out, localDE=0, farrayptr=ptr4d_out, _RC) LM = size(ptr4d_out,3) KM = size(ptr4d_out,4) else @@ -4812,14 +4430,12 @@ subroutine RegridTransformT2G(STATE_IN, XFORM, STATE_OUT, LS_OUT, NTILES_OUT, RC end if if (present(XFORM)) then - call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, RC=STATUS ) - _VERIFY(STATUS) + call MAPL_LocStreamTransform( tile_out, XFORM, tile_in, _RC ) else tile_out => tile_in endif - call MAPL_LocStreamTransform(LS_OUT, OUT2d, TILE_OUT, RC=STATUS) - _VERIFY(STATUS) + call MAPL_LocStreamTransform(LS_OUT, OUT2d, TILE_OUT, _RC) END DO END DO @@ -4961,8 +4577,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ! rather than the actual output field variables (i.e., fields(1,:)). ! Also do check that there are no illegal operations !------------------------------------------------------------------- - allocate ( exptmp (1), stat=status ) - _VERIFY(STATUS) + allocate ( exptmp (1), _STAT ) exptmp(1) = ExpState ! check which fields are actual exports or expressions nPExtraFields = 0 @@ -4970,8 +4585,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & allocate(isBundle(nfield)) do m=1,nfield - call MAPL_ExportStateGet(exptmp,fields(2,m),state,rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet(exptmp,fields(2,m),state,_RC) if (index(fields(1,m),'%') == 0) then call checkIfStateHasField(state, fields(1,m), hasField, _RC) if (hasField) then @@ -4993,10 +4607,8 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & enddo ! now that we know this allocated a place to store the names of the real fields - allocate(VarNames(iRealFields),stat=status) - _VERIFY(STATUS) - allocate(VarNeeded(iRealFields),stat=status) - _VERIFY(STATUS) + allocate(VarNames(iRealFields),_STAT) + allocate(VarNeeded(iRealFields),_STAT) k=0 do m=1,nfield if ( (rewrite(m) .eqv. .False.) .and. (isBundle(m) .eqv. .False.) ) then @@ -5013,8 +4625,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & if (rewrite(m)) then ExtVars = "" - call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,rc=status) - _VERIFY(STATUS) + call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,_RC) tmpList=ExtVars do i=1,len_trim(tmpList) @@ -5039,8 +4650,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & if (rewrite(m)) then ExtVars = "" - call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,rc=status) - _VERIFY(STATUS) + call CheckSyntax(tmpfields(m),VarNames,VarNeeded,ExtVar=ExtVars,_RC) tmpList=ExtVars do i=1,len_trim(tmpList) @@ -5079,16 +4689,11 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & end do totFields = iRealFields + nUniqueExtraFields - allocate(TotVarNames(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotCmpNames(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotAliasNames(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotRank(totFields),stat=status) - _VERIFY(STATUS) - allocate(TotLoc(totFields),stat=status) - _VERIFY(STATUS) + allocate(TotVarNames(totFields),_STAT) + allocate(TotCmpNames(totFields),_STAT) + allocate(TotAliasNames(totFields),_STAT) + allocate(TotRank(totFields),_STAT) + allocate(TotLoc(totFields),_STAT) iRealFields = 0 do i=1,nfield @@ -5098,15 +4703,11 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & TotCmpNames(iRealFields) = trim(fields(2,i)) TotAliasNames(iRealFields) = trim(fields(3,i)) - call MAPL_ExportStateGet(exptmp,fields(2,i),state,rc=status) - _VERIFY(STATUS) - call MAPL_StateGet(state,fields(1,i),field,rc=status) - _VERIFY(STATUS) - call ESMF_AttributeGet(field,name='DIMS',value=dims,rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet(exptmp,fields(2,i),state,_RC) + call MAPL_StateGet(state,fields(1,i),field,_RC) + call ESMF_AttributeGet(field,name='DIMS',value=dims,_RC) TotRank(iRealFields) = dims - call ESMF_AttributeGet(field,name='VLOCATION',value=dims,rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(field,name='VLOCATION',value=dims,_RC) TotLoc(iRealFields) = dims endif @@ -5118,24 +4719,18 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & TotVarNames(iRealFields+nUniqueExtraFields) = NonUniqueVarNames(i,1) TotCmpNames(iRealFields+nUniqueExtraFields) = NonUniqueVarNames(i,2) TotAliasNames(iRealFields+nUniqueExtraFields) = NonUniqueVarNames(i,1) - call MAPL_ExportStateGet ( exptmp,NonUniqueVarNames(i,2),state,rc=status ) - _VERIFY(STATUS) - call MAPL_StateGet(state, NonUniqueVarNames(i,1),field,rc=status) - _VERIFY(STATUS) + call MAPL_ExportStateGet ( exptmp,NonUniqueVarNames(i,2),state,_RC ) + call MAPL_StateGet(state, NonUniqueVarNames(i,1),field,_RC) - call ESMF_AttributeGet(field,name='DIMS',value=dims,rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(field,name='DIMS',value=dims,_RC) TotRank(iRealFields+nUniqueExtraFields) = dims - call ESMF_AttributeGet(field,name='VLOCATION',value=dims,rc=status) - _VERIFY(STATUS) + call ESMF_AttributeGet(field,name='VLOCATION',value=dims,_RC) TotLoc(iRealFields+nUniqueExtraFields) = dims end if end do - allocate(extraFields(nUniqueExtraFields),stat=status) - _VERIFY(STATUS) - allocate(extraGridComp(nUniqueExtraFields),stat=status) - _VERIFY(STATUS) + allocate(extraFields(nUniqueExtraFields),_STAT) + allocate(extraGridComp(nUniqueExtraFields),_STAT) nPExtraFields = nUniqueExtraFields nUniqueExtraFields = 0 do i=1,nExtraFields @@ -5155,15 +4750,13 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ! But the actual arithmetic parsing field already has been copied to the temporialy field. ! Also we will do some syntax checking here since this is a good place !---------------------------------------------------------------------- - allocate(VarNeeded(TotFields),stat=status) - _VERIFY(STATUS) + allocate(VarNeeded(TotFields),_STAT) do m=1,nfield if (Rewrite(m) .eqv. .TRUE.) then largest_rank =0 ifound_vloc=.false. - call CheckSyntax(tmpfields(m),TotAliasNames,VarNeeded,rc=status) - _VERIFY(STATUS) + call CheckSyntax(tmpfields(m),TotAliasNames,VarNeeded,_RC) do i=1,TotFields if (VarNeeded(i)) then if (TotRank(i)> largest_rank) then @@ -5217,11 +4810,9 @@ subroutine MAPL_RunExpression(state,fields,tmpfields,rewrite,nfield,rc) do m=1,nfield if (rewrite(m)) then fname = trim(fields(3,m)) - call MAPL_StateGet(state,fname,field,rc=status) - _VERIFY(STATUS) + call MAPL_StateGet(state,fname,field,_RC) fexpr = tmpfields(m) - call MAPL_StateEval(state,fexpr,field,rc=status) - _VERIFY(STATUS) + call MAPL_StateEval(state,fexpr,field,_RC) end if enddo @@ -5244,47 +4835,33 @@ subroutine MAPL_StateDestroy(State, RC) integer :: I, J, N, NF - call ESMF_StateGet(state, ITEMCOUNT=N, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(state, ITEMCOUNT=N, _RC) - allocate(itemNameList(N), STAT=STATUS) - _VERIFY(STATUS) - allocate(itemtypeList(N), STAT=STATUS) - _VERIFY(STATUS) + allocate(itemNameList(N), _STAT) + allocate(itemtypeList(N), _STAT) - call ESMF_StateGet(state,ITEMNAMELIST=itemNamelist,ITEMTYPELIST=itemtypeList,RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(state,ITEMNAMELIST=itemNamelist,ITEMTYPELIST=itemtypeList,_RC) do I=1,N if(itemtypeList(I)==ESMF_STATEITEM_FIELD) then - call ESMF_StateGet(state,itemNameList(I),FIELD,RC=STATUS) - _VERIFY(STATUS) - call ESMF_FieldDestroy(FIELD, rc=status) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemNameList(I),FIELD,_RC) + call ESMF_FieldDestroy(FIELD, _RC) else if(itemtypeList(I)==ESMF_STATEITEM_FieldBundle) then - call ESMF_StateGet(state,itemNameList(I), BUNDLE, RC=STATUS) - _VERIFY(STATUS) - call ESMF_FieldBundleGet(BUNDLE,FieldCount=NF, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateGet(state,itemNameList(I), BUNDLE, _RC) + call ESMF_FieldBundleGet(BUNDLE,FieldCount=NF, _RC) DO J=1,NF - call ESMF_FieldBundleGet(BUNDLE, J, FIELD, RC=STATUS) - _VERIFY(STATUS) - call ESMF_FieldDestroy(field, rc=status) - _VERIFY(STATUS) + call ESMF_FieldBundleGet(BUNDLE, J, FIELD, _RC) + call ESMF_FieldDestroy(field, _RC) END DO - call ESMF_FieldBundleDestroy(BUNDLE, RC=STATUS) - _VERIFY(STATUS) + call ESMF_FieldBundleDestroy(BUNDLE, _RC) else if(itemtypeList(I)==ESMF_STATEITEM_State) then !ALT we ingore nested states for now, they will get destroyed by their GC end if end do - call ESMF_StateDestroy(STATE, RC=STATUS) - _VERIFY(STATUS) + call ESMF_StateDestroy(STATE, _RC) - deallocate(itemNameList, STAT=STATUS) - _VERIFY(STATUS) - deallocate(itemtypeList, STAT=STATUS) - _VERIFY(STATUS) + deallocate(itemNameList, _STAT) + deallocate(itemtypeList, _STAT) _RETURN(ESMF_SUCCESS) end subroutine MAPL_StateDestroy @@ -5313,7 +4890,6 @@ subroutine MAPL_StateGet(state,name,field,rc) else call ESMF_StateGet(state,trim(name),field,rc=status) _ASSERT(status==ESMF_SUCCESS,'Field '//trim(name)//' not found') - _VERIFY(STATUS) end if _RETURN(ESMF_SUCCESS) @@ -5350,20 +4926,17 @@ subroutine RecordRestart( gc, import, export, clock, rc ) ! Check if it is time to do anything doRecord = .false. - call MAPL_InternalStateRetrieve(GC, meta, rc=status) - _VERIFY(status) + call MAPL_InternalStateRetrieve(GC, meta, _RC) - doRecord = MAPL_RecordAlarmIsRinging(meta, rc=status) + doRecord = MAPL_RecordAlarmIsRinging(meta, _RC) if (.not. doRecord) then _RETURN(ESMF_SUCCESS) end if - call MAPL_DateStampGet(clock, datestamp, rc=status) - _VERIFY(STATUS) + call MAPL_DateStampGet(clock, datestamp, _RC) ! Retrieve the pointer to the state call ESMF_GridCompGetInternalState(gc, wrap, status) - _VERIFY(status) IntState => wrap%ptr list => IntState%list nlist = size(list) @@ -5377,12 +4950,10 @@ subroutine RecordRestart( gc, import, export, clock, rc ) if (.not. list(n)%partial) then ! save the compname - call ESMF_CplCompGet (INTSTATE%CCS(n), name=fname_saved, rc=status) - _VERIFY(status) + call ESMF_CplCompGet (INTSTATE%CCS(n), name=fname_saved, _RC) ! add timestamp to filename filename = trim(fname_saved) // datestamp - call ESMF_CplCompSet (INTSTATE%CCS(n), name=filename, rc=status) - _VERIFY(status) + call ESMF_CplCompSet (INTSTATE%CCS(n), name=filename, _RC) call ESMF_CplCompWriteRestart (INTSTATE%CCS(n), & importState=INTSTATE%CIM(n), & @@ -5391,8 +4962,7 @@ subroutine RecordRestart( gc, import, export, clock, rc ) userRC=STATUS) _VERIFY(STATUS) ! restore the compname - call ESMF_CplCompSet (INTSTATE%CCS(n), name=fname_saved, rc=status) - _VERIFY(status) + call ESMF_CplCompSet (INTSTATE%CCS(n), name=fname_saved, _RC) end if end if end if @@ -5410,15 +4980,11 @@ subroutine checkIfStateHasField(state, fieldName, hasField, rc) character (len=ESMF_MAXSTR), allocatable :: itemNameList(:) type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) - call ESMF_StateGet(state, itemcount=n, rc=status) - _VERIFY(status) + call ESMF_StateGet(state, itemcount=n, _RC) - allocate(itemNameList(n), stat=status) - _VERIFY(status) - allocate(itemTypeList(n), stat=status) - _VERIFY(status) - call ESMF_StateGet(state,itemnamelist=itemNamelist,itemtypelist=itemTypeList,rc=status) - _VERIFY(STATUS) + allocate(itemNameList(n), _STAT) + allocate(itemTypeList(n), _STAT) + call ESMF_StateGet(state,itemnamelist=itemNamelist,itemtypelist=itemTypeList,_RC) hasField = .false. do I=1,N @@ -5428,10 +4994,8 @@ subroutine checkIfStateHasField(state, fieldName, hasField, rc) exit end if end do - deallocate(itemNameList, stat=status) - _VERIFY(STATUS) - deallocate(itemTypeList, stat=status) - _VERIFY(status) + deallocate(itemNameList, _STAT) + deallocate(itemTypeList, _STAT) _RETURN(ESMF_SUCCESS) end subroutine checkIfStateHasField @@ -5455,24 +5019,17 @@ subroutine shavebits( state, list, rc) call ESMF_VMGet(vm,mpiCommunicator=mpi_comm,_RC) do m=1,list%field_set%nfields - call ESMF_StateGet(state, trim(list%field_set%fields(3,m)),field,rc=status ) - _VERIFY(STATUS) - call ESMF_FieldGet(field, rank=fieldRank,rc=status) + call ESMF_StateGet(state, trim(list%field_set%fields(3,m)),field,_RC ) + call ESMF_FieldGet(field, rank=fieldRank,_RC) if (fieldRank ==1) then - call ESMF_FieldGet(field, farrayptr=ptr1d, rc=status) - _VERIFY(STATUS) - call DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayptr=ptr1d, _RC) + call DownBit(ptr1d,ptr1d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,_RC) elseif (fieldRank ==2) then - call ESMF_FieldGet(field, farrayptr=ptr2d, rc=status) - _VERIFY(STATUS) - call DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayptr=ptr2d, _RC) + call DownBit(ptr2d,ptr2d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,_RC) elseif (fieldRank ==3) then - call ESMF_FieldGet(field, farrayptr=ptr3d, rc=status) - _VERIFY(STATUS) - call DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,rc=status) - _VERIFY(STATUS) + call ESMF_FieldGet(field, farrayptr=ptr3d, _RC) + call DownBit(ptr3d,ptr3d,list%nbits_to_keep,undef=MAPL_undef,mpi_comm=mpi_comm,_RC) else _FAIL('The field rank is not implmented') endif diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 94e0d1c3d3a..dd63f711a17 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -74,36 +74,27 @@ function HistoryTrajectory_from_file(filename,unusable,rc) result(trajectory) type(FileMetadataUtils) :: metadata type(FileMetadata) :: basic_metadata integer :: num_times - + _UNUSED_DUMMY(unusable) - call formatter%open(trim(filename),pFIO_READ,rc=status) - _VERIFY(status) - basic_metadata = formatter%read(rc=status) - _VERIFY(status) + call formatter%open(trim(filename),pFIO_READ,_RC) + basic_metadata = formatter%read(_RC) call metadata%create(basic_metadata,trim(filename)) - num_times = metadata%get_dimension("time",rc=status) - _VERIFY(status) - allocate(trajectory%lons(num_times),trajectory%lats(num_times),stat=status) - _VERIFY(status) + num_times = metadata%get_dimension("time",_RC) + allocate(trajectory%lons(num_times),trajectory%lats(num_times),_STAT) if (metadata%is_var_present("longitude")) then - call formatter%get_var("longitude",trajectory%lons,rc=status) - _VERIFY(status) + call formatter%get_var("longitude",trajectory%lons,_RC) end if if (metadata%is_var_present("latitude")) then - call formatter%get_var("latitude",trajectory%lats,rc=status) - _VERIFY(status) + call formatter%get_var("latitude",trajectory%lats,_RC) end if - - call metadata%get_time_info(timeVector=trajectory%times,rc=status) - _VERIFY(status) - trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,rc=status) - _VERIFY(status) - trajectory%root_locstream = trajectory%locstream_factory%create_locstream(rc=status) - _VERIFY(status) - - _RETURN(_SUCCESS) - + + call metadata%get_time_info(timeVector=trajectory%times,_RC) + trajectory%locstream_factory = LocStreamFactory(trajectory%lons,trajectory%lats,_RC) + trajectory%root_locstream = trajectory%locstream_factory%create_locstream(_RC) + + _RETURN(_SUCCESS) + end function HistoryTrajectory_from_file subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc) @@ -131,17 +122,13 @@ subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc if (present(vdata)) then this%vdata=vdata else - this%vdata=VerticalData(rc=status) - _VERIFY(status) + this%vdata=VerticalData(_RC) end if - call this%vdata%append_vertical_metadata(this%metadata,this%bundle,rc=status) - _VERIFY(status) + call this%vdata%append_vertical_metadata(this%metadata,this%bundle,_RC) this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) - if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,rc=status) - _VERIFY(status) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) - call timeInfo%add_time_to_metadata(this%metadata,rc=status) - _VERIFY(status) + call timeInfo%add_time_to_metadata(this%metadata,_RC) this%time_info = timeInfo nobs = size(this%times) v = variable(type=PFIO_REAL64,dimensions="time") @@ -158,46 +145,37 @@ subroutine initialize(this,items,bundle,timeInfo,unusable,vdata,recycle_track,rc do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call this%create_variable(item%xname,rc=status) - _VERIFY(status) + call this%create_variable(item%xname,_RC) else if (item%itemType == ItemTypeVector) then - call this%create_variable(item%xname,rc=status) - _VERIFY(status) - call this%create_variable(item%yname,rc=status) - _VERIFY(status) + call this%create_variable(item%xname,_RC) + call this%create_variable(item%yname,_RC) end if call iter%next() enddo - - call ESMF_FieldBundleGet(this%bundle,grid=grid,rc=status) - !this%dist_locstream = this%locstream_factory%create_locstream(grid=grid,rc=status) - !_VERIFY(status) + + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + !this%dist_locstream = this%locstream_factory%create_locstream(grid=grid,_RC) this%number_written = 0 this%previous_index = lbound(this%times,1)-1 - call timeInfo%get(clock=clock,rc=status) - _VERIFY(status) - call ESMF_ClockGet(clock,currTime=this%previous_time,rc=status) - _VERIFY(status) - - this%regridder = LocStreamRegridder(grid,this%root_locstream,rc=status) - _VERIFY(status) - call this%create_output_bundle(rc=status) - _VERIFY(status) + call timeInfo%get(clock=clock,_RC) + call ESMF_ClockGet(clock,currTime=this%previous_time,_RC) + + this%regridder = LocStreamRegridder(grid,this%root_locstream,_RC) + call this%create_output_bundle(_RC) this%file_name = '' - + this%recycle_track=.false. if (present(recycle_track)) then this%recycle_track=recycle_track end if if (this%recycle_track) then - call this%reset_times_to_current_day(rc=status) - _VERIFY(status) + call this%reset_times_to_current_day(_RC) end if _RETURN(_SUCCESS) end subroutine initialize - + function compute_times_for_interval(this,interval,rc) result(rtimes) class(HistoryTrajectory), intent(inout) :: this integer, intent(in) :: interval(2) @@ -212,35 +190,30 @@ function compute_times_for_interval(this,interval,rc) result(rtimes) if (all(interval==0)) then _RETURN(_SUCCESS) end if - call this%get_file_start_time(file_start_time,tunits,rc=status) - _VERIFY(status) - allocate(rtimes(ntimes),stat=status) - _VERIFY(status) + call this%get_file_start_time(file_start_time,tunits,_RC) + allocate(rtimes(ntimes),_STAT) icnt=0 do i=interval(1),interval(2) icnt=icnt+1 tint = this%times(i)-file_start_time select case(trim(tunits)) case ('days') - call ESMF_TimeIntervalGet(tint,d_r8=rtimes(icnt),rc=status) - _VERIFY(status) + call ESMF_TimeIntervalGet(tint,d_r8=rtimes(icnt),_RC) case ('hours') - call ESMF_TimeIntervalGet(tint,h_r8=rtimes(icnt),rc=status) - _VERIFY(status) + call ESMF_TimeIntervalGet(tint,h_r8=rtimes(icnt),_RC) case ('minutes') - call ESMF_TimeIntervalGet(tint,m_r8=rtimes(icnt),rc=status) - _VERIFY(status) + call ESMF_TimeIntervalGet(tint,m_r8=rtimes(icnt),_RC) end select enddo _RETURN(_SUCCESS) - end function compute_times_for_interval + end function compute_times_for_interval function get_current_interval(this,current_time,rc) result(interval) class(HistoryTrajectory), intent(inout) :: this type(ESMF_Time), intent(inout) :: current_time integer, optional, intent(out) :: rc integer :: interval(2) - integer :: i,nfound + integer :: i,nfound logical :: found found = .false. @@ -248,7 +221,7 @@ function get_current_interval(this,current_time,rc) result(interval) interval = 0 do i=this%previous_index+1,size(this%times) if (this%times(i) .ge. this%previous_time .and. this%times(i) .le. current_time) then - if (.not.found) then + if (.not.found) then interval(1) = i found = .true. end if @@ -275,23 +248,17 @@ subroutine create_variable(this,vname,rc) type(variable) :: v logical :: is_present - call ESMF_FieldBundleGet(this%bundle,vname,field=field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(field,name=var_name,rank=field_rank,rc=status) - _VERIFY(status) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,rc=status) - _VERIFY(status) + call ESMF_FieldBundleGet(this%bundle,vname,field=field,_RC) + call ESMF_FieldGet(field,name=var_name,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) if ( is_present ) then - call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, _RC) else long_name = var_name endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,rc=status) - _VERIFY(status) + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) if ( is_present ) then - call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, RC=STATUS) - _VERIFY(STATUS) + call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, _RC) else units = 'unknown' endif @@ -306,11 +273,10 @@ subroutine create_variable(this,vname,rc) call v%add_attribute('missing_value',MAPL_UNDEF) call v%add_attribute('_FillValue',MAPL_UNDEF) call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) - call this%metadata%add_variable(trim(var_name),v,rc=status) - _VERIFY(status) + call this%metadata%add_variable(trim(var_name),v,_RC) end subroutine create_variable - + subroutine create_output_bundle(this,rc) class(HistoryTrajectory), intent(inout) :: this integer, optional, intent(out) :: rc @@ -321,41 +287,33 @@ subroutine create_output_bundle(this,rc) type(ESMF_Field) :: src_field,dst_field integer :: rank,lb(1),ub(1) - this%output_bundle = ESMF_FieldBundleCreate(rc=status) - _VERIFY(status) + this%output_bundle = ESMF_FieldBundleCreate(_RC) iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(src_field,rank=rank,rc=status) - _VERIFY(status) + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) if (rank==2) then dst_field = ESMF_FieldCreate(this%root_locstream,name=trim(item%xname), & - typekind=ESMF_TYPEKIND_R4,rc=status) - _VERIFY(status) + typekind=ESMF_TYPEKIND_R4,_RC) else if (rank==3) then - call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,rc=status) - _VERIFY(status) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) if (this%vdata%lm/=(ub(1)-lb(1)+1)) then lb(1)=1 ub(1)=this%vdata%lm end if dst_field = ESMF_FieldCreate(this%root_locstream,name=trim(item%xname), & - typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,rc=status) - _VERIFY(status) + typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) end if - call MAPL_FieldBundleAdd(this%output_bundle,dst_field,rc=status) - _VERIFY(status) + call MAPL_FieldBundleAdd(this%output_bundle,dst_field,_RC) else if (item%itemType == ItemTypeVector) then - _VERIFY(status) - _VERIFY(status) + _FAIL("ItemTypeVector not yet supported") end if call iter%next() enddo - + end subroutine create_output_bundle subroutine create_file_handle(this,filename,rc) @@ -367,15 +325,11 @@ subroutine create_file_handle(this,filename,rc) integer :: status this%file_name = trim(filename) - v = this%time_info%define_time_variable(rc=status) - _VERIFY(status) - call this%metadata%modify_variable('time',v,rc=status) - _VERIFY(status) + v = this%time_info%define_time_variable(_RC) + call this%metadata%modify_variable('time',v,_RC) if (mapl_am_I_root()) then - call this%file_handle%create(trim(filename),rc=status) - _VERIFY(status) - call this%file_handle%write(this%metadata,rc=status) - _VERIFY(status) + call this%file_handle%create(trim(filename),_RC) + call this%file_handle%write(this%metadata,_RC) end if this%number_written = 0 @@ -388,8 +342,7 @@ subroutine close_file_handle(this,rc) if (trim(this%file_name) /= '') then if (mapl_am_i_root()) then - call this%file_handle%close(rc=status) - _VERIFY(status) + call this%file_handle%close(_RC) end if end if @@ -417,83 +370,63 @@ subroutine append_file(this,current_time,rc) number_to_write = 0 else number_to_write = interval(2)-interval(1)+1 - end if + end if if (number_to_write>0) then - rtimes = this%compute_times_for_interval(interval,rc=status) - _VERIFY(status) + rtimes = this%compute_times_for_interval(interval,_RC) if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%setup_eta_to_pressure(rc=status) - _VERIFY(status) + call this%vdata%setup_eta_to_pressure(_RC) end if if (mapl_am_i_root()) then call this%file_handle%put_var('time',rtimes,& - start=[this%number_written+1],count=[number_to_write],rc=status) - _VERIFY(status) + start=[this%number_written+1],count=[number_to_write],_RC) call this%file_handle%put_var('longitude',this%lons(interval(1):interval(2)),& - start=[this%number_written+1],count=[number_to_write],rc=status) - _VERIFY(status) + start=[this%number_written+1],count=[number_to_write],_RC) call this%file_handle%put_var('latitude',this%lats(interval(1):interval(2)),& - start=[this%number_written+1],count=[number_to_write],rc=status) - _VERIFY(status) + start=[this%number_written+1],count=[number_to_write],_RC) end if deallocate(rtimes) iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%output_bundle,trim(item%xname),field=dst_field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(src_field,rank=rank,rc=status) - _VERIFY(status) + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldBundleGet(this%output_bundle,trim(item%xname),field=dst_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) if (rank==2) then - call ESMF_FieldGet(src_field,farrayptr=p_src_2d,rc=status) - _VERIFY(status) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,rc=status) - _VERIFY(status) - call this%regridder%regrid(p_src_2d,p_dst_2d,rc=status) - _VERIFY(status) + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) + call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) if (mapl_am_i_root()) then call this%file_handle%put_var(trim(item%xname),p_dst_2d(interval(1):interval(2)),& - start=[this%number_written+1],count=[number_to_write]) + start=[this%number_written+1],count=[number_to_write]) end if else if (rank==3) then - call ESMF_FieldGet(src_field,farrayptr=p_src_3d,rc=status) - _VERIFY(status) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,rc=status) - _VERIFY(status) + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - allocate(p_new_lev(size(p_src_3d,1),size(p_src_3d,2),this%vdata%lm),stat=status) - _VERIFY(status) - call this%vdata%regrid_eta_to_pressure(p_src_3d,p_new_lev,rc=status) - call this%regridder%regrid(p_new_lev,p_dst_3d,rc=status) - _VERIFY(status) + allocate(p_new_lev(size(p_src_3d,1),size(p_src_3d,2),this%vdata%lm),_STAT) + call this%vdata%regrid_eta_to_pressure(p_src_3d,p_new_lev,_RC) + call this%regridder%regrid(p_new_lev,p_dst_3d,_RC) else - call this%regridder%regrid(p_src_3d,p_dst_3d,rc=status) - _VERIFY(status) + call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) end if if (mapl_am_i_root()) then call this%file_handle%put_var(trim(item%xname),p_dst_3d(interval(1):interval(2),:),& - start=[this%number_written+1,1],count=[number_to_write,size(p_dst_3d,2)]) + start=[this%number_written+1,1],count=[number_to_write,size(p_dst_3d,2)]) end if end if else if (item%itemType == ItemTypeVector) then - _VERIFY(status) - _VERIFY(status) + _FAIL("ItemTypeVector not yet supported") end if call iter%next() enddo this%number_written=this%number_written+number_to_write endif - call ESMF_TimeGet(this%previous_time,dd=previous_day,rc=status) - _VERIFY(status) - call ESMF_TimeGet(current_time,dd=current_day,rc=status) - _VERIFY(status) + call ESMF_TimeGet(this%previous_time,dd=previous_day,_RC) + call ESMF_TimeGet(current_time,dd=current_day,_RC) if (this%recycle_track .and. (current_day/=previous_day)) then - call this%reset_times_to_current_day(rc=status) - _VERIFY(status) + call this%reset_times_to_current_day(_RC) this%previous_index = lbound(this%times,1)-1 end if this%previous_time=current_time @@ -519,8 +452,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) integer lastspace,since_pos integer year,month,day,hour,min,sec - var => this%metadata%get_variable('time',rc=status) - _VERIFY(status) + var => this%metadata%get_variable('time',_RC) attr => var%get_attribute('units') ptimeUnits => attr%get_value() select type(pTimeUnits) @@ -598,8 +530,7 @@ subroutine get_file_start_time(this,start_time,time_units,rc) class default _FAIL("Time unit must be character") end select - call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,rc=status) - _VERIFY(status) + call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,_RC) _RETURN(_SUCCESS) end subroutine get_file_start_time @@ -622,16 +553,12 @@ subroutine reset_times_to_current_day(this,rc) type(ESMF_Time) :: current_time integer :: year,month,day - call this%time_info%get(clock=clock,rc=status) - _VERIFY(status) - call ESMF_ClockGet(clock,currtime=current_time,rc=status) - _VERIFY(status) - call ESMF_TimeGet(current_time,yy=year,mm=month,dd=day,rc=status) - _VERIFY(status) + call this%time_info%get(clock=clock,_RC) + call ESMF_ClockGet(clock,currtime=current_time,_RC) + call ESMF_TimeGet(current_time,yy=year,mm=month,dd=day,_RC) do i=1,size(this%times) - call ESMF_TimeGet(this%times(i),yy=yp,mm=mp,dd=dp,h=h,m=m,s=s,ms=ms,us=us,ns=ns,rc=status) - _VERIFY(status) - call ESMF_TimeSet(this%times(i),yy=year,mm=month,dd=day,h=h,m=m,s=s,ms=ms,us=us,ns=ns,rc=status) + call ESMF_TimeGet(this%times(i),yy=yp,mm=mp,dd=dp,h=h,m=m,s=s,ms=ms,us=us,ns=ns,_RC) + call ESMF_TimeSet(this%times(i),yy=year,mm=month,dd=day,h=h,m=m,s=s,ms=ms,us=us,ns=ns,_RC) enddo end subroutine reset_times_to_current_day From 81254618b54f9be4961097ff33747bab89b44d2a Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 2 Feb 2023 17:09:07 -0500 Subject: [PATCH 55/83] Clean up some __STAT__ calls --- gridcomps/History/MAPL_HistoryGridComp.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index a2ed99c4df7..eb581fda46a 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -1932,7 +1932,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if ! check if split is needed if (.not. split) then - allocate(splitFields(1), __STAT__) + allocate(splitFields(1), _STAT) splitFields(1) = field else call MAPL_FieldSplit(field, splitFields, aliasName=alias_name, _RC) @@ -1943,7 +1943,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) szr = size(list(n)%r4) if (big > szr) then ! grow - allocate(tmp_r4(big), tmp_r8(big), tmp_r8_to_r4(big), __STAT__) + allocate(tmp_r4(big), tmp_r8(big), tmp_r8_to_r4(big), _STAT) tmp_r4(1:szr) = list(n)%r4 tmp_r8(1:szr) = list(n)%r8 tmp_r8_to_r4(1:szr) = list(n)%r8_to_r4 @@ -2006,7 +2006,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call ESMF_FieldGet(FIELD, dimCount=fieldRank, _RC) call ESMF_GridGet(GRID, dimCount=gridRank, _RC) - allocate(gridToFieldMap(gridRank), __STAT__) + allocate(gridToFieldMap(gridRank), _STAT) call ESMF_FieldGet(FIELD, gridToFieldMap=gridToFieldMap, _RC) notGridded = count(gridToFieldMap==0) @@ -2026,7 +2026,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) allocate(ungriddedLBound(unGridDims), & ungriddedUBound(unGridDims), & ungrd(unGridDims), & - __STAT__) + _STAT) call ESMF_FieldGet(field, Array=array, _RC) @@ -2044,7 +2044,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (isPresent) then call ESMF_AttributeGet(field,name="UNGRIDDED_COORDS",itemcount=ungrdsize,_RC) if ( ungrdsize /= 0 ) then - allocate(ungridded_coord(ungrdsize),__STAT__) + allocate(ungridded_coord(ungrdsize),_STAT) call ESMF_AttributeGet(field,NAME="UNGRIDDED_COORDS",valuelist=ungridded_coord,_RC) end if else @@ -3287,7 +3287,7 @@ subroutine Run ( gc, import, export, clock, rc ) allocate(Writing (nlist), _STAT) allocate(filename(nlist), _STAT) - allocate(NewSeg (nlist), __STAT__) + allocate(NewSeg (nlist), _STAT) newSeg = .false. ! decide if we are writing based on alarms @@ -5054,8 +5054,8 @@ subroutine CopyStateItems(src, dst, rc) call ESMF_StateGet(src, itemCount=itemCount, _RC) - allocate(itemnames(itemcount), __STAT__) - allocate(itemtypes(itemcount), __STAT__) + allocate(itemnames(itemcount), _STAT) + allocate(itemtypes(itemcount), _STAT) call ESMF_StateGet(src, itemNameList=itemNames, & itemTypeList=itemTypes, _RC) From 1fd961200075d841f04a760b7033b9b8ea2e7949 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 2 Feb 2023 17:10:22 -0500 Subject: [PATCH 56/83] Update changelog --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a4cbe0a1635..0e488ebe756 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -32,7 +32,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 The specific subroutines remain in MAPL_GenericMod to maintain the interface in one module, but most of the functionality is in MAPL_ResourceMod now. - Update "build like UFS" CI test -- Converted the History Gridded Component to use `_RC` macro +- Converted the History Gridded Component to use `_RC` and `_STAT` macros ### Fixed From ee89ed5ce8353d7b017a674694089474fd1dc5e7 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 3 Feb 2023 09:56:52 -0500 Subject: [PATCH 57/83] Fix missing status --- gridcomps/History/MAPL_HistoryGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index eb581fda46a..f4e8065379e 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3276,7 +3276,7 @@ subroutine Run ( gc, import, export, clock, rc ) importState=INTSTATE%CIM(n), & exportState=INTSTATE%GIM(n), & clock=CLOCK, & - userRC) + userRC=STATUS) _VERIFY(STATUS) end if end do From 44bac8c4d89d7340eb0720a288d56decf64a01da Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 3 Feb 2023 10:04:39 -0500 Subject: [PATCH 58/83] Fix some warnings from Intel --- gridcomps/History/MAPL_HistoryGridComp.F90 | 26 +++++++++++----------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index f4e8065379e..71b385fdd19 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2442,7 +2442,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) write (*,'(A)',ADVANCE='NO') ' Fields: ' do m=1,list(n)%field_set%nfields if( trim(list(n)%field_set%fields(3,m)).ne.BLANK ) then - write (*,'(A,X)',ADVANCE='NO') trim(list(n)%field_set%fields(3,m)) + write (*,'(A,1X)',ADVANCE='NO') trim(list(n)%field_set%fields(3,m)) endif enddo ! Now advance the write @@ -3682,7 +3682,7 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid integer :: DIMS(3) integer :: IM,JM,LM - character*3 :: months(12) + character(len=3) :: months(12) data months /'JAN','FEB','MAR','APR','MAY','JUN', & 'JUL','AUG','SEP','OCT','NOV','DEC'/ @@ -3939,12 +3939,12 @@ subroutine get_DateStamp (clock, DateStamp, offset, rc) integer :: YY,MM,DD,H,M,S integer :: noffset - character*4 year - character*2 month - character*2 day - character*2 hour - character*2 minute - character*2 second + character(len=4) :: year + character(len=2) :: month + character(len=2) :: day + character(len=2) :: hour + character(len=2) :: minute + character(len=2) :: second integer :: STATUS @@ -4535,12 +4535,12 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ExtraFields,ExtraGridComp,ExpState,rc) integer,intent(in)::nfield - character*(*), intent(inout) :: fields(:,:) - character*(*), intent(inout) :: tmpfields(:) + character(len=*), intent(inout) :: fields(:,:) + character(len=*), intent(inout) :: tmpfields(:) logical, intent(inout) :: rewrite(:) integer, intent(inout) :: nPExtraFields - character*(*), pointer, intent(inout) :: ExtraFields(:) - character*(*), pointer, intent(inout) :: ExtraGridComp(:) + character(len=*), pointer, intent(inout) :: ExtraFields(:) + character(len=*), pointer, intent(inout) :: ExtraGridComp(:) type(ESMF_State), intent(inout) :: ExpState integer, optional, intent(out ) :: rc @@ -4797,7 +4797,7 @@ end subroutine MAPL_SetExpression subroutine MAPL_RunExpression(state,fields,tmpfields,rewrite,nfield,rc) type (ESMF_State), intent(in) :: state - character*(*), intent(in):: fields(:,:),tmpfields(:) + character(len=*), intent(in):: fields(:,:),tmpfields(:) logical, intent(inout) :: rewrite(:) integer, intent(in):: nfield integer, optional, intent(out) :: rc From 1f567674dde76490ae699a5de6499dd3e53c6bdf Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 3 Feb 2023 10:04:55 -0500 Subject: [PATCH 59/83] Fix warning from Intel --- gridcomps/Cap/MAPL_CapGridComp.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/Cap/MAPL_CapGridComp.F90 b/gridcomps/Cap/MAPL_CapGridComp.F90 index 9bad9565223..def72d16efb 100644 --- a/gridcomps/Cap/MAPL_CapGridComp.F90 +++ b/gridcomps/Cap/MAPL_CapGridComp.F90 @@ -1348,7 +1348,7 @@ subroutine print_throughput(rc) LOOP_THROUGHPUT,INST_THROUGHPUT,RUN_THROUGHPUT,HRS_R,MIN_R,SEC_R,& mem_committed_percent,mem_used_percent 1000 format(1x,'AGCM Date: ',i4.4,'/',i2.2,'/',i2.2,2x,'Time: ',i2.2,':',i2.2,':',i2.2, & - 2x,'Throughput(days/day)[Avg Tot Run]: ',f12.1,1x,f12.1,1x,f12.1,2x,'TimeRemaining(Est) ',i3.3,':'i2.2,':',i2.2,2x, & + 2x,'Throughput(days/day)[Avg Tot Run]: ',f12.1,1x,f12.1,1x,f12.1,2x,'TimeRemaining(Est) ',i3.3,':',i2.2,':',i2.2,2x, & f5.1,'% : ',f5.1,'% Mem Comm:Used') _RETURN(_SUCCESS) From cb80189cd0216b63a951d98800824380d2e882b0 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 3 Feb 2023 10:42:37 -0500 Subject: [PATCH 60/83] We can't check some statuses --- gridcomps/History/MAPL_HistoryGridComp.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 71b385fdd19..a54e5a90817 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3037,9 +3037,9 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) ! Get Possible ALIAS Name ! ----------------------- - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) ! MAT We don't check this status if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=export_alias,default=export_name,_RC) + call ESMF_ConfigGetAttribute ( cfg,value=export_alias,default=export_name,rc=STATUS) ! MAT We don't check this status else if( trim(tmpstring) /= ' ' ) then export_alias = tmpstring @@ -3055,9 +3055,9 @@ subroutine parse_fields(cfg, label, field_set, collection_name, items, rc) ! Get Possible COUPLER Function ! ----------------------------- - call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,_RC) + call ESMF_ConfigGetAttribute ( cfg,value=tmpstring ,rc=STATUS) ! MAT We don't check this status if( trim(tmpstring) == ',' ) then - call ESMF_ConfigGetAttribute ( cfg,value=coupler_function_name,default=BLANK,_RC) + call ESMF_ConfigGetAttribute ( cfg,value=coupler_function_name,default=BLANK,rc=STATUS) ! MAT We don't check this status else if( trim(tmpstring) /= ' ' ) then coupler_function_name = tmpstring From 7db6fed57c8df7924a05c109939cf8047c175b3b Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 6 Feb 2023 10:43:12 -0500 Subject: [PATCH 61/83] Add debugging --- base/MAPL_Resource.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index ea132f8bf85..ee3a0004ec8 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -22,6 +22,7 @@ call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, _RC) ;\ end if + #ifdef SET_VALS # undef SET_VALS #endif @@ -166,8 +167,9 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then - if (present(rc)) rc = ESMF_FAILURE - return + write(*,*) "Label '" // label // "' not present and default not present. " !wdb DEBUG2 / DEBUG2 +! if (present(rc)) rc = ESMF_FAILURE !wdb original +! return !wdb original end if select type(val) @@ -341,3 +343,7 @@ function intrinsic_to_string(val, str_format, rc) result(formatted_str) end function intrinsic_to_string end module MAPL_ResourceMod +! call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, rc = status) +! if (status /= ESMF_SUCCESS) then +! write(*,*) "label '" // actual_label // "' not found." +! end if From 9b5dab0630867bdcbf70f00420591c758d0e347f Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 6 Feb 2023 14:51:42 -0500 Subject: [PATCH 62/83] Change MAPL_GetResourceFrom... to not verify rc values coming from lower subroutines --- base/MAPL_Resource.F90 | 6 +++--- generic/MAPL_Generic.F90 | 12 ++++++------ 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index ee3a0004ec8..74c983e14ec 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -167,9 +167,9 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then - write(*,*) "Label '" // label // "' not present and default not present. " !wdb DEBUG2 / DEBUG2 -! if (present(rc)) rc = ESMF_FAILURE !wdb original -! return !wdb original +! write(*,*) "Label '" // label // "' not present and default not present. " !wdb DEBUG2 / DEBUG2 + if (present(rc)) rc = ESMF_FAILURE !wdb original + return !wdb original end if select type(val) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 18671118883..e795fdb5374 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8294,9 +8294,9 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) integer :: status - call MAPL_GetResource_config_scalar(state%cf, val, label, default = default, component_name = state%compname, _RC) + call MAPL_GetResource_config_scalar(state%cf, val, label, default = default, component_name = state%compname, rc = status) - _RETURN(_SUCCESS) + _RETURN(status) end subroutine MAPL_GetResourceFromMAPL_scalar @@ -8311,9 +8311,9 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) integer :: status - call MAPL_GetResource_config_scalar(config, val, label, default = default, _RC) + call MAPL_GetResource_config_scalar(config, val, label, default = default, rc = status) - _RETURN(ESMF_SUCCESS) + _RETURN(status) end subroutine MAPL_GetResourceFromConfig_scalar @@ -8326,9 +8326,9 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) integer :: status - call MAPL_GetResource_config_array(state%cf, vals, label, default = default, component_name = state%compname, _RC) + call MAPL_GetResource_config_array(state%cf, vals, label, default = default, component_name = state%compname, rc = status) - _RETURN(ESMF_SUCCESS) + _RETURN(status) end subroutine MAPL_GetResource_array From 776f4036de496f194178c4683ea981757b9e075f Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 6 Feb 2023 21:48:25 -0500 Subject: [PATCH 63/83] Add status & replace return with _RETURN(_SUCCESS) in print_resource --- base/MAPL_Resource.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 74c983e14ec..4da367e0f67 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -257,6 +257,7 @@ subroutine print_resource(printrc, label, val, default, rc) character(len=:), allocatable :: val_str, default_str, output_format, type_str, type_format type(StringVector), pointer, save :: already_printed_labels => null() + integer :: status if (.not. associated(already_printed_labels)) then allocate(already_printed_labels) @@ -266,7 +267,7 @@ subroutine print_resource(printrc, label, val, default, rc) if (.not. vector_contains_str(already_printed_labels, trim(label))) then call already_printed_labels%push_back(trim(label)) else - return + _RETURN(_SUCCESS) end if select type(val) From f4aa596b23dd7d055d8fa03ecb9f628f34cd7f6c Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 8 Feb 2023 09:46:14 -0500 Subject: [PATCH 64/83] Removed debug prints; changed _RETURN(_SUCCESS) to return --- base/MAPL_Resource.F90 | 7 +++---- generic/MAPL_Generic.F90 | 6 +++--- 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 4da367e0f67..1853581c98d 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -167,9 +167,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then -! write(*,*) "Label '" // label // "' not present and default not present. " !wdb DEBUG2 / DEBUG2 - if (present(rc)) rc = ESMF_FAILURE !wdb original - return !wdb original + if (present(rc)) rc = ESMF_FAILURE + return end if select type(val) @@ -221,7 +220,7 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, _ASSERT(same_type_as(vals, default), "Value and default must have same type") end if - _ASSERT(present(component_name), "Component name is present but not present.") + _ASSERT(present(component_name), "Component name is necessary but not present.") call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) ! No default and not in config, error diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index e795fdb5374..789d0e1e7b8 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8296,7 +8296,7 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) call MAPL_GetResource_config_scalar(state%cf, val, label, default = default, component_name = state%compname, rc = status) - _RETURN(status) + rc = status end subroutine MAPL_GetResourceFromMAPL_scalar @@ -8313,7 +8313,7 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) call MAPL_GetResource_config_scalar(config, val, label, default = default, rc = status) - _RETURN(status) + rc = status end subroutine MAPL_GetResourceFromConfig_scalar @@ -8328,7 +8328,7 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) call MAPL_GetResource_config_array(state%cf, vals, label, default = default, component_name = state%compname, rc = status) - _RETURN(status) + rc = status end subroutine MAPL_GetResource_array From 20eb411eb6ca3bb3967ee5a6c56d34d3072fd355 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 8 Feb 2023 14:25:39 -0500 Subject: [PATCH 65/83] Add _RETURN(_SUCCESS) --- base/MAPL_Resource.F90 | 30 +++++++++++++++--------------- generic/MAPL_Generic.F90 | 15 +++++++++------ 2 files changed, 24 insertions(+), 21 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 1853581c98d..c429940136e 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -19,7 +19,8 @@ _FAIL("Type of 'default' does not match type of 'VAL'.") ;\ end select ;\ else ;\ - call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, _RC) ;\ + call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, rc = status) ;\ + _VERIFY(status) ;\ end if @@ -37,7 +38,8 @@ _FAIL("Type of 'default' does not match type of 'VALS'.") ;\ end select ;\ else ;\ - call ESMF_ConfigGetAttribute(config, valuelist = VALS, count = count, label = actual_label, _RC) ;\ + call ESMF_ConfigGetAttribute(config, valuelist = VALS, count = count, label = actual_label, rc = status) ;\ + _VERIFY(status) ;\ end if #ifdef SET_STRINGS @@ -131,12 +133,12 @@ subroutine get_actual_label(config, label, label_is_present, actual_label, unusa do i = 1, size(labels_to_try) actual_label = trim(labels_to_try(i)) if (len_trim(actual_label) == 0 ) cycle - call ESMF_ConfigFindLabel(config, label = actual_label, isPresent = label_is_present, _RC) + call ESMF_ConfigFindLabel(config, label = actual_label, isPresent = label_is_present, rc = status) + _VERIFY(status) if (label_is_present) exit end do _RETURN(_SUCCESS) - end subroutine get_actual_label ! Find value of scalar variable in config @@ -162,7 +164,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, _ASSERT(same_type_as(val, default), "Value and default must have same type") end if - call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, rc = status) + _VERIFY(status) ! No default and not in config, error ! label or default must be present @@ -182,7 +185,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, _FAIL( "Unupported type") end select - call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, _RC) + call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, rc = status) + _VERIFY(status) ! Can set printrc to negative to not print at all if (MAPL_AM_I_Root() .and. printrc >= 0) then @@ -191,7 +195,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, else label_to_print = trim(label) end if - call print_resource(printrc, label_to_print, val, default=default, _RC) + call print_resource(printrc, label_to_print, val, default=default, rc = status) + _VERIFY(status) end if _RETURN(ESMF_SUCCESS) @@ -221,7 +226,8 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, end if _ASSERT(present(component_name), "Component name is necessary but not present.") - call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, rc = status) + _VERIFY(status) ! No default and not in config, error ! label or default must be present @@ -266,7 +272,7 @@ subroutine print_resource(printrc, label, val, default, rc) if (.not. vector_contains_str(already_printed_labels, trim(label))) then call already_printed_labels%push_back(trim(label)) else - _RETURN(_SUCCESS) + return end if select type(val) @@ -292,8 +298,6 @@ subroutine print_resource(printrc, label, val, default, rc) print output_format, trim(label), trim(val_str) end if - _RETURN(_SUCCESS) - end subroutine print_resource logical function vector_contains_str(vector, string) @@ -343,7 +347,3 @@ function intrinsic_to_string(val, str_format, rc) result(formatted_str) end function intrinsic_to_string end module MAPL_ResourceMod -! call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, rc = status) -! if (status /= ESMF_SUCCESS) then -! write(*,*) "label '" // actual_label // "' not found." -! end if diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 789d0e1e7b8..6ae0db6e4a4 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8295,8 +8295,9 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) integer :: status call MAPL_GetResource_config_scalar(state%cf, val, label, default = default, component_name = state%compname, rc = status) - - rc = status + _VERIFY(status) + + _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromMAPL_scalar @@ -8312,8 +8313,9 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) integer :: status call MAPL_GetResource_config_scalar(config, val, label, default = default, rc = status) - - rc = status + _VERIFY(status) + + _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromConfig_scalar @@ -8327,8 +8329,9 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) integer :: status call MAPL_GetResource_config_array(state%cf, vals, label, default = default, component_name = state%compname, rc = status) - - rc = status + _VERIFY(status) + + _RETURN(_SUCCESS) end subroutine MAPL_GetResource_array From 5726e7c4fd5d3c0d8e6d74f76ee70843029ced8d Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Thu, 9 Feb 2023 15:32:31 -0500 Subject: [PATCH 66/83] Add value_is_found flag to maintain compatibility --- base/MAPL_Resource.F90 | 18 +++++++++++++----- generic/MAPL_Generic.F90 | 28 ++++++++++++++++++++++------ 2 files changed, 35 insertions(+), 11 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index c429940136e..107aee89439 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -142,10 +142,11 @@ subroutine get_actual_label(config, label, label_is_present, actual_label, unusa end subroutine get_actual_label ! Find value of scalar variable in config - subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, component_name, rc) + subroutine MAPL_GetResource_config_scalar(config, val, label, value_is_set, unusable, default, component_name, rc) type(ESMF_Config), intent(inout) :: config class(*), intent(inout) :: val character(len=*), intent(in) :: label + logical , intent(out) :: value_is_set class(KeywordEnforcer), optional, intent(in) :: unusable class(*), optional, intent(in) :: default character(len=*), optional, intent(in) :: component_name @@ -158,6 +159,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, _UNUSED_DUMMY(unusable) + value_is_set = .FALSE. + default_is_present = present(default) if (default_is_present) then @@ -170,7 +173,6 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then - if (present(rc)) rc = ESMF_FAILURE return end if @@ -184,6 +186,8 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, class default _FAIL( "Unupported type") end select + + value_is_set = .TRUE. call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, rc = status) _VERIFY(status) @@ -204,10 +208,11 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, unusable, default, end subroutine MAPL_GetResource_config_scalar ! Find value of array variable in config - subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, component_name, rc) + subroutine MAPL_GetResource_config_array(config, vals, label, value_is_set, unusable, default, component_name, rc) type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: label class(*), intent(inout) :: vals(:) + character(len=*), intent(in) :: label + logical, intent(out) :: value_is_set class(KeywordEnforcer), optional, intent(in) :: unusable class(*), optional, intent(in) :: default(:) character(len=*), optional, intent(in) :: component_name @@ -219,6 +224,8 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, _UNUSED_DUMMY(unusable) + value_is_set = .FALSE. + default_is_present = present(default) if (default_is_present) then @@ -232,7 +239,6 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then - if (present(rc)) rc = ESMF_FAILURE return end if @@ -249,6 +255,8 @@ subroutine MAPL_GetResource_config_array(config, vals, label, unusable, default, _FAIL( "Unsupported type") end select + value_is_set = .TRUE. + _RETURN(ESMF_SUCCESS) end subroutine MAPL_GetResource_config_array diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 6ae0db6e4a4..c39ac8ebb42 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8292,11 +8292,17 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) class(*), optional, intent(in) :: default integer, optional, intent(out) :: rc + logical :: value_is_set integer :: status - call MAPL_GetResource_config_scalar(state%cf, val, label, default = default, component_name = state%compname, rc = status) + call MAPL_GetResource_config_scalar(state%cf, val, label, value_is_set, & + default = default, component_name = state%compname, rc = status) _VERIFY(status) - + + if(.not. value_is_set) then + _RETURN(ESMF_FAILURE) + end if + _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromMAPL_scalar @@ -8311,11 +8317,16 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) integer, optional, intent(out) :: rc integer :: status + logical :: value_is_set - call MAPL_GetResource_config_scalar(config, val, label, default = default, rc = status) + call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, rc = status) _VERIFY(status) - _RETURN(_SUCCESS) + if(value_is_set) then + _RETURN(_SUCCESS) + else + _RETURN(ESMF_FAILURE) + end if end subroutine MAPL_GetResourceFromConfig_scalar @@ -8326,11 +8337,16 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) class(*), optional, intent(in) :: default(:) integer, optional, intent(out) :: rc + logical :: value_is_set integer :: status - - call MAPL_GetResource_config_array(state%cf, vals, label, default = default, component_name = state%compname, rc = status) + + call MAPL_GetResource_config_array(state%cf, vals, label, value_is_set, default = default, component_name = state%compname, rc = status) _VERIFY(status) + if(.not. value_is_set) then + _RETURN(ESMF_FAILURE) + end if + _RETURN(_SUCCESS) end subroutine MAPL_GetResource_array From 32d57c2019db27a1d33565ed455d308efeac36cb Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Thu, 9 Feb 2023 21:00:38 -0500 Subject: [PATCH 67/83] Modify to use _RC macro (again) --- base/MAPL_Resource.F90 | 21 +++++++-------------- generic/MAPL_Generic.F90 | 10 ++++------ 2 files changed, 11 insertions(+), 20 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 107aee89439..17e210eeaa8 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -19,8 +19,7 @@ _FAIL("Type of 'default' does not match type of 'VAL'.") ;\ end select ;\ else ;\ - call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, rc = status) ;\ - _VERIFY(status) ;\ + call ESMF_ConfigGetAttribute(config, VAL, label = actual_label, _RC) ;\ end if @@ -38,8 +37,7 @@ _FAIL("Type of 'default' does not match type of 'VALS'.") ;\ end select ;\ else ;\ - call ESMF_ConfigGetAttribute(config, valuelist = VALS, count = count, label = actual_label, rc = status) ;\ - _VERIFY(status) ;\ + call ESMF_ConfigGetAttribute(config, valuelist = VALS, count = count, label = actual_label, _RC) ;\ end if #ifdef SET_STRINGS @@ -133,8 +131,7 @@ subroutine get_actual_label(config, label, label_is_present, actual_label, unusa do i = 1, size(labels_to_try) actual_label = trim(labels_to_try(i)) if (len_trim(actual_label) == 0 ) cycle - call ESMF_ConfigFindLabel(config, label = actual_label, isPresent = label_is_present, rc = status) - _VERIFY(status) + call ESMF_ConfigFindLabel(config, label = actual_label, isPresent = label_is_present, _RC) if (label_is_present) exit end do @@ -167,8 +164,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, value_is_set, unus _ASSERT(same_type_as(val, default), "Value and default must have same type") end if - call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, rc = status) - _VERIFY(status) + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) ! No default and not in config, error ! label or default must be present @@ -189,8 +185,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, value_is_set, unus value_is_set = .TRUE. - call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, rc = status) - _VERIFY(status) + call ESMF_ConfigGetAttribute(config, printrc, label = 'PRINTRC:', default = 0, _RC) ! Can set printrc to negative to not print at all if (MAPL_AM_I_Root() .and. printrc >= 0) then @@ -199,8 +194,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, value_is_set, unus else label_to_print = trim(label) end if - call print_resource(printrc, label_to_print, val, default=default, rc = status) - _VERIFY(status) + call print_resource(printrc, label_to_print, val, default=default, _RC) end if _RETURN(ESMF_SUCCESS) @@ -233,8 +227,7 @@ subroutine MAPL_GetResource_config_array(config, vals, label, value_is_set, unus end if _ASSERT(present(component_name), "Component name is necessary but not present.") - call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, rc = status) - _VERIFY(status) + call get_actual_label(config, label, label_is_present, actual_label, component_name = component_name, _RC) ! No default and not in config, error ! label or default must be present diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index c39ac8ebb42..c6199264ab6 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8296,8 +8296,7 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) integer :: status call MAPL_GetResource_config_scalar(state%cf, val, label, value_is_set, & - default = default, component_name = state%compname, rc = status) - _VERIFY(status) + default = default, component_name = state%compname, _RC) if(.not. value_is_set) then _RETURN(ESMF_FAILURE) @@ -8319,8 +8318,7 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) integer :: status logical :: value_is_set - call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, rc = status) - _VERIFY(status) + call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, _RC) if(value_is_set) then _RETURN(_SUCCESS) @@ -8340,8 +8338,8 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) logical :: value_is_set integer :: status - call MAPL_GetResource_config_array(state%cf, vals, label, value_is_set, default = default, component_name = state%compname, rc = status) - _VERIFY(status) + call MAPL_GetResource_config_array(state%cf, vals, label, value_is_set, & + default = default, component_name = state%compname, _RC) if(.not. value_is_set) then _RETURN(ESMF_FAILURE) From 6dd955469a158afe9f1d3441b08865e8338b8940 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Thu, 9 Feb 2023 22:57:34 -0500 Subject: [PATCH 68/83] Modify to simple return when value is not set: Some codes uses the RC as a flag that value is not set --- base/MAPL_Resource.F90 | 2 ++ generic/MAPL_Generic.F90 | 15 +++++++++------ 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 17e210eeaa8..0b42f168ba7 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -169,6 +169,7 @@ subroutine MAPL_GetResource_config_scalar(config, val, label, value_is_set, unus ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then + value_is_set = .FALSE. return end if @@ -232,6 +233,7 @@ subroutine MAPL_GetResource_config_array(config, vals, label, value_is_set, unus ! No default and not in config, error ! label or default must be present if (.not. label_is_present .and. .not. default_is_present) then + value_is_set = .FALSE. return end if diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index c6199264ab6..01cd2b03b0c 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8299,7 +8299,8 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) default = default, component_name = state%compname, _RC) if(.not. value_is_set) then - _RETURN(ESMF_FAILURE) + if (present(rc)) rc = ESMF_FAILURE + return end if _RETURN(_SUCCESS) @@ -8320,12 +8321,13 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, _RC) - if(value_is_set) then - _RETURN(_SUCCESS) - else - _RETURN(ESMF_FAILURE) + if(.not. value_is_set) then + if (present(rc)) rc = ESMF_FAILURE + return end if + _RETURN(_SUCCESS) + end subroutine MAPL_GetResourceFromConfig_scalar subroutine MAPL_GetResource_array(state, vals, label, default, rc) @@ -8342,7 +8344,8 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) default = default, component_name = state%compname, _RC) if(.not. value_is_set) then - _RETURN(ESMF_FAILURE) + if (present(rc)) rc = ESMF_FAILURE + return end if _RETURN(_SUCCESS) From 675ae6d4b46af09c4a9f180961be1f18ef42af20 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 10 Feb 2023 10:36:53 -0500 Subject: [PATCH 69/83] Add _RETURN(_SUCCESS) to print_output; changed _RC to _VERIFY after check for label --- base/MAPL_Resource.F90 | 2 ++ generic/MAPL_Generic.F90 | 12 +++++++++--- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 0b42f168ba7..420052a6c62 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -301,6 +301,8 @@ subroutine print_resource(printrc, label, val, default, rc) print output_format, trim(label), trim(val_str) end if + _RETURN(_SUCCESS) + end subroutine print_resource logical function vector_contains_str(vector, string) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 01cd2b03b0c..95b74a01968 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8296,13 +8296,15 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) integer :: status call MAPL_GetResource_config_scalar(state%cf, val, label, value_is_set, & - default = default, component_name = state%compname, _RC) + default = default, component_name = state%compname, rc = status) if(.not. value_is_set) then if (present(rc)) rc = ESMF_FAILURE return end if + _VERIFY(status) + _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromMAPL_scalar @@ -8319,13 +8321,15 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) integer :: status logical :: value_is_set - call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, _RC) + call MAPL_GetResource_config_scalar(config, val, label, value_is_set, default = default, rc = status) if(.not. value_is_set) then if (present(rc)) rc = ESMF_FAILURE return end if + _VERIFY(status) + _RETURN(_SUCCESS) end subroutine MAPL_GetResourceFromConfig_scalar @@ -8341,12 +8345,14 @@ subroutine MAPL_GetResource_array(state, vals, label, default, rc) integer :: status call MAPL_GetResource_config_array(state%cf, vals, label, value_is_set, & - default = default, component_name = state%compname, _RC) + default = default, component_name = state%compname, rc = status) if(.not. value_is_set) then if (present(rc)) rc = ESMF_FAILURE return end if + + _VERIFY(status) _RETURN(_SUCCESS) From b472f5181a88c97de95c96e4b6fac85aa162c559 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 10 Feb 2023 21:58:16 -0500 Subject: [PATCH 70/83] Update comments --- base/MAPL_Resource.F90 | 8 +++++++- generic/MAPL_Generic.F90 | 6 +++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/base/MAPL_Resource.F90 b/base/MAPL_Resource.F90 index 420052a6c62..219381acb47 100644 --- a/base/MAPL_Resource.F90 +++ b/base/MAPL_Resource.F90 @@ -60,7 +60,8 @@ module MAPL_ResourceMod !BOP ! !MODULE: MAPL_ResourceMod ! - ! !DESCRIPTION: MAPL\_ResourceMod ... + ! !DESCRIPTION: MAPL\_ResourceMod provides subroutines get scalar and array + ! resources from ESMF_Config objects. ! !USES: @@ -256,6 +257,9 @@ subroutine MAPL_GetResource_config_array(config, vals, label, value_is_set, unus end subroutine MAPL_GetResource_config_array + ! Print the resource value according to the value of printrc + ! printrc = 0 - Only print non-default values + ! printrc = 1 - Print all values subroutine print_resource(printrc, label, val, default, rc) integer, intent(in) :: printrc character(len=*), intent(in) :: label @@ -305,6 +309,7 @@ subroutine print_resource(printrc, label, val, default, rc) end subroutine print_resource + ! Check if vector contains string logical function vector_contains_str(vector, string) type(StringVector), intent(in) :: vector character(len=*), intent(in) :: string @@ -324,6 +329,7 @@ logical function vector_contains_str(vector, string) end function vector_contains_str + ! Convert val to string according to str_format function intrinsic_to_string(val, str_format, rc) result(formatted_str) class(*), intent(in) :: val character(len=*), intent(in) :: str_format diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 95b74a01968..8b28e1856fc 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -8285,6 +8285,8 @@ recursive subroutine MAPL_GenericConnCheck(GC, RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_GenericConnCheck + ! This is a pass-through routine. It maintains the interface for + ! MAPL_GetResource as-is instead of moving this subroutine to another module. subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) type(MAPL_MetaComp), intent(inout) :: state character(len=*), intent(in) :: label @@ -8310,7 +8312,7 @@ subroutine MAPL_GetResourceFromMAPL_scalar(state, val, label, default, rc) end subroutine MAPL_GetResourceFromMAPL_scalar ! This is a pass-through routine. It maintains the interface for - ! MAPL_GetResource as is instead of moving this subroutine to another module. + ! MAPL_GetResource as-is instead of moving this subroutine to another module. subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) type(ESMF_Config), intent(inout) :: config character(len=*), intent(in) :: label @@ -8334,6 +8336,8 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) end subroutine MAPL_GetResourceFromConfig_scalar + ! This is a pass-through routine. It maintains the interface for + ! MAPL_GetResource as-is instead of moving this subroutine to another module. subroutine MAPL_GetResource_array(state, vals, label, default, rc) type(MAPL_MetaComp), intent(inout) :: state character(len=*), intent(in) :: label From d43438a10c384728eeda0d150dedfa818e147ec2 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Sun, 12 Feb 2023 21:57:40 -0500 Subject: [PATCH 71/83] Updated CHANGELOG.md with bugfix --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index b7165ed4a51..1f28670ebe6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -40,6 +40,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Corrected issue with native output having metadata saying it was bilinearly regridded. Now sets these files to have `regrid_method: identity` - Fix bug in `mapl_acg.cmake` that caused unnecessary rebuilds +- Fixed error handling for refactored MAPL_GetResource ### Removed From 1ea7b1e5804bef285660887f809ddf10c07df983 Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Tue, 14 Feb 2023 00:14:56 +0000 Subject: [PATCH 72/83] Bump devops-infra/action-pull-request from 0.5.3 to 0.5.5 Bumps [devops-infra/action-pull-request](https://github.com/devops-infra/action-pull-request) from 0.5.3 to 0.5.5. - [Release notes](https://github.com/devops-infra/action-pull-request/releases) - [Commits](https://github.com/devops-infra/action-pull-request/compare/v0.5.3...v0.5.5) --- updated-dependencies: - dependency-name: devops-infra/action-pull-request dependency-type: direct:production update-type: version-update:semver-patch ... Signed-off-by: dependabot[bot] --- .github/workflows/push-to-develop.yml | 2 +- .github/workflows/push-to-main.yml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/push-to-develop.yml b/.github/workflows/push-to-develop.yml index cea02428d49..fd525b2a4b3 100644 --- a/.github/workflows/push-to-develop.yml +++ b/.github/workflows/push-to-develop.yml @@ -15,7 +15,7 @@ jobs: with: fetch-depth: 0 - name: Run the action - uses: devops-infra/action-pull-request@v0.5.3 + uses: devops-infra/action-pull-request@v0.5.5 with: github_token: ${{ secrets.GITHUB_TOKEN }} source_branch: develop diff --git a/.github/workflows/push-to-main.yml b/.github/workflows/push-to-main.yml index ab955b6be68..07114a4aaad 100644 --- a/.github/workflows/push-to-main.yml +++ b/.github/workflows/push-to-main.yml @@ -15,7 +15,7 @@ jobs: with: fetch-depth: 0 - name: Run the action - uses: devops-infra/action-pull-request@v0.5.3 + uses: devops-infra/action-pull-request@v0.5.5 with: github_token: ${{ secrets.GITHUB_TOKEN }} source_branch: main From 64dadc712e6e0447cf7a2f8de409c44e408633b6 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 14 Feb 2023 14:27:49 -0500 Subject: [PATCH 73/83] Update to use REAL32 --- MAPL_cfio/ShaveMantissa_py.F90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/MAPL_cfio/ShaveMantissa_py.F90 b/MAPL_cfio/ShaveMantissa_py.F90 index 023e0dddc5b..b6dd6433fa1 100644 --- a/MAPL_cfio/ShaveMantissa_py.F90 +++ b/MAPL_cfio/ShaveMantissa_py.F90 @@ -3,16 +3,17 @@ subroutine Shave32 ( a_shaved, a, n, xbits, has_undef, undef, chunksize, rc ) ! ! Simple cover for f2py. ! + use iso_fortran_env, only: REAL32 implicit NONE - integer, intent(in) :: n ! array size - real(kind=4), intent(in) :: a(n) ! array to be shaved, usually 2D - integer, intent(in) :: xbits ! number of mantissa bits to zero (out of 24) - integer, intent(in) :: has_undef ! set to 1 if undef is present, 0 otherwise - real(kind=4), intent(in) :: undef ! undef value - integer, intent(in) :: chunksize ! find mid-range over chunksizes - - real(kind=4), intent(out) :: a_shaved(n) ! shaved array - integer, intent(out) :: rc ! error code + integer, intent(in) :: n ! array size + real(kind=REAL32), intent(in) :: a(n) ! array to be shaved, usually 2D + integer, intent(in) :: xbits ! number of mantissa bits to zero (out of 24) + integer, intent(in) :: has_undef ! set to 1 if undef is present, 0 otherwise + real(kind=REAL32), intent(in) :: undef ! undef value + integer, intent(in) :: chunksize ! find mid-range over chunksizes + + real(kind=REAL32), intent(out) :: a_shaved(n) ! shaved array + integer, intent(out) :: rc ! error code ! --- From 59f2349c58c0c1661968fc45be8d3e2a5920317f Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 15 Feb 2023 13:09:52 -0500 Subject: [PATCH 74/83] add variable through file formatter --- pfio/NetCDF4_FileFormatter.F90 | 24 ++++++++++++++- pfio/tests/Test_NetCDF4_FileFormatter.pf | 38 ++++++++++++++++++++++++ 2 files changed, 61 insertions(+), 1 deletion(-) diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index b7442380403..c281aad3445 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -39,6 +39,7 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: close procedure :: read procedure :: write + procedure :: add_variable #include "new_overload.macro" procedure :: ___SUB(get_var,int32,0) @@ -656,12 +657,27 @@ subroutine put_var_attributes(this, var, varid, unusable, rc) end subroutine put_var_attributes + subroutine add_variable(this, cf, varname, unusable, rc) + class (NetCDF4_FileFormatter), intent(inout) :: this + type (FileMetadata), target, intent(in) :: cf + character(*), intent(in) :: varname + class (KeywordEnforcer), optional, intent(in) :: unusable + !integer, optional, intent(in) :: chunksizes(:) + integer, optional, intent(out) :: rc + integer:: status + + call this%def_variables(cf, varname=varname, _RC) + _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) + + end subroutine add_variable - subroutine def_variables(this, cf, unusable, rc) + subroutine def_variables(this, cf, unusable, varname, rc) class (NetCDF4_FileFormatter), intent(inout) :: this type (FileMetadata), target, intent(in) :: cf class (KeywordEnforcer), optional, intent(in) :: unusable !integer, optional, intent(in) :: chunksizes(:) + character(*), optional,intent(in) :: varname integer, optional, intent(out) :: rc integer :: status @@ -693,6 +709,12 @@ subroutine def_variables(this, cf, unusable, rc) var_iter = order%begin() do while (var_iter /= order%end()) var_name => var_iter%get() + if ( present (varname)) then + if (var_name /= varname) then + call var_iter%next() + cycle + endif + endif var => vars%at(var_name) xtype = get_xtype(var%get_type(),rc=status) _VERIFY(status) diff --git a/pfio/tests/Test_NetCDF4_FileFormatter.pf b/pfio/tests/Test_NetCDF4_FileFormatter.pf index 2b2c2af857e..1e077377c67 100644 --- a/pfio/tests/Test_NetCDF4_FileFormatter.pf +++ b/pfio/tests/Test_NetCDF4_FileFormatter.pf @@ -137,4 +137,42 @@ contains end subroutine test_write_read_variable_attribute + @test + subroutine test_add_variable() + type (NetCDF4_FileFormatter) :: formatter + type (FileMetadata) :: cf_expected + type (FileMetadata) :: cf_found + type (Variable) :: v,v1 + integer :: status + +! call cf_expected%add_dimension('x',1) +! call cf_expected%add_dimension('y',2) + +! v = Variable(type=pFIO_INT32, dimensions='x,y') +! call v%add_attribute('attr', [1.,2.,3.]) +! call cf_expected%add_variable('var', v) +! + call formatter%create('test.nc', rc=status) +! @assertEqual(NF90_NOERR, status) +! call formatter%write(cf_expected, rc=status) +! @assertEqual(0, NF90_NOERR) +! +! v1 = Variable(type=pFIO_INT32, dimensions='x,y') +! call cf_expected%add_variable('new_var', v1) +! +! call formatter%add_variable(cf_expected,'new_var', rc=status) +! + call formatter%close(rc=status) +! @assertEqual(0, NF90_NOERR) +! +! call formatter%open('test.nc4', mode=NF90_NOWRITE, rc=status) +! @assertEqual(0, NF90_NOERR) +! cf_found = formatter%read(rc=status) +! call formatter%close(rc=status) +! @assertEqual(0, NF90_NOERR) +! +! @assertTrue(cf_expected == cf_found) + + end subroutine test_add_variable + end module Test_NetCDF4_FileFormatter From 0fc8f9263ef64fa7210448df9abd3ff2dffd877d Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Wed, 15 Feb 2023 13:23:12 -0500 Subject: [PATCH 75/83] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 16105df6b8b..297d740cf83 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 a subroutine add_variable to Netcdf4_Fileformatter - Created layout independent version of the "DownBit"/"pFIO_ShaveMantissa" routines when running in MPI codes - Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This provides a convenient local solar hour angle diagnostic which will be used to detect local From 46df44c1f1b86900cf94c3f43db5672ecef0137e Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 15 Feb 2023 14:38:07 -0500 Subject: [PATCH 76/83] tests pass for intel ifort --- pfio/tests/Test_NetCDF4_FileFormatter.pf | 48 ++++++++++++------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/pfio/tests/Test_NetCDF4_FileFormatter.pf b/pfio/tests/Test_NetCDF4_FileFormatter.pf index 1e077377c67..7a7332b5963 100644 --- a/pfio/tests/Test_NetCDF4_FileFormatter.pf +++ b/pfio/tests/Test_NetCDF4_FileFormatter.pf @@ -145,33 +145,33 @@ contains type (Variable) :: v,v1 integer :: status -! call cf_expected%add_dimension('x',1) -! call cf_expected%add_dimension('y',2) + call cf_expected%add_dimension('x',1) + call cf_expected%add_dimension('y',2) + + v = Variable(type=pFIO_INT32, dimensions='x,y') + call v%add_attribute('attr', [1.,2.,3.]) + call cf_expected%add_variable('var', v) -! v = Variable(type=pFIO_INT32, dimensions='x,y') -! call v%add_attribute('attr', [1.,2.,3.]) -! call cf_expected%add_variable('var', v) -! call formatter%create('test.nc', rc=status) -! @assertEqual(NF90_NOERR, status) -! call formatter%write(cf_expected, rc=status) -! @assertEqual(0, NF90_NOERR) -! -! v1 = Variable(type=pFIO_INT32, dimensions='x,y') -! call cf_expected%add_variable('new_var', v1) -! -! call formatter%add_variable(cf_expected,'new_var', rc=status) -! + @assertEqual(NF90_NOERR, status) + call formatter%write(cf_expected, rc=status) + @assertEqual(0, NF90_NOERR) + + v1 = Variable(type=pFIO_INT32, dimensions='x,y') + call cf_expected%add_variable('new_var', v1) + + call formatter%add_variable(cf_expected,'new_var', rc=status) + + call formatter%close(rc=status) + @assertEqual(0, NF90_NOERR) + + call formatter%open('test.nc', mode=NF90_NOWRITE, rc=status) + @assertEqual(0, NF90_NOERR) + cf_found = formatter%read(rc=status) call formatter%close(rc=status) -! @assertEqual(0, NF90_NOERR) -! -! call formatter%open('test.nc4', mode=NF90_NOWRITE, rc=status) -! @assertEqual(0, NF90_NOERR) -! cf_found = formatter%read(rc=status) -! call formatter%close(rc=status) -! @assertEqual(0, NF90_NOERR) -! -! @assertTrue(cf_expected == cf_found) + @assertEqual(0, NF90_NOERR) + + @assertTrue(cf_expected == cf_found) end subroutine test_add_variable From 5fcdba8f80bf1d95b07b795825859a1b286d4463 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 16 Feb 2023 22:54:03 -0500 Subject: [PATCH 77/83] add redef and enddef to add variable when open --- pfio/NetCDF4_FileFormatter.F90 | 7 +++++-- pfio/tests/Test_NetCDF4_FileFormatter.pf | 6 ++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index c281aad3445..ef881a996f1 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -665,8 +665,12 @@ subroutine add_variable(this, cf, varname, unusable, rc) !integer, optional, intent(in) :: chunksizes(:) integer, optional, intent(out) :: rc integer:: status - + + status=nf90_redef(this%ncid) + _VERIFY(status) call this%def_variables(cf, varname=varname, _RC) + status=nf90_enddef(this%ncid) + _VERIFY(status) _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) @@ -732,7 +736,6 @@ subroutine def_variables(this, cf, unusable, varname, rc) idim = idim + 1 end do _VERIFY(status) - !$omp critical status = nf90_def_var(this%ncid, var_name, xtype, dimids, varid) !$omp end critical diff --git a/pfio/tests/Test_NetCDF4_FileFormatter.pf b/pfio/tests/Test_NetCDF4_FileFormatter.pf index 7a7332b5963..3ad19ac9ddb 100644 --- a/pfio/tests/Test_NetCDF4_FileFormatter.pf +++ b/pfio/tests/Test_NetCDF4_FileFormatter.pf @@ -156,12 +156,14 @@ contains @assertEqual(NF90_NOERR, status) call formatter%write(cf_expected, rc=status) @assertEqual(0, NF90_NOERR) + call formatter%close(rc=status) + @assertEqual(0, NF90_NOERR) + call formatter%open('test.nc', mode=NF90_WRITE, rc=status) + @assertEqual(NF90_NOERR, status) v1 = Variable(type=pFIO_INT32, dimensions='x,y') call cf_expected%add_variable('new_var', v1) - call formatter%add_variable(cf_expected,'new_var', rc=status) - call formatter%close(rc=status) @assertEqual(0, NF90_NOERR) From 41a816ab6be174e3c6a09f4a331565b14a672d75 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 23 Feb 2023 09:48:05 -0500 Subject: [PATCH 78/83] add a routine to calculate spherical areas to our spherical geometry package (needed for a utility I created related to my topography generation workflow) --- CHANGELOG.md | 1 + base/Base.F90 | 1 + base/MAPL_SphericalGeometry.F90 | 87 +++++++++++++++++++++++++++++++++ 3 files changed, 89 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6375c9eff44..58883d850a0 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 +- Add a function to get the area of a spherical polygon to the spherical geometry module - Created layout independent version of the "DownBit"/"pFIO_ShaveMantissa" routines when running in MPI codes - Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This provides a convenient local solar hour angle diagnostic which will be used to detect local diff --git a/base/Base.F90 b/base/Base.F90 index 012aedc8b79..5413bcafbba 100644 --- a/base/Base.F90 +++ b/base/Base.F90 @@ -52,6 +52,7 @@ module MAPLBase_Mod use MAPL_FileMetadataUtilsMod use MAPL_VerticalDataMod use MAPL_FieldUtilities + use MAPL_SphericalGeometry logical, save, private :: mapl_is_initialized = .false. end module MAPLBase_Mod diff --git a/base/MAPL_SphericalGeometry.F90 b/base/MAPL_SphericalGeometry.F90 index 8cadc85c3d1..7e61564bb07 100644 --- a/base/MAPL_SphericalGeometry.F90 +++ b/base/MAPL_SphericalGeometry.F90 @@ -9,8 +9,46 @@ module MAPL_SphericalGeometry implicit none private public get_points_in_spherical_domain +public get_area_spherical_polygon contains + ! get area of spherical rectangle given the four corners + ! p4 ------ p3 + ! | | + ! | | + ! | | + ! p1 ------ p2 + function get_area_spherical_polygon(p1,p4,p2,p3) result(area) + real(real64) :: area + real(real64), intent(in) :: p1(2),p2(2),p3(2),p4(2) + + real(real64) :: e1(3),e2(3),e3(3) + real(real64) :: ang1,ang2,ang3,ang4 + + e1 = convert_to_cart(p1) + e2 = convert_to_cart(p2) + e3 = convert_to_cart(p4) + ang1 = spherical_angles(e1, e2, e3) + + e1 = convert_to_cart(p2) + e2 = convert_to_cart(p3) + e3 = convert_to_cart(p1) + ang2 = spherical_angles(e1, e2, e3) + + e1 = convert_to_cart(p3) + e2 = convert_to_cart(p4) + e3 = convert_to_cart(p2) + ang3 = spherical_angles(e1, e2, e3) + + e1 = convert_to_cart(p4) + e2 = convert_to_cart(p3) + e3 = convert_to_cart(p1) + ang4 = spherical_angles(e1, e2, e3) + + area = ang1 + ang2 + ang3 + ang4 - 2.0d0*MAPL_PI_R8 + + end function get_area_spherical_polygon + subroutine get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,lons,lats,ii,jj,rc) real(real64), intent(in) :: center_lats(:,:),center_lons(:,:) real(real64), intent(in) :: corner_lats(:,:),corner_lons(:,:) @@ -217,4 +255,53 @@ function vect_mag(v) result(mag) mag = sqrt(v(1)*v(1)+v(2)*v(2)+v(3)*v(3)) end function vect_mag +function spherical_angles(p1,p2,p3) result(spherical_angle) + real(real64) :: spherical_angle + real(real64), intent(in) :: p1(3),p2(3),p3(3) + + real (real64):: e1(3), e2(3), e3(3) + real (real64):: px, py, pz + real (real64):: qx, qy, qz + real (real64):: angle, ddd + integer n + + do n=1,3 + e1(n) = p1(n) + e2(n) = p2(n) + e3(n) = p3(n) + enddo + + !------------------------------------------------------------------- + ! Page 41, Silverman's book on Vector Algebra; spherical trigonmetry + !------------------------------------------------------------------- + ! Vector P: + px = e1(2)*e2(3) - e1(3)*e2(2) + py = e1(3)*e2(1) - e1(1)*e2(3) + pz = e1(1)*e2(2) - e1(2)*e2(1) + ! Vector Q: + qx = e1(2)*e3(3) - e1(3)*e3(2) + qy = e1(3)*e3(1) - e1(1)*e3(3) + qz = e1(1)*e3(2) - e1(2)*e3(1) + + ddd = (px*px+py*py+pz*pz)*(qx*qx+qy*qy+qz*qz) + + if ( ddd <= 0.0d0 ) then + angle = 0.d0 + else + ddd = (px*qx+py*qy+pz*qz) / sqrt(ddd) + if ( abs(ddd)>1.d0) then + angle = 0.5d0 * MAPL_PI_R8 + if (ddd < 0.d0) then + angle = MAPL_PI_R8 + else + angle = 0.d0 + end if + else + angle = acos( ddd ) + endif + endif + + spherical_angle = angle +end function + end module MAPL_SphericalGeometry From 6fc79f51b1012686f89e5982873b893c2c9fab8d Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 24 Feb 2023 08:55:36 -0500 Subject: [PATCH 79/83] fixed and added subroutines to read and write char type in Netcdf file --- CHANGELOG.md | 1 + pfio/NetCDF4_FileFormatter.F90 | 22 +++++++++++++++++++++- pfio/new_overload.macro | 3 ++- 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 58883d850a0..83a5308565d 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 subroutines to read char type in Netcdf - Add a function to get the area of a spherical polygon to the spherical geometry module - Created layout independent version of the "DownBit"/"pFIO_ShaveMantissa" routines when running in MPI codes - Added subroutine `MAPL_SunGetLocalSolarHourAngle()` in `base/MAPL_sun_uc.F90`. This diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index b7442380403..6109f2ae1d4 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -41,6 +41,10 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: write #include "new_overload.macro" + + procedure :: ___SUB(get_var,chars ,0) + procedure :: ___SUB(get_var,chars,1) + procedure :: ___SUB(get_var,int32,0) procedure :: ___SUB(get_var,int32,1) procedure :: ___SUB(get_var,int32,2) @@ -62,6 +66,8 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(get_var,real64,3) procedure :: ___SUB(get_var,real64,4) + procedure :: ___SUB(put_var,chars,0) + procedure :: ___SUB(put_var,chars,1) procedure :: ___SUB(put_var,int32,0) procedure :: ___SUB(put_var,int32,1) procedure :: ___SUB(put_var,int32,2) @@ -84,6 +90,8 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(put_var,real64,4) + generic :: get_var => ___SUB(get_var,chars ,0) + generic :: get_var => ___SUB(get_var,chars ,1) generic :: get_var => ___SUB(get_var,int32,0) generic :: get_var => ___SUB(get_var,int32,1) generic :: get_var => ___SUB(get_var,int32,2) @@ -105,6 +113,8 @@ 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,chars ,0) + generic :: put_var => ___SUB(put_var,chars ,1) generic :: put_var => ___SUB(put_var,int32,0) generic :: put_var => ___SUB(put_var,int32,1) generic :: put_var => ___SUB(put_var,int32,2) @@ -1279,10 +1289,20 @@ end subroutine inq_variables # undef _RANK #undef _VARTYPE + ! 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" +# undef _RANK +#undef _VARTYPE #undef _TYPE - ! Kludge to support parallel write with UNLIMITED dimension integer function inq_dim(this, dim_name, unusable, rc) result(length) class (NetCDF4_FileFormatter), intent(in) :: this diff --git a/pfio/new_overload.macro b/pfio/new_overload.macro index b0419176e0a..5133774a638 100644 --- a/pfio/new_overload.macro +++ b/pfio/new_overload.macro @@ -53,7 +53,8 @@ #if (_VARTYPE == 0) #define _MPITYPE MPI_BYTE -#define _TYPEKIND character(len=*) +#define _TYPEDECLARE character(len=*) +#define _TYPEKIND chars #define _TYPEKINDSTR 'STRING' #elif (_VARTYPE == 1) From 92af3b227f78bc67e8fee9161a356f428fb42761 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 24 Feb 2023 11:11:04 -0500 Subject: [PATCH 80/83] avoid GNU name conflict --- pfio/NetCDF4_FileFormatter.F90 | 18 ++++++++---------- pfio/new_overload.macro | 2 +- 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index 6109f2ae1d4..6c18f3c0ed2 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -42,8 +42,8 @@ module pFIO_NetCDF4_FileFormatterMod #include "new_overload.macro" - procedure :: ___SUB(get_var,chars ,0) - procedure :: ___SUB(get_var,chars,1) + procedure :: ___SUB(get_var,string ,0) + procedure :: ___SUB(get_var,string,1) procedure :: ___SUB(get_var,int32,0) procedure :: ___SUB(get_var,int32,1) @@ -66,8 +66,8 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(get_var,real64,3) procedure :: ___SUB(get_var,real64,4) - procedure :: ___SUB(put_var,chars,0) - procedure :: ___SUB(put_var,chars,1) + procedure :: ___SUB(put_var,string,0) + procedure :: ___SUB(put_var,string,1) procedure :: ___SUB(put_var,int32,0) procedure :: ___SUB(put_var,int32,1) procedure :: ___SUB(put_var,int32,2) @@ -90,8 +90,8 @@ module pFIO_NetCDF4_FileFormatterMod procedure :: ___SUB(put_var,real64,4) - generic :: get_var => ___SUB(get_var,chars ,0) - generic :: get_var => ___SUB(get_var,chars ,1) + 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) generic :: get_var => ___SUB(get_var,int32,2) @@ -113,8 +113,8 @@ 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,chars ,0) - generic :: put_var => ___SUB(put_var,chars ,1) + 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) generic :: put_var => ___SUB(put_var,int32,2) @@ -1301,8 +1301,6 @@ end subroutine inq_variables # undef _RANK #undef _VARTYPE -#undef _TYPE - ! Kludge to support parallel write with UNLIMITED dimension integer function inq_dim(this, dim_name, unusable, rc) result(length) class (NetCDF4_FileFormatter), intent(in) :: this diff --git a/pfio/new_overload.macro b/pfio/new_overload.macro index 5133774a638..169b999fcda 100644 --- a/pfio/new_overload.macro +++ b/pfio/new_overload.macro @@ -54,7 +54,7 @@ #if (_VARTYPE == 0) #define _MPITYPE MPI_BYTE #define _TYPEDECLARE character(len=*) -#define _TYPEKIND chars +#define _TYPEKIND string #define _TYPEKINDSTR 'STRING' #elif (_VARTYPE == 1) From 80c23a79040d39948a683385274e653bdbe6c6de Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 27 Feb 2023 17:12:08 -0500 Subject: [PATCH 81/83] Let users specify the grid type --- CHANGELOG.md | 1 + gridcomps/Cap/MAPL_CapGridComp.F90 | 15 ++++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 58883d850a0..a9c5ff91b2f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Changed set_grid method so users have a chance to specify the grid type - Renamed `get_regrid_method` and `translate_regrid_method` to `regrid_method_string_to_int` and `regrid_method_int_to_string` respectively in `RegridMethods.F90`. This was done so we could add `get_regrid_method` to the AbstractRegridder. The new names more accurately reflect what the RegridMethods functions do. diff --git a/gridcomps/Cap/MAPL_CapGridComp.F90 b/gridcomps/Cap/MAPL_CapGridComp.F90 index def72d16efb..8145f6c19d7 100644 --- a/gridcomps/Cap/MAPL_CapGridComp.F90 +++ b/gridcomps/Cap/MAPL_CapGridComp.F90 @@ -1453,19 +1453,32 @@ subroutine set_grid(this, grid, unusable, lm, grid_type, rc) type(ESMF_Grid) :: mapl_grid type(ExternalGridFactory) :: external_grid_factory integer :: status + character(len=ESMF_MAXSTR):: grid_type_ + _UNUSED_DUMMY(unusable) external_grid_factory = ExternalGridFactory(grid=grid, lm=lm, _RC) mapl_grid = grid_manager%make_grid(external_grid_factory, _RC) ! grid_type is an optional parameter that allows GridType to be set explicitly. + call ESMF_ConfigGetAttribute(this%cf_root, value = grid_type_, Label="GridType:", default="", _RC) if (present(grid_type)) then + if(grid_type_ /= "") then + _ASSERT(grid_type_ == grid_type, "The grid types don't match") + endif if (grid_manager%is_valid_prototype(grid_type)) then call ESMF_AttributeSet(mapl_grid, 'GridType', grid_type, _RC) else _RETURN(_FAILURE) end if - end if + else if (grid_type_ /= "") then + if (grid_manager%is_valid_prototype(grid_type_)) then + call ESMF_AttributeSet(mapl_grid, 'GridType', grid_type_, _RC) + else + _RETURN(_FAILURE) + end if + endif + call ESMF_GridCompSet(this%gc, grid=mapl_grid, _RC) _RETURN(_SUCCESS) From b236885265afcf37ad4558eb61902ea002d795ff Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Tue, 28 Feb 2023 11:09:02 -0500 Subject: [PATCH 82/83] Update NetCDF4_FileFormatter.F90 --- pfio/NetCDF4_FileFormatter.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index 4bc721b9283..cda0e7f878a 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -43,7 +43,7 @@ module pFIO_NetCDF4_FileFormatterMod #include "new_overload.macro" - procedure :: ___SUB(get_var,string ,0) + procedure :: ___SUB(get_var,string,0) procedure :: ___SUB(get_var,string,1) procedure :: ___SUB(get_var,int32,0) From 01377457ab7b5d0f249a3fdb1e289085152cb9a0 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 28 Feb 2023 14:04:05 -0500 Subject: [PATCH 83/83] Prepare for 2.35.0 Release --- CHANGELOG.md | 20 ++++++++++++++------ CMakeLists.txt | 2 +- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7bb47c38d32..82e2c24b6d3 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.35.0] - 2023-03-01 + +### Added + - Added subroutines to read char type in Netcdf - Added a subroutine add_variable to Netcdf4_Fileformatter - Add a function to get the area of a spherical polygon to the spherical geometry module @@ -24,7 +36,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed -- Changed set_grid method so users have a chance to specify the grid type +- Changed set_grid method so users have a chance to specify the grid type - Renamed `get_regrid_method` and `translate_regrid_method` to `regrid_method_string_to_int` and `regrid_method_int_to_string` respectively in `RegridMethods.F90`. This was done so we could add `get_regrid_method` to the AbstractRegridder. The new names more accurately reflect what the RegridMethods functions do. @@ -43,7 +55,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed -- Changed the type of output counters to INT64 for large file. +- Changed the type of output counters to INT64 for large file. - Tested optional arguments arrdes in MAPL_WriteVars - Added the correct values to halo corner of LatLon grid - Fixed range in halo of LatLonGridFactory @@ -52,10 +64,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Fix bug in `mapl_acg.cmake` that caused unnecessary rebuilds - Fixed error handling for refactored MAPL_GetResource -### Removed - -### Deprecated - ## [2.34.3] - 2023-02-14 ### Added diff --git a/CMakeLists.txt b/CMakeLists.txt index 632ca280074..1749a95cf39 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,7 +4,7 @@ cmake_policy (SET CMP0054 NEW) project ( MAPL - VERSION 2.34.3 + VERSION 2.35.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the default build type to release