From 353f9f9337636e37842f993a6a5bc3d6dd5c6dab Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 31 Aug 2023 15:55:23 -0400 Subject: [PATCH 01/13] Convert all uses of mpif.h to use mpi --- Apps/Regrid_Util.F90 | 3 +- CHANGELOG.md | 1 + MAPL_cfio/ESMF_CFIOUtilMod.F90 | 522 ++++++++++----------- Tests/ExtDataDriverGridComp.F90 | 51 +- base/BinIO.F90 | 27 +- base/FileIOShared.F90 | 3 +- base/MAPL_CFIO.F90 | 363 +++++++------- base/MAPL_Comms.F90 | 3 +- base/MAPL_LlcGridFactory.F90 | 102 ++-- base/MAPL_LocStreamMod.F90 | 243 +++++----- base/MAPL_MemUtils.F90 | 3 +- base/MAPL_TripolarGridFactory.F90 | 106 ++--- base/NCIO.F90 | 26 +- base/cub2latlon_regridder.F90 | 2 - generic/MAPL_Generic.F90 | 44 +- gridcomps/Cap/MAPL_CapGridComp.F90 | 17 +- gridcomps/Cap/MAPL_NUOPCWrapperMod.F90 | 3 +- gridcomps/History/MAPL_HistoryGridComp.F90 | 7 +- pfio/NetCDF4_FileFormatter.F90 | 6 +- shared/Shmem/Shmem.F90 | 3 +- 20 files changed, 757 insertions(+), 778 deletions(-) diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index cb7aa8bd8395..7a247d05c615 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -325,14 +325,13 @@ Program Regrid_Util use MAPL_FileMetadataUtilsMod use gFTL_StringVector use regrid_util_support_mod + use mpi implicit NONE type(DistributedProfiler), target :: t_prof type (ProfileReporter) :: reporter - include "mpif.h" - call main() CONTAINS diff --git a/CHANGELOG.md b/CHANGELOG.md index 64d5dc1697f8..54f13d2dbb7b 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 - Modified tilegrid creation to use index flag ESMF_INDEX_DELOCAL instead of ESMF_INDEX_USER - Renamed "geom" subdir and library to "field_utils" - Updated CircleCI to use v11.2.0 bcs +- Converted all uses of `mpif.h` to `use mpi` ### Fixed diff --git a/MAPL_cfio/ESMF_CFIOUtilMod.F90 b/MAPL_cfio/ESMF_CFIOUtilMod.F90 index f2cefbd58497..0860ce4a0cef 100644 --- a/MAPL_cfio/ESMF_CFIOUtilMod.F90 +++ b/MAPL_cfio/ESMF_CFIOUtilMod.F90 @@ -438,23 +438,23 @@ subroutine CFIO_DimInquire (fid,im,jm,km,lm,nvars,ngatts,vdir,rc) integer lm !! Number of times integer nvars !! Number of variables integer ngatts !! Number of global attributes - integer, optional :: vdir !! Positive vertical direction. - !! If `-1`, level 1 in the file is TOA. - !! If `1`, level 1 in the file is the surface. + integer, optional :: vdir !! Positive vertical direction. + !! If `-1`, level 1 in the file is TOA. + !! If `1`, level 1 in the file is the surface. !! If `0`, the file has no vertical co-ordinate (default). - integer, optional :: rc !! Error return code: - !! rc = 0 all is well - !! rc = -19 unable to identify coordinate variable - !! - !! NetCDF Errors - !! ------------- - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -47 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (time) - !! rc = -48 error from NF90_INQUIRE - !! rc = -53 error from NF90_GET_ATT + integer, optional :: rc !! Error return code: + !! rc = 0 all is well + !! rc = -19 unable to identify coordinate variable + !! + !! NetCDF Errors + !! ------------- + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -47 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (time) + !! rc = -48 error from NF90_INQUIRE + !! rc = -53 error from NF90_GET_ATT ! !------------------------------------------------------------------------- @@ -634,7 +634,7 @@ subroutine GetDateTimeVec ( fid, begDate, begTime, incVec, rc ) integer :: begDate !! Beginning date integer :: begTime !! Beginning time integer(Kind=INT64) :: incVec(:) !! Vector of offsets (seconds) - integer :: rc !! error return code + integer :: rc !! error return code ! !------------------------------------------------------------------------- @@ -1232,9 +1232,9 @@ subroutine CFIO_Open ( fname, fmode, fid, rc ) ! integer fid !! File handle - integer rc !! Error return code: - !! rc = 0 All is well - !! rc = -39 error from ncopn (file open) + integer rc !! Error return code: + !! rc = 0 All is well + !! rc = -39 error from ncopn (file open) ! !------------------------------------------------------------------------- @@ -1278,12 +1278,12 @@ subroutine CFIO_Close ( fid, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! - !! NetCDF Errors - !! ------------- - !! rc = -54 error from ncclos (file close) + integer rc !! Error return code: + !! rc = 0 all is well + !! + !! NetCDF Errors + !! ------------- + !! rc = -54 error from ncclos (file close) ! !------------------------------------------------------------------------- @@ -1327,15 +1327,15 @@ subroutine CFIO_PutIntAtt ( fid, name, count, buf, prec, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -12 error determining default precision - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -55 error from NF90_REDEF (enter define mode) - !! rc = -56 error from NF90_ENDDEF (exit define mode) + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -12 error determining default precision + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -55 error from NF90_REDEF (enter define mode) + !! rc = -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------- @@ -1420,15 +1420,15 @@ subroutine CFIO_PutRealAtt ( fid, name, count, buf, prec, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -12 error determining default precision - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -55 error from NF90_REDEF (enter define mode) - !! rc = -56 error from NF90_ENDDEF (exit define mode) + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -12 error determining default precision + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -55 error from NF90_REDEF (enter define mode) + !! rc = -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------- @@ -1511,14 +1511,14 @@ subroutine CFIO_PutCharAtt ( fid, name, count, buf, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -55 error from NF90_REDEF (enter define mode) - !! rc = -56 error from NF90_ENDDEF (exit define mode) + integer rc !! Error return code: + !! rc = 0 all is well + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -55 error from NF90_REDEF (enter define mode) + !! rc = -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------- @@ -1570,15 +1570,15 @@ subroutine CFIO_GetAttNames ( fid, ngatts, aname, rc ) ! !OUTPUT PARAMETERS: ! character*(*) aname(ngatts) !! Array of attribute names - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -10 ngatts is incompatible with file - !! rc = -11 character string not long enough - !! - !! NetCDF Errors - !! ------------- - !! rc = -48 error from NF90_INQUIRE - !! rc = -57 error from NF90_INQ_ATTNAME + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -10 ngatts is incompatible with file + !! rc = -11 character string not long enough + !! + !! NetCDF Errors + !! ------------- + !! rc = -48 error from NF90_INQUIRE + !! rc = -57 error from NF90_INQ_ATTNAME ! !------------------------------------------------------------------------- @@ -1658,20 +1658,20 @@ subroutine CFIO_AttInquire ( fid, name, type, count, rc ) ! ! !OUTPUT PARAMETERS: ! - integer type !! Code for attribute type - !! 0 = integer - !! 1 = real - !! 2 = character - !! 3 = 64-bit real - !! 4 = 64-bit integer - !! -1 = other + integer type !! Code for attribute type + !! 0 = integer + !! 1 = real + !! 2 = character + !! 3 = 64-bit real + !! 4 = 64-bit integer + !! -1 = other integer count !! Number of items (length of array) - integer rc !! Error return code: - !! rc = 0 all is well - !! - !! NetCDF Errors - !! ------------- - !! rc = -58 error from NF90_INQUIRE_ATTRIBUTE + integer rc !! Error return code: + !! rc = 0 all is well + !! + !! NetCDF Errors + !! ------------- + !! rc = -58 error from NF90_INQUIRE_ATTRIBUTE ! !------------------------------------------------------------------------- @@ -1731,17 +1731,17 @@ subroutine CFIO_GetIntAtt ( fid, name, count, buf, rc ) ! !OUTPUT PARAMETERS: ! integer buf(count) !! Buffer with integer values - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -1 invalid count - !! rc = -2 type mismatch - !! rc = -12 error determining default precision - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -51 error from NF90_GET_ATT (global attribute) - + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -1 invalid count + !! rc = -2 type mismatch + !! rc = -12 error determining default precision + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -51 error from NF90_GET_ATT (global attribute) + ! !------------------------------------------------------------------------- @@ -1835,16 +1835,16 @@ subroutine CFIO_GetRealAtt ( fid, name, count, buf, rc ) ! !OUTPUT PARAMETERS: ! real buf(count) !! Buffer with real values - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -1 invalid count - !! rc = -2 type mismatch - !! rc = -12 error determining default precision - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -51 error from NF90_GET_ATT (global attribute) + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -1 invalid count + !! rc = -2 type mismatch + !! rc = -12 error determining default precision + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -51 error from NF90_GET_ATT (global attribute) ! !------------------------------------------------------------------------- @@ -1939,15 +1939,15 @@ subroutine CFIO_GetCharAtt ( fid, name, count, buf, rc ) ! character :: buf(count) !! Buffer with character values ! character(len=MLEN) :: buf !! Buffer with character values - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -1 invalid count - !! rc = -2 type mismatch - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -51 error from NF90_GET_ATT (global attribute) + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -1 invalid count + !! rc = -2 type mismatch + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -51 error from NF90_GET_ATT (global attribute) ! !------------------------------------------------------------------------- @@ -2212,9 +2212,9 @@ subroutine ParseTimeUnits ( TimeUnits, year, month, day, hour, min, sec, rc ) integer hour !! hour integer min !! minute integer sec !! second - integer rc !! return code - !! 0 = no error - !! -1 = problem parsing string + integer rc !! return code + !! 0 = no error + !! -1 = problem parsing string ! !------------------------------------------------------------------------- @@ -2316,7 +2316,7 @@ end subroutine ParseTimeUnits ! minute boundaries to allow GrADS to work. Error checking is ! done for dimensions that are out of bounds. ! -!#### History +!#### History !- 1997.10.13 da Silva/Lucchesi Initial interface design. !- 1998.02.10 Lucchesi Added support for applications running with 64-bit reals. !- 1998.03.30 Lucchesi Documentation expanded. Clean-up of code. @@ -2352,32 +2352,32 @@ subroutine CFIO_SPutVar ( fid, vname, yyyymmdd, hhmmss, & ! !OUTPUT PARAMETERS: - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! - !! NetCDF Errors - !! ------------- - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_PUT_VAR - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! + !! NetCDF Errors + !! ------------- + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_PUT_VAR + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT ! !------------------------------------------------------------------------- @@ -2732,29 +2732,29 @@ subroutine CFIO_SGetVar ( fid, vname, yyyymmdd, hhmmss,& ! !OUTPUT PARAMETERS: ! real grid(im,kount) !! Gridded data read for this time - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! - !! NetCDF Errors - !! ------------- - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! + !! NetCDF Errors + !! ------------- + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------- @@ -3100,29 +3100,29 @@ subroutine CFIO_GetVar ( fid, vname, yyyymmdd, hhmmss,& ! !OUTPUT PARAMETERS: ! real grid(im,jm,kount) !! Gridded data read for this time - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! - !! NetCDF Errors - !! ------------- - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! + !! NetCDF Errors + !! ------------- + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------- @@ -3361,7 +3361,7 @@ subroutine CFIO_GetVar ( fid, vname, yyyymmdd, hhmmss,& rc = NF90_GET_VAR(fid, vid, grid, corner, edges) if(rc /=0) then print*,'Error reading variable using NF90_GET_VAR',rc - print*, NF_STRERROR(rc) + print*, NF90_STRERROR(rc) return endif else if (type .EQ. NF90_DOUBLE) then ! 64-bit @@ -3506,32 +3506,32 @@ subroutine CFIO_PutVar ( fid, vname, yyyymmdd, hhmmss, & ! !OUTPUT PARAMETERS: - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! - !! NetCDF Errors - !! ------------- - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_PUT_VAR - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! + !! NetCDF Errors + !! ------------- + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_PUT_VAR + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT ! !------------------------------------------------------------------------- @@ -4640,12 +4640,12 @@ subroutine EOS_Close ( fid, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! - !! NetCDF Errors - !! ------------- - !! rc = -54 error from ncclos (file close) + integer rc !! Error return code: + !! rc = 0 all is well + !! + !! NetCDF Errors + !! ------------- + !! rc = -54 error from ncclos (file close) ! !------------------------------------------------------------------------- @@ -4814,15 +4814,15 @@ subroutine EOS_PutRealAtt ( fid, name, count, buf, prec, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -12 error determining default precision - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -55 error from NF90_REDEF (enter define mode) - !! rc = -56 error from NF90_ENDDEF (exit define mode) + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -12 error determining default precision + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -55 error from NF90_REDEF (enter define mode) + !! rc = -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------- @@ -4908,7 +4908,7 @@ end subroutine EOS_PutRealAtt ! The routine `EOS_PutCharAtt` .... ! !#### History -!- 1998.07.30 Lucchesi Initial interface design. +!- 1998.07.30 Lucchesi Initial interface design. !- 1998.07.30 Lucchesi Initial coding. !- 1998.09.24 Lucchesi Changed error handling. !- 1999.01.29 Lucchesi Converted API to SD for HDFEOS @@ -4928,14 +4928,14 @@ subroutine EOS_PutCharAtt ( fid, name, count, buf, rc ) ! ! !OUTPUT PARAMETERS: ! - integer rc !! Error return code: - !! rc = 0 all is well - !! - !! NetCDF Errors - !! ------------- - !! rc = -36 error from NF90_PUT_ATT (global attribute) - !! rc = -55 error from NF90_REDEF (enter define mode) - !! rc = -56 error from NF90_ENDDEF (exit define mode) + integer rc !! Error return code: + !! rc = 0 all is well + !! + !! NetCDF Errors + !! ------------- + !! rc = -36 error from NF90_PUT_ATT (global attribute) + !! rc = -55 error from NF90_REDEF (enter define mode) + !! rc = -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------- @@ -5019,40 +5019,40 @@ subroutine EOS_PutVar ( fid, vname, yyyymmdd, hhmmss, & real grid(im,jm,kount) !! Gridded data to write at this time logical do_comp logical do_chunk - integer comp_num !! 1 -- COMP_CODE_RLE; 2 -- COMP_CODE_NBIT - !! 3 --COMP_CODE_SKPHUFF; 4 -- COMP_CODE_DEFLATE - !! 5 --COMP_CODE_SZIP + integer comp_num !! 1 -- COMP_CODE_RLE; 2 -- COMP_CODE_NBIT + !! 3 --COMP_CODE_SKPHUFF; 4 -- COMP_CODE_DEFLATE + !! 5 --COMP_CODE_SZIP ! !OUTPUT PARAMETERS: - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! - !! NetCDF Errors - !! ------------- - !! rc = -32 error detaching from grid - !! rc = -37 error attaching to grid (HDFEOS) - !! rc = -38 error from NF90_PUT_VAR (dimension variable) NOTUSED - !! rc = -40 variable not defined - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) NOTUSED - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) NOTUSED - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error reading time information - !! rc = -45 error writing data - !! rc = -52 error from NF90_INQUIRE_VARIABLE NOTUSED - !! rc = -53 error getting variable attributes + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! + !! NetCDF Errors + !! ------------- + !! rc = -32 error detaching from grid + !! rc = -37 error attaching to grid (HDFEOS) + !! rc = -38 error from NF90_PUT_VAR (dimension variable) NOTUSED + !! rc = -40 variable not defined + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) NOTUSED + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) NOTUSED + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error reading time information + !! rc = -45 error writing data + !! rc = -52 error from NF90_INQUIRE_VARIABLE NOTUSED + !! rc = -53 error getting variable attributes ! !------------------------------------------------------------------------- diff --git a/Tests/ExtDataDriverGridComp.F90 b/Tests/ExtDataDriverGridComp.F90 index 8316b006485a..0873a68c4c11 100644 --- a/Tests/ExtDataDriverGridComp.F90 +++ b/Tests/ExtDataDriverGridComp.F90 @@ -10,6 +10,7 @@ module ExtData_DriverGridCompMod use MAPL_ExtDataGridCompMod, only : ExtData1G_SetServices => SetServices use MAPL_HistoryGridCompMod, only : Hist_SetServices => SetServices use MAPL_Profiler, only : get_global_time_profiler, BaseProfiler + use mpi implicit none private @@ -53,8 +54,6 @@ module ExtData_DriverGridCompMod type :: MAPL_MetaComp_Wrapper type(MAPL_MetaComp), pointer :: ptr => null() end type MAPL_MetaComp_Wrapper - - include "mpif.h" contains @@ -153,7 +152,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) t_p => get_global_time_profiler() cap => get_CapGridComp_from_gc(gc) - maplobj => get_MetaComp_from_gc(gc) + maplobj => get_MetaComp_from_gc(gc) call ESMF_GridCompGet(gc, vm = cap%vm, rc = status) _VERIFY(status) @@ -191,26 +190,26 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call ESMF_ConfigGetAttribute(cap%config,cap%run_extdata,label="RUN_EXTDATA:",default=.true.) ! !RESOURCE_ITEM: string :: Name of ROOT's config file - call MAPL_GetResource(MAPLOBJ, ROOT_CF, "ROOT_CF:", default = "ROOT.rc", rc = status) + call MAPL_GetResource(MAPLOBJ, ROOT_CF, "ROOT_CF:", default = "ROOT.rc", rc = status) _VERIFY(status) ! !RESOURCE_ITEM: string :: Name to assign to the ROOT component - call MAPL_GetResource(MAPLOBJ, ROOT_NAME, "ROOT_NAME:", default = "ROOT", rc = status) + call MAPL_GetResource(MAPLOBJ, ROOT_NAME, "ROOT_NAME:", default = "ROOT", rc = status) _VERIFY(status) - ! !RESOURCE_ITEM: string :: Name of HISTORY's config file - call MAPL_GetResource(MAPLOBJ, HIST_CF, "HIST_CF:", default = "HISTORY.rc", rc = status) + ! !RESOURCE_ITEM: string :: Name of HISTORY's config file + call MAPL_GetResource(MAPLOBJ, HIST_CF, "HIST_CF:", default = "HISTORY.rc", rc = status) _VERIFY(status) ! !RESOURCE_ITEM: string :: Name of ExtData's config file call MAPL_GetResource(MAPLOBJ, EXTDATA_CF, "EXTDATA_CF:", default = 'ExtData.rc', rc = status) _VERIFY(status) - ! !RESOURCE_ITEM: string :: Control Timers + ! !RESOURCE_ITEM: string :: Control Timers call MAPL_GetResource(MAPLOBJ, enableTimers, "MAPL_ENABLE_TIMERS:", default = 'NO', rc = status) _VERIFY(status) - ! !RESOURCE_ITEM: string :: Control Memory Diagnostic Utility + ! !RESOURCE_ITEM: string :: Control Memory Diagnostic Utility call MAPL_GetResource(MAPLOBJ, enableMemUtils, "MAPL_ENABLE_MEMUTILS:", default='NO', rc = status) _VERIFY(status) call MAPL_GetResource(MAPLOBJ, MemUtilsMode, "MAPL_MEMUTILS_MODE:", default = MAPL_MemUtilsModeBase, rc = status) @@ -309,7 +308,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) root_set_services => cap%root_set_services - cap%root_id = MAPL_AddChild(MAPLOBJ, name = root_name, SS = root_set_services, rc = status) + cap%root_id = MAPL_AddChild(MAPLOBJ, name = root_name, SS = root_set_services, rc = status) _VERIFY(status) if (cap%run_hist) then @@ -317,7 +316,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) call MAPL_Set(MAPLOBJ, CF=CAP%CF_HIST, RC=STATUS) _VERIFY(STATUS) - cap%history_id = MAPL_AddChild( MAPLOBJ, name = 'HIST', SS = HIST_SetServices, rc = status) + cap%history_id = MAPL_AddChild( MAPLOBJ, name = 'HIST', SS = HIST_SetServices, rc = status) _VERIFY(status) end if @@ -335,7 +334,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) else cap%extdata_id = MAPL_AddChild (MAPLOBJ, name = 'EXTDATA', SS = ExtData1G_SetServices, _RC) end if - + end if ! Query MAPL for the the children's for GCS, IMPORTS, EXPORTS @@ -405,7 +404,7 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) !------------------------ call ESMF_GridCompInitialize (cap%gcs(cap%extdata_id), importState = cap%imports(cap%extdata_id), & - exportState = cap%exports(cap%extdata_id), & + exportState = cap%exports(cap%extdata_id), & clock = cap%clock, userRc = status) _VERIFY(status) @@ -420,10 +419,10 @@ subroutine initialize_gc(gc, import_state, export_state, clock, rc) _RETURN(ESMF_SUCCESS) end subroutine initialize_gc - + subroutine run_gc(gc, import, export, clock, rc) !ARGUMENTS: - type(ESMF_GridComp) :: GC ! Gridded component + type(ESMF_GridComp) :: GC ! Gridded component type(ESMF_State) :: import ! Import state type(ESMF_State) :: export ! Export state type(ESMF_Clock) :: clock ! The clock @@ -456,7 +455,7 @@ subroutine finalize_gc(gc, import_state, export_state, clock, rc) _UNUSED_DUMMY(import_state) _UNUSED_DUMMY(export_state) _UNUSED_DUMMY(clock) - + cap => get_CapGridComp_from_gc(gc) MAPLOBJ => get_MetaComp_from_gc(gc) @@ -520,9 +519,9 @@ end subroutine set_services subroutine initialize(this, rc) class(ExtData_DriverGridComp), intent(inout) :: this integer, optional, intent(out) :: rc - + integer :: status - + call ESMF_GridCompInitialize(this%gc, userRc = status) _VERIFY(status) _RETURN(ESMF_SUCCESS) @@ -546,9 +545,9 @@ end subroutine run subroutine finalize(this, rc) class(ExtData_DriverGridComp), intent(inout) :: this integer, optional, intent(out) :: rc - - integer :: status - + + integer :: status + call ESMF_GridCompFinalize(this%gc, rc = status) _VERIFY(status) _RETURN(ESMF_SUCCESS) @@ -577,7 +576,7 @@ function get_CapGridComp_from_gc(gc) result(cap) cap => cap_wrapper%ptr end function get_CapGridComp_from_gc - + function get_MetaComp_from_gc(gc) result(meta_comp) type(ESMF_GridComp), intent(inout) :: gc type(MAPL_MetaComp), pointer :: meta_comp @@ -591,7 +590,7 @@ end function get_MetaComp_from_gc subroutine run_MultipleTimes(gc, rc) type (ESMF_Gridcomp) :: gc integer, optional, intent(out) :: rc - + integer :: n, status type(ExtData_DriverGridComp), pointer :: cap @@ -689,7 +688,7 @@ subroutine run_one_step(this, rc) call MAPL_MemCommited ( mem_total, mem_commit, mem_percent, RC=STATUS ) if (this%AmIRoot) write(6,1000) AGCM_YY,AGCM_MM,AGCM_DD,AGCM_H,AGCM_M,AGCM_S,mem_percent 1000 format(1x,'TestDriver Date: ',i4.4,'/',i2.2,'/',i2.2,2x,'Time: ',i2.2,':',i2.2,':',i2.2,2x,f5.1,'%Memory Committed') - + _RETURN(ESMF_SUCCESS) end subroutine run_one_step @@ -697,7 +696,7 @@ end subroutine run_one_step ! !IROUTINE: MAPL_ClockInit -- Sets the clock - ! !INTERFACE: + ! !INTERFACE: subroutine MAPL_ClockInit ( cf, Clock, nsteps, rc) @@ -762,7 +761,7 @@ subroutine MAPL_ClockInit ( cf, Clock, nsteps, rc) _VERIFY(STATUS) call ESMF_ConfigGetAttribute(cf, heartbeat_dt, label='HEARTBEAT_DT:',rc=status) - _VERIFY(status) + _VERIFY(status) call ESMF_TimeIntervalSet( TimeInterval, h=0, m=0, s=heartbeat_dt, rc=status ) _VERIFY(STATUS) Clock = ESMF_ClockCreate (timeInterval, CurrTime, rc=status ) diff --git a/base/BinIO.F90 b/base/BinIO.F90 index 6bf76502bc2f..2de6de654267 100644 --- a/base/BinIO.F90 +++ b/base/BinIO.F90 @@ -28,6 +28,7 @@ module BinIOMod use MAPL_ExceptionHandling use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env + use mpi implicit none private @@ -46,8 +47,6 @@ module BinIOMod public MAPL_DestroyFile public MAPL_MemFileInquire - include "mpif.h" - !#define TIME_MPIIO #ifdef TIME_MPIIO real(kind=ESMF_KIND_R8), save :: peak_ioread_bandwidth=0 @@ -1106,8 +1105,7 @@ subroutine MAPL_VarRead_R4_2d(UNIT, GRID, A, MASK, arrdes, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_beg = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_beg = MPI_Wtime() #endif if(present(arrdes)) then @@ -1286,8 +1284,7 @@ subroutine MAPL_VarRead_R4_2d(UNIT, GRID, A, MASK, arrdes, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_end = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_end = MPI_Wtime() bwidth = REAL(IM_WORLD*JM_WORLD*4/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_ioread_bandwidth) peak_ioread_bandwidth = bwidth @@ -1677,8 +1674,7 @@ subroutine MAPL_VarRead_R8_2d(UNIT, GRID, A, MASK, arrdes, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_beg = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_beg = MPI_Wtime() #endif if(present(arrdes)) then @@ -1838,8 +1834,7 @@ subroutine MAPL_VarRead_R8_2d(UNIT, GRID, A, MASK, arrdes, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_end = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_end = MPI_Wtime() bwidth = REAL(IM_WORLD*JM_WORLD*8/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_ioread_bandwidth) peak_ioread_bandwidth = bwidth @@ -2736,8 +2731,7 @@ subroutine MAPL_VarWrite_R4_2d(UNIT, GRID, A, MASK, ARRDES, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_beg = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_beg = MPI_Wtime() #endif @@ -2960,8 +2954,7 @@ subroutine MAPL_VarWrite_R4_2d(UNIT, GRID, A, MASK, ARRDES, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_end = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_end = MPI_Wtime() bwidth = REAL(IM_WORLD*JM_WORLD*4/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_iowrite_bandwidth) peak_iowrite_bandwidth = bwidth @@ -3384,8 +3377,7 @@ subroutine MAPL_VarWrite_R8_2d(UNIT, GRID, A, MASK, ARRDES, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_beg = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_beg = MPI_Wtime() #endif if(present(arrdes)) then @@ -3601,8 +3593,7 @@ subroutine MAPL_VarWrite_R8_2d(UNIT, GRID, A, MASK, ARRDES, RC) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) _VERIFY(STATUS) - itime_end = MPI_Wtime(STATUS) - _VERIFY(STATUS) + itime_end = MPI_Wtime() bwidth = REAL(IM_WORLD*JM_WORLD*8/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_iowrite_bandwidth) peak_iowrite_bandwidth = bwidth diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 070d06388772..67f63078799c 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -25,6 +25,7 @@ module FileIOSharedMod use MAPL_ExceptionHandling use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env + use mpi implicit none private @@ -41,8 +42,6 @@ module FileIOSharedMod public ArrDescrSet public ArrDescrInit - include "mpif.h" - ! Global vars: ! ------------ diff --git a/base/MAPL_CFIO.F90 b/base/MAPL_CFIO.F90 index 25fe0b02e478..65806d540f7c 100644 --- a/base/MAPL_CFIO.F90 +++ b/base/MAPL_CFIO.F90 @@ -31,14 +31,14 @@ module MAPL_CFIOMod use MAPL_ExceptionHandling -! !DESCRIPTION: +! !DESCRIPTION: ! \input{MAPL_CFIODescr.tex} ! use ESMF use MAPL_BaseMod use MAPL_CommsMod use MAPL_Constants - use ESMF_CFIOMod + use ESMF_CFIOMod use ESMF_CFIOUtilMod use ESMF_CFIOFileMod use MAPL_IOMod @@ -57,11 +57,12 @@ module MAPL_CFIOMod use PFIO use gFTL_IntegerVector use MAPL_StringTemplate + use mpi use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env, only: REAL64 - + implicit none private @@ -99,7 +100,7 @@ module MAPL_CFIOMod public ESMF_ioRead ! another name for MAPL_CFIORead public ESMF_ioCreate ! another name for MAPL_CFIOCreate public ESMF_ioWrite ! another name for MAPL_CFIOWrite - public ESMF_ioDestroy ! another name for MAPL_CFIODestroy + public ESMF_ioDestroy ! another name for MAPL_CFIODestroy ! !PUBLIC TYPES: ! @@ -172,10 +173,10 @@ module MAPL_CFIOMod real(KIND=REAL64), pointer :: LONS2D(:) => NULL() real(KIND=REAL64), pointer :: LATS2D(:) => NULL() logical :: created = .false. - integer :: IM = 0 - integer :: JM = 0 + integer :: IM = 0 + integer :: JM = 0 end type StoredGlobalCoords - + type :: MCFIO_Variable integer :: request_id integer :: num_dimensions @@ -183,7 +184,7 @@ module MAPL_CFIOMod end type MCFIO_VARIABLE type :: MAPL_CFIO - private + private logical :: CREATED=.false. character(len=ESMF_MAXSTR) :: NAME character(len=ESMF_MAXPATHLEN) :: fNAME @@ -227,7 +228,7 @@ module MAPL_CFIOMod class (AbstractRegridder), pointer :: regridder => null() class (AbstractRegridder), pointer :: new_regridder => null() integer :: regrid_method - type (ESMF_Grid) :: output_grid + type (ESMF_Grid) :: output_grid integer :: AsyncWorkRank integer :: globalComm logical :: regridConservative @@ -252,8 +253,8 @@ module MAPL_CFIOMod ! TLC components used in the new ESMF regrid variant integer :: n_vars type (MCFIO_Variable), allocatable :: variables(:) - - + + end type MAPL_CFIO integer, parameter :: trans_tag=9999 @@ -266,8 +267,6 @@ module MAPL_CFIOMod type(CFIOCollectionVector) :: collections - include "mpif.h" - contains !------------------------------------------------------------------------- @@ -277,9 +276,9 @@ module MAPL_CFIOMod ! is opaque and its properties can only be set by this method at ! creation. Currently, its properties cannot be queried. The object ! is used only as a handle in write operations. It is not needed for -! reading. +! reading. ! -! Its non-optional arguments associate a _NAME_, an ESMF +! Its non-optional arguments associate a _NAME_, an ESMF ! _BUNDLE_, and a _CLOCK_ with the object. An ESMF TimeInterval ! _OFFSET_ is an optional argument that sets an offset between the ! time on the clock when eriting and the time stamp used for the data @@ -296,7 +295,7 @@ module MAPL_CFIOMod ! attributes in the SDF file. ! !#### HIstory -! +! !- 19Apr2007 Todling ! - Added ability to write out ak/bk ! - Added experiment ID as optional argument @@ -324,12 +323,12 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, integer, optional, intent(IN) :: XYOFFSET real, optional, intent(IN) :: VSCALE integer, optional, intent(IN) :: DEFLATE - character(len=*),optional, intent(IN) :: VUNIT - character(len=*),optional, intent(IN) :: VCOORD + character(len=*),optional, intent(IN) :: VUNIT + character(len=*),optional, intent(IN) :: VCOORD character(len=*),optional, intent(IN) :: source - character(len=*),optional, intent(IN) :: institution + character(len=*),optional, intent(IN) :: institution character(len=*),optional, intent(IN) :: comment - character(len=*),optional, intent(IN) :: contact + character(len=*),optional, intent(IN) :: contact character(len=*),optional, intent(IN) :: format character(len=*),optional, intent(IN) :: EXPID integer, optional, intent(IN) :: Conservative @@ -398,9 +397,9 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, character(len=ESMF_MAXSTR) :: Units character(len=ESMF_MAXSTR) :: StartTime character(len=esmf_maxstr) :: Usource - character(len=esmf_maxstr) :: Uinstitution + character(len=esmf_maxstr) :: Uinstitution character(len=esmf_maxstr) :: Ucomment - character(len=esmf_maxstr) :: Ucontact + character(len=esmf_maxstr) :: Ucontact character(len=esmf_maxstr) :: Utitle character(len=esmf_maxstr) :: GridTypeAttribute @@ -437,7 +436,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, ! Begin !------ - MCFIO%NAME = NAME + MCFIO%NAME = NAME MCFIO%CLOCK = CLOCK MCFIO%BUNDLE = BUNDLE @@ -511,7 +510,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, endif if(present(descr )) then - Utitle = descr + Utitle = descr else Utitle = "unknown" endif @@ -602,7 +601,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, if (MCFIO%Func=='log') then MCFIO%Vvar = adjustl(MCFIO%Vvar(index(MCFIO%Vvar,'(')+1:index(MCFIO%Vvar,')')-1)) elseif(MCFIO%Func=='pow') then - read( MCFIO%Vvar(index(MCFIO%Vvar,',')+1:index(MCFIO%Vvar,')')-1) , *) mCFIO%pow + read( MCFIO%Vvar(index(MCFIO%Vvar,',')+1:index(MCFIO%Vvar,')')-1) , *) mCFIO%pow MCFIO%Vvar = adjustl(MCFIO%Vvar(index(MCFIO%Vvar,'(')+1:index(MCFIO%Vvar,',')-1)) endif else @@ -732,8 +731,8 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, unGrdCoordCheck = .false. end if if ( unGrdUnitCheck .or. unGrdNameCheck .or. unGrdCoordCheck) then - _FAIL( 'Ungridded attributes for variables in collection do not match') - end if + _FAIL( 'Ungridded attributes for variables in collection do not match') + end if end if end do end if @@ -802,7 +801,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, if (HAVE_ungrd) then _FAIL( 'ERROR: Specifying LEVELS is not allowed for UNGRIDDED vars') end if - else + else ! Check on proper levels ! ----------------------- @@ -821,7 +820,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, end if if (minval(vsize) /= maxval(vsize)) then _FAIL( 'ERROR: Outputting variables with different ungridded sizes in one collection') - end if + end if LM = maxval(vsize) else LM = COUNTS(3) @@ -868,7 +867,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, else mcfio%output_grid = mCFIO%grid end if - + call MAPL_GridGet(mcfio%output_grid, globalCellCountPerDim=dims, rc=status) _VERIFY(status) IMO = dims(1) @@ -1021,7 +1020,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, end if else ! TRANSFORM - + ! Arrays of lats and lons from esmfgrid !-------------------------------------- @@ -1036,7 +1035,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, allocate(LATS (IM ,JM ),STAT=STATUS) _VERIFY(STATUS) allocate(LOCAL(IML,JML),STAT=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) call ESMF_GridGetCoord(esmfgrid, localDE=0, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & @@ -1045,12 +1044,12 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, LOCAL = R8D2*(180._REAL64/MAPL_PI_R8) call ArrayGather(LOCAL, LONS, ESMFGRID, RC=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) call ESMF_GridGetCoord(esmfgrid, localDE=0, coordDim=2, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=R8D2, rc=status) - _VERIFY(STATUS) + _VERIFY(STATUS) LOCAL = R8D2*(180._REAL64/MAPL_PI_R8) call ArrayGather(LOCAL, LATS, ESMFGRID, RC=STATUS) @@ -1144,7 +1143,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, VERTGRID: if(HAVE3D) THEN allocate(LEV(LM), stat=status) _VERIFY(STATUS) - + if (associated(ULEVELS)) then if (mCFIO%Vinterp .or. (size(ulevels) < LMG)) then LEV = ULEVELS @@ -1202,7 +1201,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, if (present(vunit) .and. trim(vunits) .ne. "") then call ESMF_CFIOGridSet(cfiogrid, levUnit =trim(vunits), RC=STATUS) _VERIFY(STATUS) - else + else call ESMF_CFIOGridSet(cfiogrid, levUnit ='layer', RC=STATUS) _VERIFY(STATUS) end if @@ -1364,7 +1363,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, MCFIO%cfio = ESMF_CFIOCreate(cfioObjName=trim(Name)) ! Set Internal MetaCode Writing interval. Default of 6 hours. If set to 0 -! it is reset to 6 hours.Currently CFIO and GFIO expect timeIncrement to be +! it is reset to 6 hours.Currently CFIO and GFIO expect timeIncrement to be ! in HHMMSS format, this imposes severe limitations to the frequency of the output: ! no writes should be done less frequently than once every 4 days (99 hours) ! ------------------------------------------------------------------------------ @@ -1404,7 +1403,7 @@ subroutine MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, BUNDLE, OFFSET, convention = "COARDS", & contact = Ucontact, & references = "http://gmao.gsfc.nasa.gov", & - comment = Ucomment, & + comment = Ucomment, & prec = 0, & deflate = df, & RC=STATUS ) @@ -1486,11 +1485,11 @@ subroutine MAPL_CFIOCreatewrite ( MCFIO, nsteps, RC ) else call ESMF_CFIOSet(MCFIO%CFIO, nsteps=1, RC=STATUS) _VERIFY(STATUS) - endif + endif ! Get time info from the clock. Note the optional offset !------------------------------------------------------- - + call ESMF_ClockGet(mCFIO%CLOCK, name=clockname, CurrTime=CurrTime, RC=STATUS) _VERIFY(STATUS) @@ -1628,13 +1627,13 @@ subroutine MAPL_CFIOCreateFromState ( MCFIO, NAME, CLOCK, STATE, OFFSET, & real, optional, pointer :: LEVELS(:) character(LEN=*),optional, intent(IN) :: DESCR real, optional, intent(IN) :: VSCALE - character(len=*),optional, intent(IN) :: VUNIT - character(len=*),optional, intent(IN) :: VCOORD + character(len=*),optional, intent(IN) :: VUNIT + character(len=*),optional, intent(IN) :: VCOORD integer, optional, intent(IN) :: XYOFFSET character(len=*),optional, intent(IN) :: source - character(len=*),optional, intent(IN) :: institution + character(len=*),optional, intent(IN) :: institution character(len=*),optional, intent(IN) :: comment - character(len=*),optional, intent(IN) :: contact + character(len=*),optional, intent(IN) :: contact character(len=*),optional, intent(IN) :: format character(len=*),optional, intent(IN) :: EXPID integer, optional, intent(IN) :: DEFLATE @@ -1658,7 +1657,7 @@ subroutine MAPL_CFIOCreateFromState ( MCFIO, NAME, CLOCK, STATE, OFFSET, & tBUNDLE = ESMF_FieldBundleCreate ( name=Iam, rc=STATUS ) _VERIFY(STATUS) - + ! Serialize the state ! ------------------- @@ -1669,7 +1668,7 @@ subroutine MAPL_CFIOCreateFromState ( MCFIO, NAME, CLOCK, STATE, OFFSET, & ! ---------------------- call MAPL_CFIOCreateFromBundle ( MCFIO, NAME, CLOCK, tBUNDLE, & - OFFSET = OFFSET, & + OFFSET = OFFSET, & OUTPUT_GRID=OUTPUT_GRID, & CHUNKSIZE=CHUNKSIZE, & FREQUENCY=FREQUENCY, & @@ -1702,7 +1701,7 @@ subroutine MAPL_CFIOCreateFromState ( MCFIO, NAME, CLOCK, STATE, OFFSET, & _RETURN(ESMF_SUCCESS) end subroutine MAPL_CFIOCreateFromState - + !------------------------------------------------------------------------- !> @@ -1714,7 +1713,7 @@ end subroutine MAPL_CFIOCreateFromState ! *CLOCK, BUNDLE* can be used to override the choice ! made at creation, but this is of dubious value, particularly ! for *BUNDLE* since it must be excatly conformant with the -! creation *BUNDLE*. *NBITS* if the number of bits of +! creation *BUNDLE*. *NBITS* if the number of bits of ! the mantissa to retain. This is used to write files with degraded ! precision, which can then be compressed with standard utilities. ! The default is no degradation of precision. @@ -1731,8 +1730,8 @@ end subroutine MAPL_CFIOCreateFromState ! requires no special handling by the users of the data. In fact, ! they do not even need to know that the data is compressed! At this ! point, `MAPL_CFIO` does not activate this GZIP compression -! feature in the files being written, but the resulting precision -! degredaded files can be compressed offline with the HDF-4 +! feature in the files being written, but the resulting precision +! degredaded files can be compressed offline with the HDF-4 ! *hrepack* utility. @@ -1754,7 +1753,7 @@ subroutine MAPL_CFIOWriteBundlePost( MCFIO, PrePost, RC ) real, pointer :: layer(:,:),ps0(:,:) logical :: PrePost_ integer :: globalcount(3) - type(ESMF_VM) :: vm + type(ESMF_VM) :: vm ! --- _ASSERT(MCFIO%CREATED, 'MCFIO%CREATED is false') @@ -1812,7 +1811,7 @@ subroutine MAPL_CFIOWriteBundlePost( MCFIO, PrePost, RC ) if (associated(mCFIO%regridder)) then mcfio%ascending = (ptr3(1,1,0) Gptr2Out call TransShaveAndSend(PtrTypeIn(1:1),PtrTypeOut(1:1),MCFIO%reqs(nn)%s_rqst,doTrans=.true.,IdxOut=1) _VERIFY(status) - else if (nv > 0) then + else if (nv > 0) then ! I am U part of vector if (associated(MCFIO%reqs(nn)%Trans_Array)) then _ASSERT(associated(MCFIO%reqs(nv)%Trans_Array), 'Trans_Array not associated') @@ -2083,7 +2082,7 @@ subroutine MAPL_CFIOWriteBundleWait( MCFIO, CLOCK, RC ) PtrTypeOut(2)%ptr => MCFIO%reqs(nv)%Trans_Array(:,:,1) call TransShaveAndSend(PtrTypeIn(1:2),PtrTypeOut(1:2),MCFIO%reqs(nn)%s_rqst,doTrans=.not.TransAlreadyDone,IdxOut=1) _VERIFY(status) - else + else ! I am V part of vector nv = abs(nv) if (associated(MCFIO%reqs(nn)%Trans_Array)) then @@ -2130,7 +2129,7 @@ subroutine MAPL_CFIOWriteBundleWait( MCFIO, CLOCK, RC ) _RETURN(ESMF_SUCCESS) contains - + subroutine TransShaveAndSend(PtrIn,PtrOut,request,doTrans,idxOut) type(Ptr2Arr) :: PtrIn(:) type(Ptr2Arr) :: PtrOut(:) @@ -2192,11 +2191,11 @@ subroutine TransShaveAndSend(PtrIn,PtrOut,request,doTrans,idxOut) deallocate(Gin) nullify (Gin) else - _ASSERT(size(PtrIn) == 2, 'if not scalar, ptrIn must be 2-vector') - _ASSERT(size(PtrOut) == 2, 'if not scalar, ptrOut must be 2-vector') + _ASSERT(size(PtrIn) == 2, 'if not scalar, ptrIn must be 2-vector') + _ASSERT(size(PtrOut) == 2, 'if not scalar, ptrOut must be 2-vector') Gout => PtrOut(idxOut)%ptr ! TLC: Probably do not need this conditional now that there are identity regridders - if (doTrans) then + if (doTrans) then _ASSERT(associated(mcfio%regridder), 'mcfio%regridder not associated') im = size(PtrIn(1)%ptr,1) jm = size(PtrIn(1)%ptr,2) @@ -2204,7 +2203,7 @@ subroutine TransShaveAndSend(PtrIn,PtrOut,request,doTrans,idxOut) ! MAT PGI cannot handle C_LOC call inside C_F_POINTER cptr = C_loc(PtrIn(1)%ptr(1,1)) call C_F_pointer (cptr, uin,[im,jm,1]) - + cptr = C_loc(PtrIn(2)%ptr(1,1)) call C_F_pointer (cptr, vin,[im,jm,1]) @@ -2217,12 +2216,12 @@ subroutine TransShaveAndSend(PtrIn,PtrOut,request,doTrans,idxOut) cptr = C_loc(PtrOut(1)%ptr(1,1)) call C_F_pointer (cptr, uout,[im,jm,1]) - + cptr = C_loc(PtrOut(2)%ptr(1,1)) call C_F_pointer (cptr, vout,[im,jm,1]) - + !@# allocate(uout(im,jm,1), vout(im,jm,1)) - + call mCFIO%regridder%set_undef_value(MAPL_undef) call mCFIO%regridder%regrid(uin, vin, uout, vout, rc=status) _VERIFY(status) @@ -2548,7 +2547,7 @@ end subroutine MAPL_CFIOWriteBundle ! *CLOCK, BUNDLE* can be used to override the choice ! made at creation, but this is of dubious value, particularly ! for *BUNDLE* since it must be excatly conformant with the -! creation *BUNDLE*. *NBITS* if the number of bits of +! creation *BUNDLE*. *NBITS* if the number of bits of ! the mantissa to retain. This is used to write files with degraded ! precision, which can then be compressed with standard utilities. ! The default is no degradation of precision. @@ -2565,8 +2564,8 @@ end subroutine MAPL_CFIOWriteBundle ! requires no special handling by the users of the data. In fact, ! they do not even need to know that the data is compressed! At this ! point, `MAPL_CFIO` does not activate this GZIP compression -! feature in the files being written, but the resulting precision -! degredaded files can be compressed offline with the HDF-4 +! feature in the files being written, but the resulting precision +! degredaded files can be compressed offline with the HDF-4 ! *hrepack* utility. ! subroutine MAPL_CFIOWriteState ( MCFIO, CLOCK, State, & @@ -2644,7 +2643,7 @@ end subroutine MAPL_CFIOWriteState ! useful to define a Bundle with the same variables as presented in the ! file, which in turn can be used to created a `MAPL_CFIO` object for ! writing. -!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. +!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. !- **[VERBOSE]** If .TRUE., prints progress messages to STDOUT; useful ! for debugging. !- **[FORCE_REGRID]** Obsolete; kept for backward compatibility but @@ -2652,12 +2651,12 @@ end subroutine MAPL_CFIOWriteState !- **[TIME_IS_CYCLIC]** If .TRUE. it says that the input file is periodic ! in time. Useful for reading climatological files. For example, if the ! input file has 12 monthly means from January to December of 2001, setting -! this option to .TRUE. allows one to read this data for any other year. See +! this option to .TRUE. allows one to read this data for any other year. See ! note below regarding issues with reading monthly mean data. !- **[TIME_INTERP]** If .TRUE., the input file does not have to coincide with the ! actual times on file. In such cases, the data for the bracketing times are ! read and the data is properly interpolated in time. The input time, though, -! need to be within the range of times present on file +! need to be within the range of times present on file ! (unless *TIME_IS_CYCLIC* is specified). !- **[ONLY_VARS]** A list of comma separated vafriables to be read from the ! file. By default, all variables are read from the file. This option allows @@ -2686,13 +2685,13 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & logical, optional, intent(IN ) :: NOREAD integer, optional, intent( OUT) :: RC logical, optional, intent(IN) :: VERBOSE - logical, optional, intent(IN) :: FORCE_REGRID + logical, optional, intent(IN) :: FORCE_REGRID logical, optional, intent(IN) :: TIME_IS_CYCLIC logical, optional, intent(IN) :: TIME_INTERP logical, optional, intent(IN) :: conservative logical, optional, intent(IN) :: voting logical, optional, intent(IN) :: doParallel - character(len=*), optional, intent(IN) :: ONLY_VARS + character(len=*), optional, intent(IN) :: ONLY_VARS real, optional, intent(IN) :: ONLY_LEVS(:) character(len=*), optional, intent(IN) :: EXPID logical, optional, intent(IN) :: ignoreCase @@ -2844,8 +2843,8 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & !call WRITE_PARALLEL("CFIO: Reading " // trim(filename)) if (mapl_am_i_root()) write(*,*)"CFIO: Reading ",trim(filename)," at ",nymd," ",nhms - - cfioIsCreated = .false. + + cfioIsCreated = .false. if (present(collection_id)) then collection => collections%at(collection_id) cfio => collection%find(filename, _RC) @@ -2859,8 +2858,8 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & call ESMF_CFIOFileOpen (CFIO, FMODE=1, cyclic=TIME_IS_CYCLIC_, RC=STATUS) _VERIFY(STATUS) end if - - + + ! Get info from the bundle !------------------------- @@ -2928,12 +2927,12 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & do L=1,NUMVARS call ESMF_CFIOVarInfoGet(VARS(L),vname=CFIOVARNAME, vtitle=LONG_NAME, vunits=UNITS, twoDimVar=twoD, & - & grid=varsGrid, RC=STATUS) + & grid=varsGrid, RC=STATUS) _VERIFY(STATUS) if ( present(ONLY_VARS) ) then if ( index(','//trim(ONLY_VARS) //',', & - ','//trim(CFIOVARNAME)//',') < 1 ) cycle + ','//trim(CFIOVARNAME)//',') < 1 ) cycle endif if (trim(CFIOVARNAME)=="lons" .or. trim(CFIOVARNAME)=="lats") cycle @@ -2981,18 +2980,18 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & _VERIFY(STATUS) call ESMF_AttributeSet(FIELD, NAME='VLOCATION', & VALUE=MAPL_VLocationNone, RC=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) else ! 3-d case call ESMF_CFIOGridGet (varsGrid, lev=levsfile, rc=status) - _VERIFY(STATUS) + _VERIFY(STATUS) if (levsfile(1) > levsfile(lm)) kreverse = .true. if (selectedLevels) then if (.not. allocated(levidx)) then allocate(levidx(LM), stat=status) - _VERIFY(STATUS) + _VERIFY(STATUS) ! build level index DO K = 1, LM found = .false. @@ -3011,7 +3010,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & deallocate(levsfile) nullify(levsfile) - if (lm == counts(3)) then + if (lm == counts(3)) then allocate(PTR3(1-HW:DIMS(1)+HW,1-HW:DIMS(2)+HW,LM),stat=STATUS) _VERIFY(STATUS) else if (lm == (counts(3)+1)) then @@ -3021,7 +3020,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & PTR3 = 0.0 FIELD = ESMF_FieldCreate(grid=ESMFGRID, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & - farrayPtr=PTR3, name=BundleVARNAME, & + farrayPtr=PTR3, name=BundleVARNAME, & totalLWidth=haloWidth(1:2), & totalUWidth=haloWidth(1:2), & rc = status) @@ -3050,7 +3049,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & NUMVARS = L1 ! could be less than on file if user chooses to else - + do L=1,NumVars call ESMF_FieldBundleGet (BUNDLE, L, FIELD, RC=STATUS) _VERIFY(STATUS) @@ -3080,11 +3079,11 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & end if end do _ASSERT(found, 'search failed') - call ESMF_CFIOVarInfoGet(VARS(K), twoDimVar=twoD, grid=varsGrid, RC=STATUS) + call ESMF_CFIOVarInfoGet(VARS(K), twoDimVar=twoD, grid=varsGrid, RC=STATUS) _VERIFY(STATUS) if (.not. twoD) then call ESMF_CFIOGridGet (varsGrid, lev=levsfile, rc=status) - _VERIFY(STATUS) + _VERIFY(STATUS) if (levsfile(1) > levsfile(lm)) kreverse = .true. end if if (selectedLevels) then @@ -3092,7 +3091,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & ! 3-d case if (.not. allocated(levidx)) then allocate(levidx(LM), stat=status) - _VERIFY(STATUS) + _VERIFY(STATUS) ! build level index DO K = 1, LM found = .false. @@ -3127,21 +3126,21 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & if (IM /= IM0 .or. JM /= JM0) then change_resolution = .true. - else + else change_resolution = .false. end if ! 180 Degree Shifting and Cubed Sphere ! ------------------------------------ -! +! ! In the earlier revisions of this subroutine there was an implicit assumption ! of the input data being on the lat-lon grid. Since there were two ! possibilities: Longitudinal origin at dateline, or at the Greewitch meridian, -! the code used to perform Longitudinal shifting, if needed, so that the -! output is "properly" oriented at dateline center. +! the code used to perform Longitudinal shifting, if needed, so that the +! output is "properly" oriented at dateline center. ! ! Out current strategy is to correct the input (from the file), if needed. -! We first check if the input is on the Cubed-Sphere grid. +! We first check if the input is on the Cubed-Sphere grid. ! In this case no shifting is done. Otherwise we still assume that the ! input is on a lat-lon grid and if shifting is needed, ! it will be done prior to the optional MAPL_HorzTransformRun regridding. @@ -3149,7 +3148,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & if ( JM == 6*IM ) then fcubed = .true. - else + else fcubed = .false. end if @@ -3217,7 +3216,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & allocate(krank(1) ,stat=status) end if krank = 0 - + else IM0 = counts(1) @@ -3268,7 +3267,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & end if ! Special handling for single column case -! Pick out index into file grid for lats and lons of scm grid - +! Pick out index into file grid for lats and lons of scm grid - ! Assume that scm grid counts lon from -180 to 180 and lat from -90 to 90 if(single_point) then if(LONSfile(1).lt.0.) then ! assume lons on file go from -180 to 180 @@ -3292,13 +3291,13 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & _VERIFY(STATUS) call ESMF_FieldGet (FIELD, NAME=BundleVarName, array=ARRAY, RC=STATUS) _VERIFY(STATUS) - + if (ignoreCase_) call getVarNameIgnoreCase(BundleVarName,vars,RC=status) call ESMF_FieldGet(FIELD, Grid=ESMFGRID, RC=STATUS) _VERIFY(STATUS) call ESMF_ArrayGet (array, rank=arrayRank, RC=STATUS) - + _VERIFY(STATUS) if ( VERB .and. IamRoot ) & @@ -3310,7 +3309,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & call ESMF_ArrayGet(Array, localDE=0, farrayPtr=PTR2, RC=STATUS) _VERIFY(STATUS) - + ! read the data on root if (IamRoot) then if ( timeInterp ) then @@ -3329,10 +3328,10 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & call shift180Lon2D_ ( Gptr2file, im, jm ) end if end if - + ! transform and scatter - if (change_resolution) then - if (RegridCnv) then + if (change_resolution) then + if (RegridCnv) then call MAPL_SyncSharedMemory(rc=status) _VERIFY(STATUS) call MAPL_BcastShared(VM, Data=Gptr2file, N=im*jm, Root=0, RootOnly=.false., rc=status) @@ -3407,7 +3406,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & end if end if - if (change_resolution) then + if (change_resolution) then if (RegridCnv) then call MAPL_SyncSharedMemory(rc=status) _VERIFY(STATUS) @@ -3424,7 +3423,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & L1 = LBOUND(PTR3,3)-1 ptr3(:,:,K+L1) = Gptr2bundle call MAPL_SyncSharedMemory(rc=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) else if (MyGlobal) then @@ -3478,7 +3477,7 @@ subroutine MAPL_CFIOReadBundle ( FILETMPL, TIME, BUNDLE, NOREAD, RC, & deallocate(Gptr3file) end if -10 continue +10 continue ! always do this cleanup deallocate(LONSfile,LATSfile) @@ -3585,7 +3584,7 @@ end subroutine MAPL_CFIOReadBundle ! useful to define a Bundle with the same variables as presented in the ! file, which in turn can be used to created a `MAPL_CFIO` object for ! writing. -!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. +!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. !- **[VERBOSE]** If .TRUE., prints progress messages to STDOUT; useful ! for debugging. !- **[FORCE_REGRID]** Obsolete; kept for backward compatibility but @@ -3593,12 +3592,12 @@ end subroutine MAPL_CFIOReadBundle !- **[TIME_IS_CYCLIC]** If .TRUE. it says that the input file is periodic ! in time. Useful for reading climatological files. For example, if the ! input file has 12 monthly means from January to December of 2001, setting -! this option to .TRUE. allows one to read this data for any other year. See +! this option to .TRUE. allows one to read this data for any other year. See ! note below regarding issues with reading monthly mean data. !- **[TIME_INTERP]** If .TRUE., the input file does not have to coincide with the ! actual times on file. In such cases, the data for the bracketing times are ! read and the data is properly interpolated in time. The input time, though, -! need to be within the range of times present on file +! need to be within the range of times present on file ! (unless *TIME_IS_CYCLIC* is specified). !- **[ONLY_VARS]** A list of comma separated vafriables to be read from the ! file. By default, all variables are read from the file. This option allows @@ -3643,7 +3642,7 @@ subroutine MAPL_CFIOReadState ( FILETMPL, TIME, STATE, NOREAD, RC, & ! ---------------------- tBUNDLE = ESMF_FieldBundleCreate ( name=Iam, rc=STATUS ) _VERIFY(STATUS) - + ! Serialize the state ! ------------------- call ESMFL_BundleAddState ( tBUNDLE, STATE, rc=STATUS, VALIDATE=.true. ) @@ -3697,7 +3696,7 @@ end subroutine MAPL_CFIOReadState ! says it is 18Z on 05 February 2007, the template will expand in the ! following file name: `forecast.2007-02-05_18Z.nc4'` !- **TIME** The ESMF time to read from the file -!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. +!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. !- **[VERBOSE]** If .TRUE., prints progress messages to STDOUT; useful ! for debugging. !- **[FORCE_REGRID]** Obsolete; kept for backward compatibility but @@ -3705,12 +3704,12 @@ end subroutine MAPL_CFIOReadState !- **[TIME_IS_CYCLIC]** If .TRUE. it says that the input file is periodic ! in time. Useful for reading climatological files. For example, if the ! input file has 12 monthly means from January to December of 2001, setting -! this option to .TRUE. allows one to read this data for any other year. See +! this option to .TRUE. allows one to read this data for any other year. See ! note below regarding issues with reading monthly mean data. !- **[TIME_INTERP]** If .TRUE., the input file does not have to coincide with the ! actual times on file. In such cases, the data for the bracketing times are ! read and the data is properly interpolated in time. The input time, though, -! need to be within the range of times present on file +! need to be within the range of times present on file ! (unless *TIME_IS_CYCLIC* is specified). !- **[ONLY_VARS]** A list of comma separated vafriables to be read from the ! file. By default, all variables are read from the file. This option allows @@ -3749,7 +3748,7 @@ subroutine MAPL_CFIOReadField ( VARN, FILETMPL, TIME, FIELD, RC, & ! Locals type(ESMF_FIELDBUNDLE) :: BUNDLE - + ! Create a temporary empty bundle ! ------------------------------- call ESMF_FieldGet(Field, grid=Grid, rc=status) @@ -3777,13 +3776,13 @@ subroutine MAPL_CFIOReadField ( VARN, FILETMPL, TIME, FIELD, RC, & voting = voting, ignoreCase = ignoreCase, & doParallel = doParallel, getFrac=getFrac, & RC=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) ! Destroy temporary bundle; field data will be preserved ! ------------------------------------------------------ call ESMF_FieldBundleDestroy ( BUNDLE, rc=STATUS ) - _VERIFY(STATUS) + _VERIFY(STATUS) _RETURN(ESMF_SUCCESS) @@ -3810,9 +3809,9 @@ end subroutine MAPL_CFIOReadField ! says it is 18Z on 05 February 2007, the template will expand in the ! following file name: ``forecast.2007-02-05\_18Z.nc4'' !- **TIME** The ESMF time to read from the file -!- **GRID** The ESMF grid associated with the Field. The data will be +!- **GRID** The ESMF grid associated with the Field. The data will be ! (horizontally) interpolated to this grid if necessary. -!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. +!- **[RC]** Error return code; set to `ESMF_SUCCESS` if all is well. !- **[VERBOSE]}] If .TRUE., prints progress messages to STDOUT; useful ! for debugging. !- **[FORCE_REGRID]** Obsolete; kept for backward compatibility but @@ -3820,12 +3819,12 @@ end subroutine MAPL_CFIOReadField !- **[TIME_IS_CYCLIC]** If .TRUE. it says that the input file is periodic ! in time. Useful for reading climatological files. For example, if the ! input file has 12 monthly means from January to December of 2001, setting -! this option to .TRUE. allows one to read this data for any other year. See +! this option to .TRUE. allows one to read this data for any other year. See ! note below regarding issues with reading monthly mean data. !- **[TIME_INTERP]** If .TRUE., the input file does not have to coincide with the ! actual times on file. In such cases, the data for the bracketing times are ! read and the data is properly interpolated in time. The input time, though, -! need to be within the range of times present on file +! need to be within the range of times present on file ! (unless *TIME_IS_CYCLIC* is specified). !- **[ONLY_VARS]** A list of comma separated vafriables to be read from the ! file. By default, all variables are read from the file. This option allows @@ -3865,10 +3864,10 @@ subroutine MAPL_CFIOReadArray3D ( VARN, FILETMPL, TIME, GRID, farrayPtr, RC, & integer :: ios, k ! ---- -! Special case: when filename is "/dev/null" it is assumed the user +! Special case: when filename is "/dev/null" it is assumed the user ! wants to set the variable to a constant ! ----------------------------------------------------------------- - if ( FILETMPL(1:9) == '/dev/null' ) then + if ( FILETMPL(1:9) == '/dev/null' ) then ios = -1 k = index(FILETMPL,':') if ( k > 9 ) read(FILETMPL(k+1:),*,iostat=ios) const @@ -3886,7 +3885,7 @@ subroutine MAPL_CFIOReadArray3D ( VARN, FILETMPL, TIME, GRID, farrayPtr, RC, & farrayPtr=farrayPtr, name=trim(varn), RC=STATUS) _VERIFY(STATUS) - + ! Read array data from file ! ------------------------- call MAPL_CFIOReadField ( VARN, FILETMPL, TIME, FIELD, & @@ -3987,10 +3986,10 @@ subroutine MAPL_CFIOReadArray2D ( VARN, FILETMPL, TIME, GRID, farrayPtr, RC, & ! ---- -! Special case: when filename is "/dev/null" it is assumed the user +! Special case: when filename is "/dev/null" it is assumed the user ! wants to set the variable to a constant ! ----------------------------------------------------------------- - if ( FILETMPL(1:9) == '/dev/null' ) then + if ( FILETMPL(1:9) == '/dev/null' ) then ios = -1 k = index(FILETMPL,':') if ( k > 9 ) read(FILETMPL(k+1:),*,iostat=ios) const @@ -4023,7 +4022,7 @@ subroutine MAPL_CFIOReadArray2D ( VARN, FILETMPL, TIME, GRID, farrayPtr, RC, & datacopyFlag = ESMF_DATACOPY_REFERENCE, & farrayPtr=farrayPtr, name=trim(varn), gridToFieldMap=gridToFieldMap, RC=STATUS) _VERIFY(STATUS) - + deallocate(gridToFieldMap) ! Read array data from file @@ -4060,7 +4059,7 @@ subroutine MAPL_CFIODestroy( MCFIO, RC ) ! integer :: status - if(associated(MCFIO%Krank )) deallocate(MCFIO%Krank ) + if(associated(MCFIO%Krank )) deallocate(MCFIO%Krank ) if(associated(MCFIO%reqs )) deallocate(MCFIO%reqs ) if(associated(MCFIO%varname )) deallocate(MCFIO%varname ) if(associated(MCFIO%vardims )) deallocate(MCFIO%vardims ) @@ -4071,7 +4070,7 @@ subroutine MAPL_CFIODestroy( MCFIO, RC ) if(associated(MCFIO%buffer )) deallocate(MCFIO%buffer ) if(associated(MCFIO%varid )) deallocate(MCFIO%varid ) - nullify(MCFIO%Krank ) + nullify(MCFIO%Krank ) nullify(MCFIO%reqs ) nullify(MCFIO%varname ) nullify(MCFIO%vardims ) @@ -4148,7 +4147,7 @@ subroutine MAPL_CFIOSet( MCFIO, Root, Psize, fName, Krank, IOWorker, globalComm, if(present(fName)) then mCFIO%fName = fName endif - + if(present(Krank)) then mCFIO%Krank = Krank endif @@ -4209,7 +4208,7 @@ end subroutine MAPL_CFIOGet !------------------------------------------------------------------------- !> ! This is a candidate for ESMFL, here for dependency reasons -! +! subroutine GridGetLatLons_ ( grid, lons, lats, rc ) use MAPL_GetLatLonCoordMod @@ -4254,7 +4253,7 @@ subroutine GridGetLatLons_ ( grid, lons, lats, rc ) _VERIFY(status) lons = lons*(180._REAL64/MAPL_PI_R8) lats = lats*(180._REAL64/MAPL_PI_R8) - + _RETURN(ESMF_SUCCESS) end subroutine GridGetLatLons_ @@ -4310,9 +4309,9 @@ subroutine VertInterp(v2,v3,pp,ple_,pl_,rc) if(all(pbpt .and. ppx<=pb) al = (pb-ppx)/(pb-pt) - where (v3(:,:,k) .eq. MAPL_UNDEF ) v2 = v3(:,:,k+1) + where (v3(:,:,k) .eq. MAPL_UNDEF ) v2 = v3(:,:,k+1) where (v3(:,:,k+1) .eq. MAPL_UNDEF ) v2 = v3(:,:,k) - where (v3(:,:,k) .ne. MAPL_UNDEF .and. v3(:,:,k+1) .ne. MAPL_UNDEF ) + where (v3(:,:,k) .ne. MAPL_UNDEF .and. v3(:,:,k+1) .ne. MAPL_UNDEF ) v2 = v3(:,:,k)*al + v3(:,:,k+1)*(1.0-al) end where end where @@ -4350,7 +4349,7 @@ subroutine MAPL_GetCurrentFile(FileTmpl, Time, Filename, RC, EXPID) call ESMF_TimeGet(Time, timeString=DATE, RC=STATUS) _VERIFY(STATUS) - + call strToInt(DATE, nymd, nhms) call fill_grads_template ( Filename, FileTmpl,& experiment_id=EXPID, nymd=nymd, nhms=nhms, rc=status ) @@ -4369,9 +4368,9 @@ character(len=ESMF_MAXSTR) function MAPL_CFIOGetFilename(MCFIO) end function MAPL_CFIOGetFilename subroutine MAPL_CFIOGetTimeString(mcfio,Clock,Date,rc) - + type(MAPL_CFIO ), intent(inout) :: MCFIO - type(ESMF_Clock), intent(in ) :: Clock + type(ESMF_Clock), intent(in ) :: Clock character(len=ESMF_MAXSTR), intent(inout) :: Date integer, optional, intent(out ) :: rc @@ -4421,10 +4420,10 @@ subroutine MAPL_CFIOGetTimeString(mcfio,Clock,Date,rc) _RETURN(ESMF_SUCCESS) end subroutine MAPL_CFIOGetTimeString - + !------------------------------------------------------------------------ !> -! Returns Psize and Root, the size (in nodes) and root node +! Returns Psize and Root, the size (in nodes) and root node ! of each node partition assigned to active collections. ! subroutine MAPL_CFIOPartition(Slices, NumColls, NumNodes, Writing, Psize,Root) @@ -4453,7 +4452,7 @@ subroutine MAPL_CFIOPartition(Slices, NumColls, NumNodes, Writing, Psize,Root) Root = 1 ! Sort the collection sizes (# of slices) in ascending order. -! Also sort the collection index the same way, to fill the +! Also sort the collection index the same way, to fill the ! correct ones later. !------------------------------------------------------------ where(writing) @@ -4475,14 +4474,14 @@ subroutine MAPL_CFIOPartition(Slices, NumColls, NumNodes, Writing, Psize,Root) ! and is used as our initial guess. MaxSlicesPerNode = (sum(Slices,mask=Writing)-1)/NumNodes + 1 - ! ALT: The above expression could be zero if + ! ALT: The above expression could be zero if ! NumNodes==1 and the sum over "writing" slices is 0 (i.e. no writing) MaxSlicesPerNode = max(MaxSlicesPerNode,1) ! make sure it is not 0 ! We try to distribute the slices in active collections as uniformly ! as possible. "Small" collections (<= MaxSlicesPerNode) are -! assigned to a single node, others span multiple nodes. -! Small collections are grouped in a node without +! assigned to a single node, others span multiple nodes. +! Small collections are grouped in a node without ! exceeding MaxSlicesPerNode. Multi-node collections are ! not grouped in nodes. Since MaxSlicesPerNode is generally ! too small to fit all the collections, it is then increased,until @@ -4573,13 +4572,13 @@ subroutine MAPL_CFIOReadParallel_(bundlelist,filelist,time,blocksize,RegridMetho call tindex%push_back(nn) enddo - if (present(blocksize)) then + if (present(blocksize)) then blocksize_=blocksize else blocksize_=1 end if - if (present(regridMethod)) then + if (present(regridMethod)) then call regridMethod_%resize(size(filelist)) do n=1,size(filelist) call regridMethod_%set(n,RegridMethod) @@ -4597,22 +4596,22 @@ subroutine MAPL_CFIOReadParallel_(bundlelist,filelist,time,blocksize,RegridMetho _VERIFY(status) nfiles = size(bundlelist) - blocksize_ = min(nfiles,blocksize_) + blocksize_ = min(nfiles,blocksize_) allocate(slices(blocksize_),psize(blocksize_),root(blocksize_),reading(blocksize_),gslices(nfiles),stat=status) _VERIFY(STATUS) reading=.false. hw=0 - if (present(gsiMode)) then + if (present(gsiMode)) then cfio(:)%gsiMode=gsiMode if (gsiMode) hw=1 end if nnodes = size(MAPL_NodeRankList) n1=1 - time_iter = tindex%begin() + time_iter = tindex%begin() regrid_iter = RegridMethod_%begin() do n=1,nfiles - + fname = cfio(n)%fname myregridmethod = regrid_iter%get() collection_id = cfio(n)%collection_id @@ -4622,7 +4621,7 @@ subroutine MAPL_CFIOReadParallel_(bundlelist,filelist,time,blocksize,RegridMetho call regrid_iter%next() gslices(n)=size(cfio(n)%krank) - enddo + enddo maxSlices = maxval(gslices) maxSlices = max(maxSlices,nPet) @@ -4643,7 +4642,7 @@ subroutine MAPL_CFIOReadParallel_(bundlelist,filelist,time,blocksize,RegridMetho enddo n2=n1+nn-1 - call MAPL_CFIOPartition(slices,blocksize_,nNodes,reading,psize,root) + call MAPL_CFIOPartition(slices,blocksize_,nNodes,reading,psize,root) nn=0 do n=n1,n2 @@ -4744,7 +4743,7 @@ subroutine MAPL_CFIOCreateFromFile(MCFIO,bundlein,RegridMethod,hw,only_vars,rc) localCellCountPerDim=DIMS, RC=STATUS) img=counts(1) jmg=counts(2) - + ! Get the number of variables we will be reading call ESMF_FieldBundleGet(bundlein,fieldCount=bvars,rc=status) _VERIFY(status) @@ -5102,7 +5101,7 @@ subroutine MAPL_CFIOReadBundleRead(MCFIO,tindex,hw,rc) _VERIFY(status) allocate(transDone(lt),source=.false.,stat=status) _VERIFY(status) - + nn = 0 VARS1: do L=1,size(MCFIO%VarDims) @@ -5144,7 +5143,7 @@ subroutine MAPL_CFIOReadBundleRead(MCFIO,tindex,hw,rc) LM = MCFIO%lm else LM = 0 - end if + end if do k = 1,lm nn=nn+1 @@ -5275,7 +5274,7 @@ subroutine MAPL_CFIOReadBundleRead(MCFIO,tindex,hw,rc) _RETURN(ESMF_SUCCESS) contains - + subroutine TransAndSave(mcfio,ptrin,ptrout,req,doTrans,idxOut,hw,rc) type(MAPL_CFIO), intent(inout) :: mcfio type(Ptr2Arr), intent(inout) :: PtrIn(:) @@ -5285,7 +5284,7 @@ subroutine TransAndSave(mcfio,ptrin,ptrout,req,doTrans,idxOut,hw,rc) integer, intent(in) :: idxOut integer, intent(in) :: hw integer, optional, intent(out) :: rc - + __Iam__('TransAndSave') real, pointer :: gin(:,:) real , pointer :: gout(:,:) @@ -5313,27 +5312,27 @@ subroutine TransAndSave(mcfio,ptrin,ptrout,req,doTrans,idxOut,hw,rc) end if if (mcfio%gsiMode) call shift180Lon2D_(gout) else - + _ASSERT(size(PtrIn) == 2, 'input is neither a scalar nor a tangent (2d) vector') _ASSERT(size(PtrOut) == 2, 'input is a vector, but output is not') gout => PtrOut(idxOut)%ptr if (doTrans) then - + im = size(PtrIn(1)%ptr,1) jm = size(PtrIn(1)%ptr,2) - + cptr = C_loc(PtrIn(1)%ptr(1,1)) call C_F_pointer (cptr, uin,[im,jm,1]) - + cptr = C_loc(PtrIn(2)%ptr(1,1)) call C_F_pointer (cptr, vin,[im,jm,1]) - + im = size(PtrOut(1)%ptr,1) jm = size(PtrOut(1)%ptr,2) - + cptr = C_loc(PtrOut(1)%ptr(1,1)) call C_F_pointer (cptr, uout,[im,jm,1]) - + cptr = C_loc(PtrOut(2)%ptr(1,1)) call C_F_pointer (cptr, vout,[im,jm,1]) @@ -5558,11 +5557,11 @@ subroutine get_latlon_from_factory(grid, lons, lats, rc) real, intent(out) :: lons(:), lats(:) integer :: i integer, optional, intent(out) :: rc - + integer :: status class (AbstractGridFactory), pointer :: factory - + factory => get_factory(grid, rc=status) _VERIFY(status) select type (factory) @@ -5577,7 +5576,7 @@ subroutine get_latlon_from_factory(grid, lons, lats, rc) lats(i)=i enddo end select - + end subroutine get_latlon_from_factory function make_regridder(esmfgrid, method, lons, lats, im,jm,lm, runparallel, LocalTiles, rc) result(regridder) @@ -5599,13 +5598,13 @@ function make_regridder(esmfgrid, method, lons, lats, im,jm,lm, runparallel, Loc integer :: status type (ESMF_Grid) :: grid - + type (ESMF_DistGrid) :: dist_grid type (ESMF_LocalArray) :: lon_array, lat_array - + integer, allocatable :: krank(:) type (ESMF_DELayout) :: layout - + real, pointer :: lons_radians(:) real, pointer :: lats_radians(:) integer :: numNodes, k @@ -5634,19 +5633,19 @@ function make_regridder(esmfgrid, method, lons, lats, im,jm,lm, runparallel, Loc else krank = 0 end if - + allocate(lons_radians(size(lons))) allocate(lats_radians(size(lats))) - + lons_radians = MAPL_DEGREES_TO_RADIANS_R8 * lons lats_radians = MAPL_DEGREES_TO_RADIANS_R8 * lats - + lon_array = ESMF_LocalArrayCreate(lons_radians, rc=status) _VERIFY(status) lat_array = ESMF_LocalArrayCreate(lats_radians, rc=status) _VERIFY(status) - - + + layout = ESMF_DELayoutCreate(petMap=krank, rc=status) _VERIFY(status) dist_grid = ESMF_DistGridCreate([1,1,1],[IM,JM,LM], & @@ -5655,7 +5654,7 @@ function make_regridder(esmfgrid, method, lons, lats, im,jm,lm, runparallel, Loc _VERIFY(status) grid = grid_manager%make_grid('LatLon', dist_grid, lon_array, lat_array, rc=status) _VERIFY(status) - + call ESMF_DistGridDestroy(dist_grid, rc=status) _VERIFY(status) deallocate(lons_radians, lats_radians) @@ -5664,8 +5663,8 @@ function make_regridder(esmfgrid, method, lons, lats, im,jm,lm, runparallel, Loc call ESMF_LocalArrayDestroy(lat_array) _VERIFY(status) - if (method == REGRID_METHOD_CONSERVE .or. method == REGRID_METHOD_VOTE .or. & - method == REGRID_METHOD_FRACTION) then + if (method == REGRID_METHOD_CONSERVE .or. method == REGRID_METHOD_VOTE .or. & + method == REGRID_METHOD_FRACTION) then regridder => regridder_manager%make_regridder(grid, ESMFGRID, & & method, hints=regrid_hints, rc=status) _VERIFY(status) @@ -5676,7 +5675,7 @@ function make_regridder(esmfgrid, method, lons, lats, im,jm,lm, runparallel, Loc end if _RETURN(ESMF_SUCCESS) - + end function make_regridder function MAPL_CFIOAddCollection(template) result(id) diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index 2cd2bef7bf45..dd02d6693390 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -16,6 +16,7 @@ module MAPL_CommsMod use MAPL_ShmemMod use MAPL_Constants, only: MAPL_Unknown, MAPL_IsGather, MAPL_IsScatter use MAPL_ExceptionHandling + use mpi implicit none private @@ -234,8 +235,6 @@ module MAPL_CommsMod module procedure ArrayGatherRcvCnt_R4_1 end interface - include "mpif.h" - integer, parameter :: MAPL_root=0 integer, parameter :: msg_tag=11 diff --git a/base/MAPL_LlcGridFactory.F90 b/base/MAPL_LlcGridFactory.F90 index cd2d0dcbb587..d3b7ff5732ed 100644 --- a/base/MAPL_LlcGridFactory.F90 +++ b/base/MAPL_LlcGridFactory.F90 @@ -47,7 +47,7 @@ module MAPL_LlcGridFactoryMod procedure :: add_horz_coordinates procedure :: init_halo procedure :: halo - + procedure :: initialize_from_file_metadata procedure :: initialize_from_config_with_prefix @@ -72,9 +72,9 @@ module MAPL_LlcGridFactoryMod procedure :: decomps_are_equal procedure :: physical_params_are_equal end type LlcGridFactory - + character(len=*), parameter :: MOD_NAME = 'MAPL_LlcGridFactory::' - + interface LlcGridFactory module procedure LlcGridFactory_from_parameters end interface LlcGridFactory @@ -107,7 +107,7 @@ function LlcGridFactory_from_parameters(unusable, grid_file_name, grid_name, & integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'LlcGridFactory_from_parameters' - + if (present(unusable)) print*,shape(unusable) call set_with_default(factory%grid_name, grid_name, MAPL_GRID_NAME_DEFAULT) @@ -152,13 +152,13 @@ function make_new_grid(this, unusable, rc) result(grid) end function make_new_grid - + function create_basic_grid(this, unusable, rc) result(grid) type (ESMF_Grid) :: grid class (LlcGridFactory), intent(in) :: this class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - + integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'create_basic_grid' @@ -176,16 +176,16 @@ function create_basic_grid(this, unusable, rc) result(grid) poleKindFlag=[ESMF_POLEKIND_MONOPOLE,ESMF_POLEKIND_BIPOLE], & coordSys=ESMF_COORDSYS_SPH_RAD, rc=status) _VERIFY(status) - + ! Allocate coords at default stagger location call ESMF_GridAddCoord(grid, rc=status) _VERIFY(status) - + if (this%lm /= MAPL_UNDEFINED_INTEGER) then call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, rc=status) _VERIFY(status) end if - + call ESMF_AttributeSet(grid, 'GridType', 'Llc', rc=status) _VERIFY(status) @@ -201,7 +201,7 @@ subroutine add_horz_coordinates(this, grid, unusable, rc) type (ESMF_Grid), intent(inout) :: grid class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - + @@ -220,7 +220,7 @@ subroutine add_horz_coordinates(this, grid, unusable, rc) type(ESMF_DistGrid) :: DISTGRID real(ESMF_KIND_R8), allocatable :: x(:,:), y(:,:) real(ESMF_KIND_R8), pointer :: gridx(:,:), gridy(:,:) - + _UNUSED_DUMMY(unusable) ! get IM, JM and IM_WORLD, JM_WORLD call MAPL_GridGet(GRID, localCellCountPerDim=COUNTS, globalCellCountPerDim=DIMS, RC=STATUS) @@ -234,7 +234,7 @@ subroutine add_horz_coordinates(this, grid, unusable, rc) ! get global index of the lower left corner !------------------------------------------ call MAPL_GRID_INTERIOR(GRID,IMSTART,DUMMYI,JMSTART,DUMMYJ) - + call ESMF_GridGetCoord(grid, localDE=0, coordDim=1, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=gridx, rc=status) @@ -325,7 +325,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc _RETURN(_SUCCESS) contains - + subroutine get_multi_integer(values, label, rc) integer, allocatable, intent(out) :: values(:) character(len=*) :: label @@ -336,7 +336,7 @@ subroutine get_multi_integer(values, label, rc) integer :: tmp integer :: status logical :: isPresent - + call ESMF_ConfigFindLabel(config, label=prefix//label,isPresent=isPresent,rc=status) _VERIFY(status) if (.not. isPresent) then @@ -369,7 +369,7 @@ subroutine get_multi_integer(values, label, rc) end subroutine get_multi_integer end subroutine initialize_from_config_with_prefix - + function to_string(this) result(string) @@ -408,7 +408,7 @@ subroutine check_and_fill_consistency(this, unusable, rc) call verify(this%ny, this%jm_world, this%jms, rc=status) !this%ims = spread(this%im_world / this%nx, 1, this%nx) !this%jms = spread(this%jm_world / this%ny, 1, this%ny) - + _RETURN(_SUCCESS) contains @@ -449,7 +449,7 @@ subroutine verify(n, m_world, ms, rc) _RETURN(_SUCCESS) end subroutine verify - + end subroutine check_and_fill_consistency @@ -457,27 +457,27 @@ elemental subroutine set_with_default_integer(to, from, default) integer, intent(out) :: to integer, optional, intent(in) :: from integer, intent(in) :: default - + if (present(from)) then to = from else to = default end if - + end subroutine set_with_default_integer - - + + subroutine set_with_default_character(to, from, default) character(len=:), allocatable, intent(out) :: to character(len=*), optional, intent(in) :: from character(len=*), intent(in) :: default - + if (present(from)) then to = from else to = default end if - + end subroutine set_with_default_character ! MAPL uses values in lon_array and lat_array only to determine the @@ -547,7 +547,7 @@ function physical_params_are_equal(this, a) result(equal) end select end function physical_params_are_equal - + logical function equals(a, b) class (LlcGridFactory), intent(in) :: a @@ -562,15 +562,15 @@ logical function equals(a, b) equals = (a%lm == b%lm) if (.not. equals) return - + equals = a%decomps_are_equal(b) if (.not. equals) return equals = a%physical_params_are_equal(b) - if (.not. equals) return - + if (.not. equals) return + end select - + end function equals @@ -595,7 +595,7 @@ subroutine read_grid_coordinates(this, longitudes, latitudes, unusable, rc) integer, optional, intent(out) :: rc include 'netcdf.inc' - + integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'read_grid_coordinates()' @@ -629,10 +629,10 @@ subroutine read_grid_coordinates(this, longitudes, latitudes, unusable, rc) xid = ncvid(ncid, 'x_T', status) _VERIFY(status) - + yid = ncvid(ncid, 'y_T', status) _VERIFY(status) - + call ncvgt(ncid, xid, start, counts, lons, status) _VERIFY(status) call ncvgt(ncid, yid, start, counts, lats, status) @@ -654,7 +654,7 @@ subroutine read_grid_dimensions(this, unusable, rc) integer, optional, intent(out) :: rc include 'netcdf.inc' - + integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'read_grid_dimensions()' @@ -685,10 +685,10 @@ subroutine read_grid_dimensions(this, unusable, rc) xid = ncvid(ncid, 'x_T', status) _VERIFY(status) - + call ncvinq (ncid, xid, name, type, n, dims, natt, status) _VERIFY(status) - + associate (im => this%im_world, jm => this%jm_world) call ncdinq(ncid, dims(1), name, im, status) _VERIFY(status) @@ -719,12 +719,12 @@ subroutine init_halo(this, unusable, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'init_halo' - + _UNUSED_DUMMY(unusable) grid = this%make_grid(rc=status) _VERIFY(status) - + call ESMF_GridGet(grid, distGrid=dist_grid, dimCount=dim_count, rc=status) _VERIFY(status) call ESMF_DistGridGet(dist_grid, delayout=this%layout, rc=status) @@ -735,7 +735,7 @@ subroutine init_halo(this, unusable, rc) call ESMF_VmGet(vm, localPet=pet, petCount=ndes, rc=status) _VERIFY(status) - + this%px = mod(pet, this%nx) this%py = pet / this%nx @@ -746,6 +746,7 @@ end subroutine init_halo subroutine halo(this, array, unusable, halo_width, rc) use MAPL_CommsMod + use mpi class (LlcGridFactory), intent(inout) :: this real(kind=REAL32), intent(inout) :: array(:,:) class (KeywordEnforcer), optional, intent(in) :: unusable @@ -754,7 +755,6 @@ subroutine halo(this, array, unusable, halo_width, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'halo' - include 'mpif.h' integer :: pet_north integer :: pet_south @@ -804,7 +804,7 @@ integer function get_pet(px, py, nx, ny) result(pet) else pet = mod(px+nx,nx) + nx*mod(py+ny,ny) end if - + end function get_pet @@ -817,9 +817,9 @@ subroutine fill_north(array, rc) integer :: len, last - last = size(array,2)-1 + last = size(array,2)-1 len = size(array,1) - + if(this%py==this%ny-1) then call MAPL_CommsSendRecv(this%layout, & array(:,2 ), len, pet_south, & @@ -845,12 +845,12 @@ subroutine fill_north(array, rc) end do end block end if - + _RETURN(_SUCCESS) end subroutine fill_north - + subroutine fill_south(array, rc) use MAPL_BaseMod, only: MAPL_UNDEF real(kind=REAL32), intent(inout) :: array(:,:) @@ -861,7 +861,7 @@ subroutine fill_south(array, rc) integer :: len, last - last = size(array,2)-1 + last = size(array,2)-1 len = size(array,1) call MAPL_CommsSendRecv(this%layout, & @@ -885,10 +885,10 @@ subroutine fill_east(array, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'fill_east' - + integer :: len, last - last = size(array,2)-1 + last = size(array,2)-1 len = size(array,1) call MAPL_CommsSendRecv(this%layout, & @@ -905,28 +905,28 @@ end subroutine fill_east subroutine fill_west(array, rc) real(kind=REAL32), intent(inout) :: array(:,:) integer, optional, intent(out) :: rc - + integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'fill_west' integer :: len, last - + last = size(array,1)-1 len = size(array,2) - + call MAPL_CommsSendRecv(this%layout, & array(last , : ), len, pet_west, & array(1 , : ), len, pet_east, & rc=status) _VERIFY(status) - + _RETURN(_SUCCESS) end subroutine fill_west end subroutine halo - + subroutine append_metadata(this, metadata) class (LlcGridFactory), intent(inout) :: this type (FileMetadata), intent(inout) :: metadata diff --git a/base/MAPL_LocStreamMod.F90 b/base/MAPL_LocStreamMod.F90 index 81bf99cbc402..a721dfa71079 100644 --- a/base/MAPL_LocStreamMod.F90 +++ b/base/MAPL_LocStreamMod.F90 @@ -32,6 +32,7 @@ module MAPL_LocStreamMod use MAPL_ShmemMod use MAPL_ExceptionHandling use, intrinsic :: iso_fortran_env, only: REAL64, INT64 +use mpi implicit none private @@ -54,8 +55,6 @@ module MAPL_LocStreamMod #define DO_NOT_USE_FCOLLECT #endif -INCLUDE 'mpif.h' - ! !PUBLIC TYPES: type, public :: MAPL_LocStream @@ -100,7 +99,7 @@ module MAPL_LocStreamMod integer :: NT_GLOBAL=0 !! Total number locations integer :: NT_LOCAL=0 !! Number locations on local PE integer :: N_GRIDS=0 !! Number of associated grids - integer :: Current_tiling=-1 !! Grid tiling currently attached + integer :: Current_tiling=-1 !! Grid tiling currently attached type(ESMF_GRID) :: GRID !! Grid currently attached type(ESMF_GRID) :: TILEGRID !! the next best thing to LocStream grid integer, pointer :: GLOBAL_Id(:) =>null() !! All Location Ids in file order @@ -161,8 +160,8 @@ module MAPL_LocStreamMod logical function MAPL_LocStreamIsAssociated(LocStream, RC) type(MAPL_LocStream), intent(IN ) :: LocStream - integer, optional, intent( OUT) :: RC - + integer, optional, intent( OUT) :: RC + MAPL_LocStreamIsAssociated = associated(LocStream%Ptr) @@ -174,8 +173,8 @@ end function MAPL_LocStreamIsAssociated logical function MAPL_LocStreamXformIsAssociated(Xform, RC) type(MAPL_LocStreamXform), intent(IN ) :: Xform - integer, optional, intent( OUT) :: RC - + integer, optional, intent( OUT) :: RC + MAPL_LocStreamXformIsAssociated = associated(Xform%Ptr) @@ -334,7 +333,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, type(ESMF_Grid), optional, intent(INout) :: GRID logical, optional, intent(IN ) :: NewGridNames logical, optional, intent(In ) :: use_pfaf - integer, optional, intent( OUT) :: RC + integer, optional, intent( OUT) :: RC ! Local variables @@ -396,7 +395,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, STREAM => LocStream%Ptr -! Use the filename as identifier. NAME is thus the +! Use the filename as identifier. NAME is thus the ! same for all streams made from this file !------------------------------------------------- @@ -441,7 +440,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, else call READ_PARALLEL(layout, nt, UNIT=UNIT, rc=status) _VERIFY(STATUS) - end if + end if ! Number of grids that can be attached !------------------------------------- @@ -493,7 +492,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, AVR= transpose(AVR_transpose) deallocate(AVR_transpose) - ! adjust EASE grid starting index. Internally, the starting index is 1 instead of 0. + ! adjust EASE grid starting index. Internally, the starting index is 1 instead of 0. do N=1,STREAM%N_GRIDS if(index(STREAM%TILING(N)%NAME,'EASE') /=0 ) then AVR(:,NumGlobalVars+1+NumLocalVars*(N-1)) = AVR(:,NumGlobalVars+1+NumLocalVars*(N-1))+1 @@ -816,7 +815,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, endif end if end do - + call MAPL_SyncSharedMemory(RC=STATUS); _VERIFY(STATUS) if ( MAPL_am_I_root() ) read(UNIT) AVR call MAPL_BcastShared(vm, DATA=AVR, N=NT, ROOT=0, RootOnly=.false., RC=status) @@ -832,7 +831,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, endif end if end do - + call MAPL_SyncSharedMemory(RC=STATUS); _VERIFY(STATUS) if ( MAPL_am_I_root() ) read(UNIT) AVR call MAPL_BcastShared(vm, DATA=AVR, N=NT, ROOT=0, RootOnly=.false., RC=status) @@ -856,10 +855,10 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, end if ! If grid is present attach that grid to the stream. -! It must be one of the possible grids described in +! It must be one of the possible grids described in ! the tile file. This is ascertained by name. !--------------------------------------------------- - + if (present(GRID)) then call MAPL_LocStreamAttachGrid(LocStream, GRID, & ISMINE=ISMINE, RC=STATUS) @@ -932,9 +931,9 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, if(MSK(I)) then K = K + 1 if (ISMINE(K)) then - L = L + 1 + L = L + 1 STREAM%LOCAL_GeoLocation(L)%X = AVR(I,1) * (MAPL_PI/180.) - endif + endif end if end do @@ -1112,7 +1111,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, !------------------- call MAPL_LocStreamCreateTileGrid(LocStream, GRID, RC=status) _VERIFY(STATUS) - + _RETURN(ESMF_SUCCESS) 100 _RETURN(ESMF_FAILURE) @@ -1141,29 +1140,29 @@ subroutine GetBilinearCoeffs(X0,Y0,DX,DY,X,Y,II,JJ,D,RC) D = 0.0 if (DX0 >= 0.0 .and. DY0 >= 0.0) then - D( 1, 0) = DX0*(1.0-DY0) - D( 0, 1) = DY0*(1.0-DX0) - D( 0, 0) = (1.0-DX0)*(1.0-DY0) + D( 1, 0) = DX0*(1.0-DY0) + D( 0, 1) = DY0*(1.0-DX0) + D( 0, 0) = (1.0-DX0)*(1.0-DY0) D( 1, 1) = DX0*DY0 elseif(DX0 >= 0.0 .and. DY0 <= 0.0) then DY0 = -DY0 - D( 1, 0) = DX0*(1.0-DY0) - D( 0,-1) = DY0*(1.0-DX0) - D( 0, 0) = (1.0-DX0)*(1.0-DY0) - D( 1,-1) = DX0*DY0 + D( 1, 0) = DX0*(1.0-DY0) + D( 0,-1) = DY0*(1.0-DX0) + D( 0, 0) = (1.0-DX0)*(1.0-DY0) + D( 1,-1) = DX0*DY0 elseif(DX0 <= 0.0 .and. DY0 >= 0.0) then DX0 = -DX0 - D(-1, 0) = DX0*(1.0-DY0) - D( 0, 1) = DY0*(1.0-DX0) - D( 0, 0) = (1.0-DX0)*(1.0-DY0) - D(-1, 1) = DX0*DY0 + D(-1, 0) = DX0*(1.0-DY0) + D( 0, 1) = DY0*(1.0-DX0) + D( 0, 0) = (1.0-DX0)*(1.0-DY0) + D(-1, 1) = DX0*DY0 else DX0 = -DX0 DY0 = -DY0 - D(-1, 0) = DX0*(1.0-DY0) - D( 0,-1) = DY0*(1.0-DX0) - D( 0, 0) = (1.0-DX0)*(1.0-DY0) - D(-1,-1) = DX0*DY0 + D(-1, 0) = DX0*(1.0-DY0) + D( 0,-1) = DY0*(1.0-DX0) + D( 0, 0) = (1.0-DX0)*(1.0-DY0) + D(-1,-1) = DX0*DY0 end if _RETURN(ESMF_SUCCESS) @@ -1174,10 +1173,10 @@ subroutine GetBilinearCoeffs(lons,lats,lon,lat,D,RC) real, intent(IN ) :: lon,lat real, intent( OUT) :: D(-1:,-1:) integer, optional, intent( OUT) :: RC - + integer :: STATUS - + real, dimension(3) :: pp, p0, dp, dpx, dpy real :: DX0, DY0 @@ -1186,21 +1185,21 @@ subroutine GetBilinearCoeffs(lons,lats,lon,lat,D,RC) #define ToXYZ(lon,lat) (/ cos(lat)*sin(lon), cos(lat)*cos(lon), sin(lat) /) p0 = ToXYZ(lons(0,0), lats(0,0)) - + dp = ToXYZ(lon , lat ) - p0 dpx = ToXYZ(lons(1,0), lats(1,0)) - p0 dpy = ToXYZ(lons(0,1), lats(0,1)) - p0 - + DX0 = dot_product(dp,dpx) DY0 = dot_product(dp,dpy) - + if(DX0 >= 0.0 ) then - + if (DY0 >= 0.0) then - + if (DX0 /= 0.0) DX0 = DX0/dot_product(dpx,dpx) if (DY0 /= 0.0) DY0 = DY0/dot_product(dpy,dpy) - + if(lons(1,1) /= MAPL_UNDEF) then D( 0, 0) = (1.0-DX0)*(1.0-DY0) D( 1, 0) = DX0*(1.0-DY0) @@ -1212,16 +1211,16 @@ subroutine GetBilinearCoeffs(lons,lats,lon,lat,D,RC) D( 0, 1) = DY0 D( 1, 1) = 0. endif - + else dpy = ToXYZ(lons(0,-1), lats(0,-1)) - p0 - + DY0 = dot_product(dp,dpy) - + if (DX0 /= 0.0) DX0 = DX0/dot_product(dpx,dpx) if (DY0 /= 0.0) DY0 = DY0/dot_product(dpy,dpy) - + if(lons(1,-1) /= MAPL_UNDEF) then D( 0, 0) = (1.0-DX0)*(1.0-DY0) D( 1, 0) = DX0*(1.0-DY0) @@ -1239,14 +1238,14 @@ subroutine GetBilinearCoeffs(lons,lats,lon,lat,D,RC) else dpx = ToXYZ(lons(-1,0), lats(-1,0)) - p0 - + DX0 = dot_product(dp,dpx) - + if(DY0 >= 0.0) then - + if (DX0 /= 0.0) DX0 = DX0/dot_product(dpx,dpx) if (DY0 /= 0.0) DY0 = DY0/dot_product(dpy,dpy) - + if(lons(-1,1) /= MAPL_UNDEF) then D( 0, 0) = (1.0-DX0)*(1.0-DY0) D(-1, 0) = DX0*(1.0-DY0) @@ -1260,13 +1259,13 @@ subroutine GetBilinearCoeffs(lons,lats,lon,lat,D,RC) end if else - + dpy = ToXYZ(lons(0,-1), lats(0,-1)) - p0 DY0 = dot_product(dp,dpy) - + if (DX0 /= 0.0) DX0 = DX0/dot_product(dpx,dpx) if (DY0 /= 0.0) DY0 = DY0/dot_product(dpy,dpy) - + if(lons(-1,-1) /= MAPL_UNDEF) then D( 0, 0) = (1.0-DX0)*(1.0-DY0) D(-1, 0) = DX0*(1.0-DY0) @@ -1299,9 +1298,9 @@ subroutine GenOldGridName_(name) character(len=2) :: dateline, pole character(len=8) :: imsz, jmsz character(len=MAPL_TileNameLength) :: imstr, jmstr - - ! Parse name for grid info + + ! Parse name for grid info !------------------------- Gridname = AdjustL(name) @@ -1323,7 +1322,7 @@ subroutine GenOldGridName_(name) read(IMSZ,*) IM read(JMSZ,*) JM endif - + write(imstr,*) im write(jmstr,*) jm gridname = pole // trim(adjustl(imstr))//'x'//& @@ -1346,7 +1345,7 @@ subroutine MAPL_LocStreamCreateFromStream(LocStreamOut, LocStreamIn, NAME, MASK, type(MAPL_LocStream), intent(IN ) :: LocStreamIn character(len=*), intent(IN ) :: NAME integer, optional, intent(IN ) :: MASK(:) - integer, optional, intent( OUT) :: RC + integer, optional, intent( OUT) :: RC ! Local variables @@ -1358,7 +1357,7 @@ subroutine MAPL_LocStreamCreateFromStream(LocStreamOut, LocStreamIn, NAME, MASK, integer :: NT_LOCAL(1) logical, pointer :: MSK(:) type(ESMF_VM) :: VM - + ! Begin !------ @@ -1395,7 +1394,7 @@ subroutine MAPL_LocStreamCreateFromStream(LocStreamOut, LocStreamIn, NAME, MASK, allocate(STREAMOUT%TILING(STREAMOUT%N_GRIDS), STAT=STATUS) _VERIFY(STATUS) - STREAMOUT%Tiling = STREAMIN%Tiling + STREAMOUT%Tiling = STREAMIN%Tiling ! Local number of tiles in input stream !-------------------------------------- @@ -1450,7 +1449,7 @@ subroutine MAPL_LocStreamCreateFromStream(LocStreamOut, LocStreamIn, NAME, MASK, do I=1, NT if(MSK(I)) then K = K + 1 - STREAMOUT%LOCAL_ID (K) = STREAMIN%LOCAL_ID (I) + STREAMOUT%LOCAL_ID (K) = STREAMIN%LOCAL_ID (I) STREAMOUT%LOCAL_GeoLocation(K)%T = STREAMIN%LOCAL_GeoLocation(I)%T STREAMOUT%LOCAL_GeoLocation(K)%A = STREAMIN%LOCAL_GeoLocation(I)%A STREAMOUT%LOCAL_GeoLocation(K)%X = STREAMIN%LOCAL_GeoLocation(I)%X @@ -1482,8 +1481,8 @@ subroutine MAPL_LocStreamAttachGrid(LocStream, GRID, ISMINE, RC) type(MAPL_LocStream), intent(INOUT) :: LocStream type(ESMF_Grid), intent(INout) :: Grid logical, optional, pointer :: ISMINE(:) - integer, optional, intent( OUT) :: RC - + integer, optional, intent( OUT) :: RC + ! Local variables @@ -1538,21 +1537,21 @@ subroutine MAPL_LocStreamAttachGrid(LocStream, GRID, ISMINE, RC) _VERIFY(STATUS) call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) _VERIFY(STATUS) - + IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) - + _ASSERT(IM_WORLD==TILING%IM,'needs informative message') if (JM_WORLD /= TILING%JM) then print *,'error tiling jm/jm ',jm_world, tiling%jm _RETURN(_FAILURE) end if - + ! Find out which tiles are in local PE !------------------------------------- call MAPL_GRID_INTERIOR (GRID, I1,IN,J1,JN) - + ! Local location uses local indexing !----------------------------------- @@ -1560,7 +1559,7 @@ subroutine MAPL_LocStreamAttachGrid(LocStream, GRID, ISMINE, RC) STREAM%LOCAL_IndexLocation(:)%J = STREAM%LOCAL_IndexLocation(:)%J-J1+1 _RETURN(ESMF_SUCCESS) - + end subroutine MAPL_LocStreamAttachGrid !====================================================== @@ -1569,8 +1568,8 @@ subroutine MAPL_LocStreamCreateTileGrid(LocStream, GRID, RC) type(MAPL_LocStream), intent(INOUT) :: LocStream type(ESMF_Grid), intent(INout) :: Grid - integer, optional, intent( OUT) :: RC - + integer, optional, intent( OUT) :: RC + ! Local variables @@ -1596,13 +1595,13 @@ subroutine MAPL_LocStreamCreateTileGrid(LocStream, GRID, RC) ! Alias to the pointer !--------------------- - + STREAM => LocStream%Ptr ! Get the attached grid's info !----------------------------- - + call ESMF_GridGet(GRID, NAME=GNAME, RC=STATUS) _VERIFY(STATUS) @@ -1611,10 +1610,10 @@ subroutine MAPL_LocStreamCreateTileGrid(LocStream, GRID, RC) distgrid = ESMF_DistGridCreate( & arbSeqIndexList=STREAM%LOCAL_ID, rc=status) _VERIFY(STATUS) - + TILEGRID = ESMF_GridEmptyCreate(rc=status) _VERIFY(STATUS) - + arbIndexCount = size(STREAM%LOCAL_ID) allocate(arbIndex(arbIndexCount,1), stat=status) _VERIFY(STATUS) @@ -1622,7 +1621,7 @@ subroutine MAPL_LocStreamCreateTileGrid(LocStream, GRID, RC) arbIndex(:,1) = STREAM%LOCAL_ID call ESMF_GridSet(tilegrid, & name="tile_grid_"//trim(Stream%NAME)//'@'//trim(GNAME), & - distgrid=distgrid, & + distgrid=distgrid, & indexFlag=ESMF_INDEX_DELOCAL, & distDim = (/1/), & localArbIndexCount=arbIndexCount, & @@ -1658,8 +1657,8 @@ subroutine MAPL_LocStreamAdjustNsubtiles(LocStream, NSUBTILES, RC) type(MAPL_LocStream), intent(INOUT) :: LocStream integer, intent(IN ) :: NSUBTILES - integer, optional, intent( OUT) :: RC - + integer, optional, intent( OUT) :: RC + ! Local variables @@ -1669,7 +1668,7 @@ subroutine MAPL_LocStreamAdjustNsubtiles(LocStream, NSUBTILES, RC) ! Alias to the pointer !--------------------- - + STREAM => LocStream%Ptr !====================================================== @@ -1686,7 +1685,7 @@ subroutine MAPL_LocStreamAdjustNsubtiles(LocStream, NSUBTILES, RC) end subroutine MAPL_LocStreamAdjustNsubtiles !====================================================== - + !BOPI ! !IROUTINE: MAPL_LocStreamTransform @@ -1704,7 +1703,7 @@ subroutine MAPL_LocStreamTransformField (LocStream, OUTPUT, INPUT, MASK, & logical, optional, intent(IN ) :: ISMINE(:), INTERP logical, optional, intent(IN ) :: GLOBAL integer, optional, intent(IN ) :: GRID_ID - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC !EOPI ! Local variables @@ -1789,7 +1788,7 @@ subroutine MAPL_LocStreamFracArea (LocStream, TYPE, AREA, RC ) type(MAPL_LocStream), intent(IN ) :: LocStream integer, intent(IN ) :: TYPE real, intent(OUT) :: AREA(:,:) - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC ! Local variables @@ -1811,11 +1810,11 @@ subroutine MAPL_LocStreamFracArea (LocStream, TYPE, AREA, RC ) !----------------------------------------------- AREA = 0.0 - + do N = 1, size(LOCSTREAM%Ptr%LOCAL_INDEXLOCATION) if(LOCSTREAM%Ptr%LOCAL_GEOLOCATION(N)%T == TYPE) then II = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%I - JJ = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%J + JJ = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%J AREA (II,JJ) = AREA (II,JJ) + LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%W end if end do @@ -1830,26 +1829,26 @@ end subroutine MAPL_LocStreamFracArea !INTERFACE: subroutine MAPL_LocStreamTransformT2G (LocStream, OUTPUT, INPUT, MASK, SAMPLE, TRANSPOSE, variance, RC ) - + !ARGUMENTS: type(MAPL_LocStream), intent(IN ) :: LocStream real, intent(INOUT) :: OUTPUT(:,:) real, intent(INOUT) :: INPUT(:) - logical, optional, intent(IN ) :: MASK(:) + logical, optional, intent(IN ) :: MASK(:) logical, optional, intent(IN ) :: SAMPLE logical, optional, intent(IN ) :: TRANSPOSE logical, optional, intent(IN ) :: variance - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC !EOPI - + ! Local variables integer :: STATUS real, allocatable :: FF(:,:),tmpOut(:,:) integer :: II, JJ, N, I1, IN, J1, JN - logical, allocatable :: usableMASK(:) - logical :: uSAMPLE + logical, allocatable :: usableMASK(:) + logical :: uSAMPLE logical :: usableTRANSPOSE logical :: computeVariance @@ -1882,7 +1881,7 @@ subroutine MAPL_LocStreamTransformT2G (LocStream, OUTPUT, INPUT, MASK, SAMPLE, T ! Make usable mask from optional argument !---------------------------------------- - + if (present(MASK)) then usableMASK = MASK else @@ -1930,7 +1929,7 @@ subroutine MAPL_LocStreamTransformT2G (LocStream, OUTPUT, INPUT, MASK, SAMPLE, T do N = 1, size(INPUT) if(usableMASK(N) .and. INPUT(N)/=MAPL_UNDEF) then II = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%I - JJ = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%J + JJ = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%J if(uSample) then if( LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%W > FF(II,JJ)) then OUTPUT(II,JJ) = INPUT(N) @@ -1944,7 +1943,7 @@ subroutine MAPL_LocStreamTransformT2G (LocStream, OUTPUT, INPUT, MASK, SAMPLE, T !jk FF (II,JJ) = FF (II,JJ) + LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%W endif - + endif end if end do @@ -1980,12 +1979,12 @@ subroutine MAPL_LocStreamTransformT2G (LocStream, OUTPUT, INPUT, MASK, SAMPLE, T do N = 1, size(INPUT) if(usableMASK(N) .and. INPUT(N)/=MAPL_UNDEF) then II = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%I - JJ = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%J + JJ = LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%J OUTPUT(II,JJ) = OUTPUT(II,JJ) + LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%W * (INPUT(N)-tmpOut(II,JJ))**2 FF (II,JJ) = FF (II,JJ) + LOCSTREAM%Ptr%LOCAL_INDEXLOCATION(N)%W end if end do - where (FF>0) + where (FF>0) output=output/ff end where where (ff<=0) @@ -2018,7 +2017,7 @@ subroutine MAPL_LocStreamTransformG2T ( LocStream, OUTPUT, INPUT, & logical, optional, intent(IN ) :: GLOBAL integer, optional, intent(IN ) :: GRID_ID logical, optional, intent(IN ) :: TRANSPOSE - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC !EOPI ! Local variables @@ -2028,7 +2027,7 @@ subroutine MAPL_LocStreamTransformG2T ( LocStream, OUTPUT, INPUT, & integer :: N, I1, IN, J1, JN, I, J, IM, JM logical, allocatable :: usableMASK(:) - + logical :: usableATTACHED logical :: usableGLOBAL logical :: usableINTERP @@ -2095,7 +2094,7 @@ subroutine MAPL_LocStreamTransformG2T ( LocStream, OUTPUT, INPUT, & allocate(usableMASK(size(OUTPUT)), STAT=STATUS) _VERIFY(STATUS) - + if (present(MASK)) then usableMASK = MASK else @@ -2176,7 +2175,7 @@ subroutine MAPL_LocStreamTileWeight ( LocStream, OUTPUT, INPUT, RC ) type(MAPL_LocStream), intent(IN ) :: LocStream real, intent(OUT) :: OUTPUT(:) real, intent(IN ) :: INPUT(:,:) - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC ! Local variables @@ -2210,7 +2209,7 @@ subroutine MAPL_LocStreamTransformT2T ( OUTPUT, XFORM, INPUT, RC ) real, intent(OUT) :: OUTPUT(:) type(MAPL_LocStreamXform), intent(IN ) :: XFORM real, intent(IN ) :: INPUT(:) - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC !EOPI ! Local variables @@ -2235,13 +2234,13 @@ subroutine MAPL_LocStreamTransformT2T ( OUTPUT, XFORM, INPUT, RC ) #endif _ASSERT(associated(Xform%PTR),'needs informative message') - + do N = 1,Xform%PTR%LastLocal OUTPUT(Xform%PTR%IndexOut(N)) = INPUT(Xform%PTR%IndexIn(N)) end do - + if(.not.Xform%PTR%Local) then - + if (Xform%PTR%do_not_use_fcollect) then me = Xform%PTR%myId @@ -2288,7 +2287,7 @@ subroutine MAPL_LocStreamTransformT2T ( OUTPUT, XFORM, INPUT, RC ) if (associated(Xform%PTR%senders)) then do n=1,size(Xform%PTR%senders) #if defined(TWO_SIDED_COMM) -! ALT: the senders' id is also used as a mpi_tag +! ALT: the senders' id is also used as a mpi_tag msg_tag = Xform%PTR%senders(N) call MPI_RECV(FULLINPUT(offset), Xform%PTR%len(N), MPI_REAL, & Xform%PTR%senders(N), msg_tag, & @@ -2301,7 +2300,7 @@ subroutine MAPL_LocStreamTransformT2T ( OUTPUT, XFORM, INPUT, RC ) 0, Xform%PTR%window, status) _VERIFY(STATUS) end if - + call MPI_GET(FULLINPUT(offset), Xform%PTR%len(N), MPI_REAL, & Xform%PTR%senders(N), 0, Xform%PTR%len(N), MPI_REAL, & Xform%PTR%window, STATUS) @@ -2357,12 +2356,12 @@ end subroutine MAPL_LocStreamTransformT2T !INTERFACE: subroutine MAPL_LocStreamTransformT2TR4R8 ( OUTPUT, XFORM, INPUT, RC ) - + !ARGUMENTS: real(kind=ESMF_KIND_R8), intent(OUT) :: OUTPUT(:) type(MAPL_LocStreamXform), intent(IN ) :: XFORM real, intent(IN ) :: INPUT(:) - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC !EOPI ! Local variables @@ -2407,10 +2406,10 @@ subroutine MAPL_LocStreamTransformT2TR4R8 ( OUTPUT, XFORM, INPUT, RC ) OUTPUTR4 = OUTPUT - call MAPL_LocStreamTransformT2T( OUTPUTR4, XFORM, INPUT, RC ) + call MAPL_LocStreamTransformT2T( OUTPUTR4, XFORM, INPUT, RC ) OUTPUT = OUTPUTR4 deallocate(OUTPUTR4) - + #endif _RETURN(ESMF_SUCCESS) @@ -2429,7 +2428,7 @@ subroutine MAPL_LocStreamTransformT2TR8R4 ( OUTPUT, XFORM, INPUT, RC ) real, intent(OUT) :: OUTPUT(:) type(MAPL_LocStreamXform), intent(IN ) :: XFORM real(kind=ESMF_KIND_R8), intent(IN ) :: INPUT(:) - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC !EOPI ! Local variables @@ -2474,7 +2473,7 @@ subroutine MAPL_LocStreamTransformT2TR8R4 ( OUTPUT, XFORM, INPUT, RC ) INPUTR4 = INPUT - call MAPL_LocStreamTransformT2T( OUTPUT, XFORM, INPUTR4, RC ) + call MAPL_LocStreamTransformT2T( OUTPUT, XFORM, INPUTR4, RC ) deallocate(INPUTR4) #endif @@ -2491,7 +2490,7 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M character(len=*), intent(IN ) :: NAME logical, optional, intent(IN ) :: MASK_OUT(:) logical, optional, intent(IN ) :: UseFCollect - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC ! Local variables @@ -2562,7 +2561,7 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M do N = 1, LocStreamOut%Ptr%NT_local if(DONE(N)) cycle M = MAPL_HashIncrement(Hash,LocStreamOut%Ptr%Local_Id(N)) - if(m<=LocStreamIn%Ptr%NT_local) then + if(m<=LocStreamIn%Ptr%NT_local) then Xform%Ptr%IndexOut(MM) = N Xform%Ptr%IndexIn (MM) = M DONE (N) = .TRUE. @@ -2648,7 +2647,7 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M if(Xform%Ptr%do_not_use_fcollect) then ! Find out which processors have output tiles we need !---------------------------------------------------- - + IsNeeded = .false. do N = 1, LocStreamOut%Ptr%NT_local if(.not.DONE(N)) then @@ -2691,7 +2690,7 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M deallocate(PELens,Begs,Ends,IsNeeded) - Xform%Ptr%InputLen = Last + Xform%Ptr%InputLen = Last call ESMF_VmGet(VM, localPet=MYID, rc=status) _VERIFY(STATUS) @@ -2707,7 +2706,7 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M _VERIFY(STATUS) allSenders(:,myId+1) = -1 if (m>0) allSenders(1:M,myId+1) = Xform%Ptr%senders - + do I=1,NDES call MAPL_CommsBcast(vm, DATA=allSenders(:,I), N=ndes, ROOT=I-1, RC=status) _VERIFY(STATUS) @@ -2746,14 +2745,14 @@ subroutine MAPL_LocStreamCreateXform ( Xform, LocStreamOut, LocStreamIn, NAME, M end block call ESMF_VMBarrier(vm, rc=status) _VERIFY(STATUS) - + NumReceivers = 0 do I=1,NDES NumReceivers = NumReceivers + allSenders(I,1) end do allocate(Xform%Ptr%receivers(NumReceivers), stat=status) _VERIFY(STATUS) - + M = 0 do I=1,NDES if(myId == I-1) cycle ! skip myself @@ -2811,10 +2810,10 @@ end subroutine MAPL_LocStreamCreateXform -integer function GRIDINDEX(STREAM,GRID,RC) +integer function GRIDINDEX(STREAM,GRID,RC) type(MAPL_LocStreamType), intent(IN ) :: Stream type(ESMF_Grid), intent(IN ) :: Grid - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC integer :: STATUS @@ -2847,13 +2846,13 @@ end function GRIDINDEX subroutine MAPL_GridCoordAdjust(GRID, LOCSTREAM, RC) type(ESMF_Grid), intent(INout ) :: Grid type(MAPL_LocStream), intent(IN ) :: Locstream - integer, optional, intent(OUT) :: RC + integer, optional, intent(OUT) :: RC ! local vars -!------------ +!------------ integer :: STATUS - + integer :: NGRIDS integer :: I, J, N integer :: IM, JM @@ -2888,7 +2887,7 @@ subroutine MAPL_GridCoordAdjust(GRID, LOCSTREAM, RC) _ASSERT(FOUND,'needs informative message') ! get id of the grid we just found - IG = I + IG = I _ASSERT(IG == LocStream%Ptr%Current_Tiling,'needs informative message') ! get IM, JM and IM_WORLD, JM_WORLD @@ -2942,7 +2941,7 @@ subroutine MAPL_GridCoordAdjust(GRID, LOCSTREAM, RC) ! Convert to radians SUMXW = SUMXW * (MAPL_PI_R8)/180._REAL64 SUMYW = SUMYW * (MAPL_PI_R8)/180._REAL64 - + END WHERE ! Modify grid coordinates diff --git a/base/MAPL_MemUtils.F90 b/base/MAPL_MemUtils.F90 index 0fdf59289a29..fa779616fbc1 100755 --- a/base/MAPL_MemUtils.F90 +++ b/base/MAPL_MemUtils.F90 @@ -22,6 +22,7 @@ module MAPL_MemUtilsMod use MAPL_ExceptionHandling use, intrinsic :: iso_fortran_env, only: INT64 use, intrinsic :: iso_fortran_env, only: REAL64 + use mpi !Author: Balaji (V.Balaji@noaa.gov) !Various operations for memory management @@ -78,8 +79,6 @@ module MAPL_MemUtilsMod integer, save :: MAPL_MemUtilsMode real, save :: gmax_save - include "mpif.h" - contains !******************************************************** diff --git a/base/MAPL_TripolarGridFactory.F90 b/base/MAPL_TripolarGridFactory.F90 index d44867b06121..02815e326045 100644 --- a/base/MAPL_TripolarGridFactory.F90 +++ b/base/MAPL_TripolarGridFactory.F90 @@ -33,7 +33,7 @@ module MAPL_TripolarGridFactoryMod integer :: ny = MAPL_UNDEFINED_INTEGER integer, allocatable :: ims(:) integer, allocatable :: jms(:) - + ! Used for halo type (ESMF_DELayout) :: layout integer :: px, py @@ -44,7 +44,7 @@ module MAPL_TripolarGridFactoryMod procedure :: add_horz_coordinates_from_file procedure :: init_halo procedure :: halo - + procedure :: initialize_from_file_metadata procedure :: initialize_from_config_with_prefix @@ -67,9 +67,9 @@ module MAPL_TripolarGridFactoryMod procedure :: decomps_are_equal procedure :: physical_params_are_equal end type TripolarGridFactory - + character(len=*), parameter :: MOD_NAME = 'MAPL_TripolarGridFactory::' - + interface TripolarGridFactory module procedure TripolarGridFactory_from_parameters end interface TripolarGridFactory @@ -102,7 +102,7 @@ function TripolarGridFactory_from_parameters(unusable, grid_file_name, grid_name integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'TripolarGridFactory_from_parameters' - + if (present(unusable)) print*,shape(unusable) call set_with_default(factory%grid_name, grid_name, MAPL_GRID_NAME_DEFAULT) @@ -147,13 +147,13 @@ function make_new_grid(this, unusable, rc) result(grid) end function make_new_grid - + function create_basic_grid(this, unusable, rc) result(grid) type (ESMF_Grid) :: grid class (TripolarGridFactory), intent(in) :: this class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - + integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'create_basic_grid' @@ -171,18 +171,18 @@ function create_basic_grid(this, unusable, rc) result(grid) poleKindFlag=[ESMF_POLEKIND_MONOPOLE,ESMF_POLEKIND_BIPOLE], & coordSys=ESMF_COORDSYS_SPH_RAD, rc=status) _VERIFY(status) - + ! Allocate coords at default stagger location call ESMF_GridAddCoord(grid, rc=status) _VERIFY(status) call ESMF_GridAddCoord(grid, staggerloc=ESMF_STAGGERLOC_CORNER, rc=status) _VERIFY(status) - + if (this%lm /= MAPL_UNDEFINED_INTEGER) then call ESMF_AttributeSet(grid, name='GRID_LM', value=this%lm, rc=status) _VERIFY(status) end if - + call ESMF_AttributeSet(grid, 'GridType', 'Tripolar', rc=status) _VERIFY(status) @@ -261,7 +261,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) centers=centers*MAPL_DEGREES_TO_RADIANS_R8 end if call MAPL_SyncSharedMemory(_RC) - + call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, & farrayPtr=fptr, rc=status) @@ -356,8 +356,8 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi this%jm_world = file_Metadata%get_dimension('Ydim',_RC) if (file_metadata%has_dimension('lev')) then this%lm = file_metadata%get_dimension('lev',_RC) - end if - + end if + this%grid_file_name=file_metadata%get_source_file() this%initialized_from_metadata = .true. @@ -414,7 +414,7 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc _RETURN(_SUCCESS) contains - + subroutine get_multi_integer(values, label, rc) integer, allocatable, intent(out) :: values(:) character(len=*) :: label @@ -425,7 +425,7 @@ subroutine get_multi_integer(values, label, rc) integer :: tmp integer :: status logical :: isPresent - + call ESMF_ConfigFindLabel(config, label=prefix//label,isPresent=isPresent,rc=status) _VERIFY(status) if (.not. isPresent) then @@ -458,7 +458,7 @@ subroutine get_multi_integer(values, label, rc) end subroutine get_multi_integer end subroutine initialize_from_config_with_prefix - + function to_string(this) result(string) @@ -493,7 +493,7 @@ subroutine check_and_fill_consistency(this, unusable, rc) call verify(this%ny, this%jm_world, this%jms, rc=status) !this%ims = spread(this%im_world / this%nx, 1, this%nx) !this%jms = spread(this%jm_world / this%ny, 1, this%ny) - + _RETURN(_SUCCESS) contains @@ -534,7 +534,7 @@ subroutine verify(n, m_world, ms, rc) _RETURN(_SUCCESS) end subroutine verify - + end subroutine check_and_fill_consistency @@ -542,27 +542,27 @@ elemental subroutine set_with_default_integer(to, from, default) integer, intent(out) :: to integer, optional, intent(in) :: from integer, intent(in) :: default - + if (present(from)) then to = from else to = default end if - + end subroutine set_with_default_integer - - + + subroutine set_with_default_character(to, from, default) character(len=:), allocatable, intent(out) :: to character(len=*), optional, intent(in) :: from character(len=*), intent(in) :: default - + if (present(from)) then to = from else to = default end if - + end subroutine set_with_default_character ! MAPL uses values in lon_array and lat_array only to determine the @@ -587,9 +587,9 @@ subroutine initialize_from_esmf_distGrid(this, dist_grid, lon_array, lat_array, _UNUSED_DUMMY(lon_array) _UNUSED_DUMMY(lat_array) - + ! not supported - _FAIL("tripolar initialize from distgrid non supported") + _FAIL("tripolar initialize from distgrid non supported") end subroutine initialize_from_esmf_distGrid @@ -608,12 +608,12 @@ function decomps_are_equal(this,a) result(equal) ! same decomposition equal = a%nx == this%nx .and. a%ny == this%ny if (.not. equal) return - + end select - + end function decomps_are_equal - + function physical_params_are_equal(this, a) result(equal) class (TripolarGridFactory), intent(in) :: this class (AbstractGridFactory), intent(in) :: a @@ -631,9 +631,9 @@ function physical_params_are_equal(this, a) result(equal) equal = (a%im_world == this%im_world) .and. (a%jm_world == this%jm_world) if (.not. equal) return - + end select - + end function physical_params_are_equal @@ -656,9 +656,9 @@ logical function equals(a, b) equals = a%physical_params_are_equal(b) if (.not. equals) return - + end select - + end function equals @@ -688,12 +688,12 @@ subroutine init_halo(this, unusable, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'init_halo' - + _UNUSED_DUMMY(unusable) grid = this%make_grid(rc=status) _VERIFY(status) - + call ESMF_GridGet(grid, distGrid=dist_grid, dimCount=dim_count, rc=status) _VERIFY(status) call ESMF_DistGridGet(dist_grid, delayout=this%layout, rc=status) @@ -704,7 +704,7 @@ subroutine init_halo(this, unusable, rc) call ESMF_VmGet(vm, localPet=pet, petCount=ndes, rc=status) _VERIFY(status) - + this%px = mod(pet, this%nx) this%py = pet / this%nx @@ -715,6 +715,7 @@ end subroutine init_halo subroutine halo(this, array, unusable, halo_width, rc) use MAPL_CommsMod + use mpi class (TripolarGridFactory), intent(inout) :: this real(kind=REAL32), intent(inout) :: array(:,:) class (KeywordEnforcer), optional, intent(in) :: unusable @@ -723,7 +724,6 @@ subroutine halo(this, array, unusable, halo_width, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'halo' - include 'mpif.h' integer :: pet_north integer :: pet_south @@ -773,7 +773,7 @@ integer function get_pet(px, py, nx, ny) result(pet) else pet = mod(px+nx,nx) + nx*mod(py+ny,ny) end if - + end function get_pet @@ -786,9 +786,9 @@ subroutine fill_north(array, rc) integer :: len, last - last = size(array,2)-1 + last = size(array,2)-1 len = size(array,1) - + if(this%py==this%ny-1) then call MAPL_CommsSendRecv(this%layout, & array(:,2 ), len, pet_south, & @@ -814,12 +814,12 @@ subroutine fill_north(array, rc) end do end block end if - + _RETURN(_SUCCESS) end subroutine fill_north - + subroutine fill_south(array, rc) use MAPL_BaseMod, only: MAPL_UNDEF real(kind=REAL32), intent(inout) :: array(:,:) @@ -830,7 +830,7 @@ subroutine fill_south(array, rc) integer :: len, last - last = size(array,2)-1 + last = size(array,2)-1 len = size(array,1) call MAPL_CommsSendRecv(this%layout, & @@ -854,10 +854,10 @@ subroutine fill_east(array, rc) integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'fill_east' - + integer :: len, last - last = size(array,2)-1 + last = size(array,2)-1 len = size(array,1) call MAPL_CommsSendRecv(this%layout, & @@ -874,28 +874,28 @@ end subroutine fill_east subroutine fill_west(array, rc) real(kind=REAL32), intent(inout) :: array(:,:) integer, optional, intent(out) :: rc - + integer :: status character(len=*), parameter :: Iam = MOD_NAME // 'fill_west' integer :: len, last - + last = size(array,1)-1 len = size(array,2) - + call MAPL_CommsSendRecv(this%layout, & array(last , : ), len, pet_west, & array(1 , : ), len, pet_east, & rc=status) _VERIFY(status) - + _RETURN(_SUCCESS) end subroutine fill_west end subroutine halo - + subroutine append_metadata(this, metadata) class (TripolarGridFactory), intent(inout) :: this type (FileMetadata), intent(inout) :: metadata @@ -913,12 +913,12 @@ subroutine append_metadata(this, metadata) do i=1,this%im_world fake_coord(i)=dble(i) enddo - + ! Coordinate variables v = Variable(type=PFIO_REAL64, dimensions='Xdim') call v%add_attribute('long_name', 'Fake Longitude for GrADS Compatibility') call v%add_attribute('units', 'degrees_east') - call v%add_const_value(UnlimitedEntity(fake_coord)) + call v%add_const_value(UnlimitedEntity(fake_coord)) call metadata%add_variable('Xdim', v) deallocate(fake_coord) @@ -931,7 +931,7 @@ subroutine append_metadata(this, metadata) call v%add_attribute('long_name', 'Fake Latitude for GrADS Compatibility') call v%add_attribute('units', 'degrees_north') call v%add_const_value(UnlimitedEntity(fake_coord)) - call metadata%add_variable('Ydim', v) + call metadata%add_variable('Ydim', v) deallocate(fake_coord) v = Variable(type=PFIO_REAL64, dimensions='Xdim,Ydim') diff --git a/base/NCIO.F90 b/base/NCIO.F90 index acae844fe9ce..63b4df68aec8 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -27,6 +27,7 @@ module NCIOMod use gFTL_StringVector use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env + use mpi implicit none private @@ -44,7 +45,6 @@ module NCIOMod public MAPL_VarReadNCPar public MAPL_VarWriteNCPar - include "mpif.h" include "netcdf.inc" interface MAPL_VarReadNCPar @@ -464,7 +464,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients _VERIFY(STATUS) if (associated(vr8_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then - + if (arrdes%write_restart_by_oserver) then if( MAPL_AM_I_ROOT() ) then lMemRef = LocalMemReference(pFIO_REAL64,[arrdes%im_world,size(vr8_2d,2)]) @@ -3911,10 +3911,10 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) else isGridCapture = .false. end if - + if (isGridCapture) then call add_fvar(cf, 'lons', pFIO_REAL64, 'lon,lat,', 'degrees east', 'lons', _RC) - call add_fvar(cf, 'lats', pFIO_REAL64, 'lon,lat,', 'degrees north', 'lats', _RC) + call add_fvar(cf, 'lats', pFIO_REAL64, 'lon,lat,', 'degrees north', 'lats', _RC) end if if (ungrid_dim_max_size /= 0) then @@ -4001,7 +4001,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) _VERIFY(status) end if end if - + enddo call ESMF_AttributeGet(bundle, name='MAPL_GridCapture', isPresent=isPresent, _RC) @@ -4010,7 +4010,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) else isGridCapture = .false. end if - + if (isGridCapture) then call ESMF_GridGet(arrdes%grid, name=fieldname, _RC) lons_field = ESMF_FieldCreate(grid=arrdes%grid, typekind=ESMF_TYPEKIND_R8, name='lons', _RC) @@ -4023,7 +4023,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) call ESMF_FieldGet(lons_field, farrayPtr=lons_field_ptr, _RC) call ESMF_FieldGet(lats_field, farrayPtr=lats_field_ptr, _RC) - + lons_field_ptr = grid_lons lats_field_ptr = grid_lats @@ -4198,9 +4198,9 @@ subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWr call ESMF_StateGet(state, itemnames(i), field, rc=status) _VERIFY(STATUS) call ESMF_FieldGet(field,array=array,rc=FieldIsValid) - + if (fieldIsValid == 0) then - + skipWriting = .false. if (.not. forceWriteNoRestart_) then call ESMF_AttributeGet(field, name='RESTART', isPresent=isPresent, rc=status) @@ -4213,13 +4213,13 @@ subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWr else skipWriting = .true. end if - + call ESMF_AttributeGet(state, name='MAPL_TestFramework', isPresent=isPresent, _RC) if (isPresent) then call ESMF_AttributeGet(state, name='MAPL_TestFramework', value=is_test_framework, _RC) if (is_test_framework) skipWriting = .false. end if - + if (skipWriting) cycle call ESMF_AttributeGet(field, name='doNotAllocate', isPresent=isPresent, rc=status) @@ -4229,7 +4229,7 @@ subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWr _VERIFY(STATUS) skipWriting = (dna /= 0) endif - + call ESMF_AttributeGet(state, name='MAPL_TestFramework', isPresent=isPresent, _RC) if (isPresent) then call ESMF_AttributeGet(state, name='MAPL_TestFramework', value=is_test_framework, _RC) @@ -4262,7 +4262,7 @@ subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWr call ESMF_AttributeGet(state, name='MAPL_GridCapture', value=isGridCapture, _RC) call ESMF_AttributeSet(bundle_write, name="MAPL_GridCapture", value=isGridCapture, _RC) end if - + call MAPL_BundleWriteNCPar(Bundle_Write, arrdes, CLOCK, filename, oClients=oClients, rc=status) _VERIFY(STATUS) diff --git a/base/cub2latlon_regridder.F90 b/base/cub2latlon_regridder.F90 index 02a5f8a29854..0c511d29cf17 100644 --- a/base/cub2latlon_regridder.F90 +++ b/base/cub2latlon_regridder.F90 @@ -952,8 +952,6 @@ subroutine write_metadata(this, rc) type (ESMF_VM) :: vm_global integer :: status - include 'mpif.h' - !$$ if (local_pet == 0) then call this%formatter_lat_lon%create_par(this%out_file, comm=MPI_COMM_WORLD, rc=status) _VERIFY(status) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 65d5760f751a..8737508c9bfd 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -75,7 +75,7 @@ ! MAPL_GenericSetServices and MAPL_Generic IRF methods cannot create their own ESMF grid. ! The grid must be inherited from the parent or created by the component ! either in its own SetServices or in its Initialize, if it is writing one. -! In any case, an important assumption of MAPL is that the grid must already be +! In any case, an important assumption of MAPL is that the grid must already be ! *present in the component and initialized* when MAPL_GenericSetServices is invoked. ! The same is true of the configuration. ! @@ -1715,7 +1715,7 @@ subroutine create_export_state_variables(rc) if (restoreExport) then call MAPL_GetResource( STATE, FILENAME, LABEL='EXPORT_RESTART_FILE:', _RC) if(status==ESMF_SUCCESS) then - + call MAPL_ESMFStateReadFromFile(EXPORT, CLOCK, FILENAME, & STATE, .FALSE., rc=status) if (status /= ESMF_SUCCESS) then @@ -1727,7 +1727,7 @@ subroutine create_export_state_variables(rc) endif end if end if - + call ESMF_AttributeSet(export,'POSITIVE',trim(positive),_RC) _RETURN(ESMF_SUCCESS) @@ -1903,7 +1903,7 @@ recursive subroutine MAPL_GenericWrapper ( GC, IMPORT, EXPORT, CLOCK, RC) _ASSERT(userRC==ESMF_SUCCESS .and. STATUS==ESMF_SUCCESS,'Error during '//stage_description//' for <'//trim(COMP_NAME)//'>') end if - + if (comp_name == comp_to_record) then call record_component('after', phase, method, GC, import, export, clock, _RC) end if @@ -1955,7 +1955,7 @@ subroutine record_component(POS, PHASE, METHOD, GC, IMPORT, EXPORT, CLOCK, RC) type(ESMF_State), intent(INOUT) :: EXPORT ! Export state type(ESMF_Clock), intent(INOUT) :: CLOCK ! The clock integer, optional, intent( OUT) :: RC ! Error code: - + type (MAPL_MetaComp), pointer :: STATE logical :: is_test_framework, is_test_framework_driver logical :: is_grid_capture, restore_export @@ -1987,7 +1987,7 @@ subroutine capture(POS, PHASE, GC, IMPORT, EXPORT, CLOCK, RC) type(ESMF_State), intent(INOUT) :: EXPORT ! Export state type(ESMF_Clock), intent(INOUT) :: CLOCK ! The clock integer, optional, intent( OUT) :: RC ! Error code: - + type (MAPL_MetaComp), pointer :: STATE integer :: status character(len=ESMF_MAXSTR) :: filename, comp_name, time_label @@ -1996,7 +1996,7 @@ subroutine capture(POS, PHASE, GC, IMPORT, EXPORT, CLOCK, RC) integer :: hdr type(ESMF_Time) :: start_time, curr_time, target_time character(len=1) :: phase_ - + call ESMF_GridCompGet(GC, NAME=comp_name, _RC) call MAPL_InternalStateGet (GC, STATE, _RC) @@ -2008,7 +2008,7 @@ subroutine capture(POS, PHASE, GC, IMPORT, EXPORT, CLOCK, RC) else target_time = parse_time_string(time_label, _RC) end if - + filetype = 'pnc4' filename = trim(comp_name)//"_" @@ -2020,10 +2020,10 @@ subroutine capture(POS, PHASE, GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_ESMFStateWriteToFile(import, CLOCK, trim(FILENAME)//"import_"//trim(POS)//"_runPhase"//phase_, & FILETYPE, STATE, .false., _RC) - + call MAPL_ESMFStateWriteToFile(export, CLOCK, trim(FILENAME)//"export_"//trim(POS)//"_runPhase"//phase_, & FILETYPE, STATE, .false., oClients = o_Clients, _RC) - + call MAPL_GetResource(STATE, hdr, default=0, LABEL="INTERNAL_HEADER:", _RC) call MAPL_ESMFStateWriteToFile(internal, CLOCK, trim(FILENAME)//"internal_"//trim(POS)//"_runPhase"//phase_, & FILETYPE, STATE, hdr/=0, oClients = o_Clients, _RC) @@ -2203,7 +2203,7 @@ recursive subroutine MAPL_GenericRunChildren ( GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_TimerOn (STATE,trim(CHILD_NAME)) child_import_state => STATE%get_child_import_state(i) - child_export_state => STATE%get_child_export_state(i) + child_export_state => STATE%get_child_export_state(i) call ESMF_GridCompRun (gridcomp, & importState=child_import_state, & @@ -4155,7 +4155,7 @@ end subroutine MAPL_InternalStateGet !- **GIM** The childrens' IMPORT states. !- **GEX** The childrens' EXPORT states. !- **CCS** Array of child-to-child couplers. -! +! subroutine MAPL_GenericStateGet (STATE, IM, JM, LM, VERTDIM, & NX, NY, NX0, NY0, LAYOUT, & GCNames, & @@ -5995,7 +5995,7 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli !call MPI_Barrier(mpl%grid%comm, status) !_VERIFY(status) - !itime_beg = MPI_Wtime(status) + !itime_beg = MPI_Wtime() !_VERIFY(status) call MAPL_VarWriteNCPar(filename,STATE,ArrDes,CLOCK, oClients=oClients, RC=status) @@ -6003,7 +6003,7 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli !call MPI_Barrier(mpl%grid%comm, status) !_VERIFY(status) - !itime_end = MPI_Wtime(status) + !itime_end = MPI_Wtime() !total_time = total_time + itime_end - itime_beg !_VERIFY(status) !call MPI_COMM_RANK(mpl%grid%comm, io_rank, status) @@ -6370,7 +6370,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _VERIFY(status) _RETURN(ESMF_SUCCESS) - + contains function grid_is_consistent(grid_type, fname) result( consistent) logical :: consistent @@ -6382,7 +6382,7 @@ function grid_is_consistent(grid_type, fname) result( consistent) class (AbstractGridFactory), allocatable :: file_factory character(len=:), allocatable :: fname_by_face logical :: fexist - + consistent = .True. if (trim(grid_type) == 'Cubed-Sphere') then app_factory => get_factory(MPL%GRID%ESMFGRID) @@ -8522,7 +8522,7 @@ subroutine MAPL_GetResourceFromConfig_scalar(config, val, label, default, rc) logical :: value_is_set 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 @@ -8545,15 +8545,15 @@ subroutine MAPL_GetResourceFromMAPL_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) - + if(.not. value_is_set) then if (present(rc)) rc = ESMF_FAILURE return end if - + _VERIFY(status) _RETURN(_SUCCESS) @@ -8572,12 +8572,12 @@ subroutine MAPL_GetResourceFromConfig_array(config, vals, label, default, rc) call MAPL_GetResource_config_array(config, vals, 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) diff --git a/gridcomps/Cap/MAPL_CapGridComp.F90 b/gridcomps/Cap/MAPL_CapGridComp.F90 index 70af546dd8e3..0b6da8df6235 100644 --- a/gridcomps/Cap/MAPL_CapGridComp.F90 +++ b/gridcomps/Cap/MAPL_CapGridComp.F90 @@ -34,6 +34,7 @@ module MAPL_CapGridCompMod #ifdef BUILD_WITH_PFLOGGER use mapl_SimulationTime, only: set_reference_clock #endif + use mpi use iso_fortran_env @@ -104,8 +105,6 @@ module MAPL_CapGridCompMod type(MAPL_CapGridComp), pointer :: ptr => null() end type MAPL_CapGridComp_Wrapper - include "mpif.h" - character(len=*), parameter :: Iam = __FILE__ contains @@ -1143,7 +1142,7 @@ subroutine run_MAPL_GridComp(gc, phase, rc) if (cap%compute_throughput) then call ESMF_VMBarrier(cap%vm,rc=status) _VERIFY(status) - cap%starts%loop_start_timer = MPI_WTime(status) + cap%starts%loop_start_timer = MPI_WTime() cap%started_loop_timer = .true. end if @@ -1172,7 +1171,7 @@ subroutine run_MAPL_GridComp(gc, phase, rc) if (n == 1 .and. cap%compute_throughput) then call ESMF_VMBarrier(cap%vm,rc=status) _VERIFY(status) - cap%starts%loop_start_timer = MPI_WTime(status) + cap%starts%loop_start_timer = MPI_WTime() endif enddo TIME_LOOP ! end of time loop @@ -1231,10 +1230,10 @@ subroutine first_phase(rc) if (this%compute_throughput) then if (.not.this%started_loop_timer) then - this%starts%loop_start_timer = MPI_WTime(status) + this%starts%loop_start_timer = MPI_WTime() this%started_loop_timer=.true. end if - this%starts%start_timer = MPI_Wtime(status) + this%starts%start_timer = MPI_Wtime() end if call ESMF_GridCompRun(this%gcs(this%extdata_id), importState = this%child_imports(this%extdata_id), & @@ -1256,7 +1255,7 @@ subroutine first_phase(rc) if (this%compute_throughput) then call ESMF_VMBarrier(this%vm,rc=status) _VERIFY(status) - this%starts%start_run_timer = MPI_WTime(status) + this%starts%start_run_timer = MPI_WTime() end if _RETURN(_SUCCESS) @@ -1270,7 +1269,7 @@ subroutine last_phase(rc) if (this%compute_throughput) then call ESMF_VMBarrier(this%vm,rc=status) _VERIFY(status) - end_run_timer = MPI_WTime(status) + end_run_timer = MPI_WTime() end if call ESMF_ClockAdvance(this%clock, rc = status) @@ -1329,7 +1328,7 @@ subroutine print_throughput(rc) ! Call system clock to estimate throughput simulated Days/Day call ESMF_VMBarrier( this%vm, RC=STATUS ) _VERIFY(STATUS) - END_TIMER = MPI_Wtime(status) + END_TIMER = MPI_Wtime() n=this%get_step_counter() !GridCompRun Timer [Inst] RUN_THROUGHPUT = REAL( this%HEARTBEAT_DT,kind=REAL64)/(END_RUN_TIMER-this%starts%start_run_timer) diff --git a/gridcomps/Cap/MAPL_NUOPCWrapperMod.F90 b/gridcomps/Cap/MAPL_NUOPCWrapperMod.F90 index a5981bb6fd26..baf74b993de5 100644 --- a/gridcomps/Cap/MAPL_NUOPCWrapperMod.F90 +++ b/gridcomps/Cap/MAPL_NUOPCWrapperMod.F90 @@ -20,6 +20,7 @@ module MAPL_NUOPCWrapperMod use MAPL_Profiler, only: BaseProfiler, get_global_time_profiler use pflogger, only: pfl_initialize => initialize use mapl_CapOptionsMod + use mpi implicit none private @@ -58,8 +59,6 @@ end subroutine set_services_interface type(cap_parameters), pointer :: ptr end type cap_parameters_wrapper -#include "mpif.h" - contains subroutine SetServices(model, rc) type(ESMF_GridComp) :: model diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 0e1268938e26..6569a303ce35 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -59,6 +59,7 @@ module MAPL_HistoryGridCompMod use gFTL_StringStringMap !use ESMF_CFIOMOD use pflogger, only: Logger, logging + use mpi implicit none private @@ -142,8 +143,6 @@ module MAPL_HistoryGridCompMod public HISTORY_ExchangeListWrap - include "mpif.h" - contains !===================================================================== @@ -3400,7 +3399,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! write(6,'(10a)') 'trim(INTSTATE%expid)', trim(INTSTATE%expid) ! write(6,'(2x,a,10i20)') 'nymd, nhms', nymd, nhms - + call fill_grads_template ( filename(n), fntmpl, & experiment_id=trim(INTSTATE%expid), & nymd=nymd, nhms=nhms, _RC ) ! here is where we get the actual filename of file we will write @@ -3409,7 +3408,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! write(6,'(a)') 'filename(n), fntmpl=', trim(filename(n)), trim(fntmpl) ! write(6,'(10a)') 'trim(INTSTATE%expid)', trim(INTSTATE%expid) ! write(6,'(2x,a,10i20)') 'nymd, nhms', nymd, nhms - + if(list(n)%monthly .and. list(n)%partial) then filename(n)=trim(filename(n)) // '-partial' diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index 401b12ad87ca..93004e7604eb 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -19,12 +19,12 @@ module pFIO_NetCDF4_FileFormatterMod use pFIO_StringAttributeMapMod use pfio_NetCDF_Supplement use netcdf + use mpi implicit none private public :: NetCDF4_FileFormatter - include 'mpif.h' type :: NetCDF4_FileFormatter !$$ private character(len=:), allocatable :: origin_file @@ -678,12 +678,12 @@ subroutine add_variable(this, cf, varname, unusable, rc) integer:: status !$omp critical - status=nf90_redef(this%ncid) + status=nf90_redef(this%ncid) !$omp end critical _VERIFY(status) call this%def_variables(cf, varname=varname, _RC) !$omp critical - status=nf90_enddef(this%ncid) + status=nf90_enddef(this%ncid) !$omp end critical _VERIFY(status) _RETURN(_SUCCESS) diff --git a/shared/Shmem/Shmem.F90 b/shared/Shmem/Shmem.F90 index 7247ec5c5cfd..5b0e6104573c 100644 --- a/shared/Shmem/Shmem.F90 +++ b/shared/Shmem/Shmem.F90 @@ -7,12 +7,11 @@ module MAPL_Shmem use, intrinsic :: ISO_C_BINDING use, intrinsic :: ISO_FORTRAN_ENV, only: REAL64, REAL32 use MAPL_Constants + use mpi implicit none private - include 'mpif.h' - public :: MAPL_GetNodeInfo public :: MAPL_CoresPerNodeGet public :: MAPL_InitializeShmem From 1e41de6725501473897e5cfe373c27fd73769816 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 31 Aug 2023 16:20:40 -0400 Subject: [PATCH 02/13] Convert all uses of character* --- Apps/time_ave_util.F90 | 2 +- MAPL_cfio/ESMF_CFIOEosMod.F90 | 348 ++++----- MAPL_cfio/ESMF_CFIOMod.F90 | 530 +++++++------- MAPL_cfio/ESMF_CFIOSdfMod.F90 | 796 ++++++++++----------- MAPL_cfio/ESMF_CFIOUtilMod.F90 | 108 +-- MAPL_cfio/netcdf_stub.F90 | 4 +- base/Base/Base_Base_implementation.F90 | 232 +++--- base/ESMFL_Mod.F90 | 20 +- base/MAPL_CFIO.F90 | 2 +- base/MAPL_LocStreamMod.F90 | 6 +- base/MAPL_MaxMinMod.F90 | 20 +- base/Regrid_Functions_Mod.F90 | 68 +- base/cub2latlon_regridder.F90 | 2 +- base/sun.H | 32 +- base/tests/testbin.F90 | 10 +- generic/MAPL_Generic.F90 | 12 +- gridcomps/History/MAPL_HistoryGridComp.F90 | 4 +- gridcomps/Orbit/MAPL_OrbGridCompMod.F90 | 164 ++--- pfio/HistoryCollection.F90 | 27 +- profiler/AbstractMeter.F90 | 5 +- profiler/TimeProfiler.F90 | 5 +- shared/MAPL_ErrorHandling.F90 | 30 +- shared/MAPL_ISO8601_DateTime.F90 | 22 +- shared/MAPL_LoadBalance.F90 | 28 +- shared/Shmem/Shmem.F90 | 2 +- 25 files changed, 1240 insertions(+), 1239 deletions(-) diff --git a/Apps/time_ave_util.F90 b/Apps/time_ave_util.F90 index a275e9c4bc3e..7f0190788d30 100644 --- a/Apps/time_ave_util.F90 +++ b/Apps/time_ave_util.F90 @@ -1475,7 +1475,7 @@ subroutine latlon_zmean ( q,qz,undef,grid,rc) if (isum == 0) then qz(j)=undef else - qz(j)=qsum/float(isum) + qz(j)=qsum/real(isum) end if enddo diff --git a/MAPL_cfio/ESMF_CFIOEosMod.F90 b/MAPL_cfio/ESMF_CFIOEosMod.F90 index fdc98725aa7b..b721d9492219 100644 --- a/MAPL_cfio/ESMF_CFIOEosMod.F90 +++ b/MAPL_cfio/ESMF_CFIOEosMod.F90 @@ -11,7 +11,7 @@ ! `ESMF_CFIOEosMod` - Source file for CFIO ! ! The module `ESMF_CFIOEosMod` provides data type definitions and interface -! specifications. It provides all the necessary subroutines for users to +! specifications. It provides all the necessary subroutines for users to ! write/read HDF format output using CF convention. ! !#### History @@ -28,7 +28,7 @@ ! problem. Fixed standard_name problem in reading CFIO files. !- Mar2005 Baoyu Yin Moved some utility routines into ESMF_CFIOUtil.F90 ! Modified error return codes. -! +! module ESMF_CFIOEosMod ! @@ -73,25 +73,25 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -1 Time increment is 0 - !! -2 allocate memory error - !! -3 Num of int/char/real elements and Cnt don't match - !! -12 error determining default precision - !! -18 incorrect time increment - !! -30 can't open file - !! -31 error from NF90_DEF_DIM - !! -32 error from NF90_DEF_VAR (dimension variable) - !! -33 error from NF90_PUT_ATT (dimension attribute) - !! -34 error from NF90_DEF_VAR (variable) - !! -35 error from NF90_PUT_ATT (variable attribute) - !! -36 error from NF90_PUT_ATT (global attribute) - !! -37 error from NF90_ENDDEF - !! -38 error from NF90_PUT_VAR (dimension variable) - !! -39 Num of real var elements and Cnt differ - !! -55 error from NF90_REDEF (enter define mode) - !! -56 error from NF90_ENDDEF (exit define mode) + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -1 Time increment is 0 + !! -2 allocate memory error + !! -3 Num of int/char/real elements and Cnt don't match + !! -12 error determining default precision + !! -18 incorrect time increment + !! -30 can't open file + !! -31 error from NF90_DEF_DIM + !! -32 error from NF90_DEF_VAR (dimension variable) + !! -33 error from NF90_PUT_ATT (dimension attribute) + !! -34 error from NF90_DEF_VAR (variable) + !! -35 error from NF90_PUT_ATT (variable attribute) + !! -36 error from NF90_PUT_ATT (global attribute) + !! -37 error from NF90_ENDDEF + !! -38 error from NF90_PUT_VAR (dimension variable) + !! -39 Num of real var elements and Cnt differ + !! -55 error from NF90_REDEF (enter define mode) + !! -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------------ integer :: i, n, maxLen, rtcode @@ -112,8 +112,8 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) valid_range(2,i) = cfio%varObjs(i)%validRange(2) packing_range(1,i) = cfio%varObjs(i)%packingRange(1) packing_range(2,i) = cfio%varObjs(i)%packingRange(2) - enddo - + enddo + call EOS_Create_ (cfio, trim(cfio%fName), trim(cfio%title), trim(cfio%source), & trim(cfio%contact), cfio%varObjs(1)%amiss, & cfio%grids(1)%im, cfio%grids(1)%jm, cfio%grids(1)%km, cfio%grids(1)%lon, & @@ -128,21 +128,21 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + call EOS_PutCharAtt(cfio%fid, 'title', len(trim(cfio%title)), & cfio%title, rtcode ) if (err("can't write title",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if - + call EOS_PutCharAtt(cfio%fid, 'history', len(trim(cfio%history)), & cfio%history, rtcode ) if (err("can't write history",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if - + call EOS_PutCharAtt(cfio%fid,'institution', & len(trim(cfio%institution)), & cfio%institution, rtcode ) @@ -164,7 +164,7 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + call EOS_PutCharAtt(cfio%fid,'comment',len(trim(cfio%comment)), & cfio%comment, rtcode ) if (err("can't write comment",rtcode,rtcode) .lt. 0) then @@ -178,7 +178,7 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + ! get integer attributes from iList if ( associated(cfio%iList) ) then call getMaxLenCnt(maxLen, cfio%nAttInt, iList=cfio%iList) @@ -189,11 +189,11 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + call getList(iList=cfio%iList, intAttNames=cfio%attIntNames, & intAttCnts=cfio%attIntCnts, intAtts=cfio%attInts ) end if - + ! write user defined integer attributes if ( cfio%nAttInt .gt. 0 ) then do i = 1, cfio%nAttInt @@ -203,7 +203,7 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + call EOS_PutIntAtt(cfio%fid, cfio%attIntNames(i), & cfio%attIntCnts(i), cfio%attInts(i,:), & cfio%prec, rtcode ) @@ -211,10 +211,10 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + end do end if - + ! get real attributes from rList if ( associated(cfio%rList) ) then call getMaxLenCnt(maxLen, cfio%nAttReal, rList=cfio%rList) @@ -225,13 +225,13 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) if ( present(rc) ) rc = rtcode return end if - + call getList(rList=cfio%rList, realAttNames=cfio%attRealNames, & realAttCnts=cfio%attRealCnts, realAtts=cfio%attReals ) do i = 1, cfio%nAttReal end do end if - + ! write user defined real attributes if ( cfio%nAttReal .gt. 0 ) then do i = 1, cfio%nAttReal @@ -251,7 +251,7 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) end if end do end if - + ! get char attributes from cList if ( associated(cfio%cList) ) then call getMaxLenCnt(maxLen, cfio%nAttChar, cList=cfio%cList) @@ -265,7 +265,7 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) call getList(cList=cfio%cList, charAttNames=cfio%attCharNames, & charAttCnts=cfio%attCharCnts, charAtts=cfio%attChars ) end if - + ! write user defined char attributes if ( cfio%nAttChar .gt. 0 ) then do i = 1, cfio%nAttChar @@ -278,7 +278,7 @@ subroutine ESMF_CFIOEosFileCreate (cfio, rc) end if end do end if - + cfio%isOpen = .true. rtcode = 0 @@ -296,8 +296,8 @@ subroutine ESMF_CFIOEosVarWrite3D_(cfio, vName, field, date, curTime, kbeg, & ! ! !INPUT PARAMETERS: ! - type(ESMF_CFIO), intent(in) :: cfio !! a CFIO obj - character(len=*), intent(in) :: vName !! Variable name + type(ESMF_CFIO), intent(in) :: cfio !! a CFIO obj + character(len=*), intent(in) :: vName !! Variable name real, intent(in) :: field(:,:,:) !! array contains data integer, intent(in), OPTIONAL :: date !! yyyymmdd integer, intent(in), OPTIONAL :: curTime !! hhmmss @@ -312,29 +312,29 @@ subroutine ESMF_CFIOEosVarWrite3D_(cfio, vName, field, date, curTime, kbeg, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_PUT_VAR - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_PUT_VAR + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT ! !------------------------------------------------------------------------------ @@ -342,7 +342,7 @@ subroutine ESMF_CFIOEosVarWrite3D_(cfio, vName, field, date, curTime, kbeg, & integer :: myKbeg, myKount integer :: myDate, myCurTime logical :: do_comp, do_chunk - + do_comp = .false. do_chunk = .false. @@ -359,7 +359,7 @@ subroutine ESMF_CFIOEosVarWrite3D_(cfio, vName, field, date, curTime, kbeg, & end do ! write 2D variable - if ( cfio%varObjs(i)%twoDimVar ) then + if ( cfio%varObjs(i)%twoDimVar ) then call EOS_PutVar (cfio%fid, vName, myDate, myCurTime, & cfio%varObjs(i)%grid%im, cfio%varObjs(i)%grid%jm, & 0, 1, field, do_comp, do_chunk, rtcode ) @@ -372,7 +372,7 @@ subroutine ESMF_CFIOEosVarWrite3D_(cfio, vName, field, date, curTime, kbeg, & myKbeg = 1 myKount = cfio%varObjs(i)%grid%km - if ( present(kbeg) ) myKbeg = kbeg + if ( present(kbeg) ) myKbeg = kbeg if ( present(kount) ) myKount = kount call EOS_PutVar (cfio%fid, vName, myDate, myCurTime, & @@ -410,18 +410,18 @@ subroutine ESMF_CFIOEosVarWrite1D_(cfio, vName, field, date, curTime, & logical, intent(in), OPTIONAL :: doComp !! do szip compression logical, intent(in), OPTIONAL :: doChunk !! do szip compression !! string expression for date and time - + ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well ! !------------------------------------------------------------------------------ integer :: i, rtcode integer :: myDate, myCurTime logical :: do_comp, do_chunk - + do_comp = .false. do_chunk = .false. @@ -435,7 +435,7 @@ subroutine ESMF_CFIOEosVarWrite1D_(cfio, vName, field, date, curTime, & do i = 1, cfio%mVars if ( trim(vName) .eq. trim(cfio%varObjs(i)%vName) ) exit end do - + ! NEED WORK HERE if (index(cfio%varObjs(i)%grid%gName,'station') .gt. 0) then ! call CFIO_SPutVar (cfio%fid, vName, myDate, myCurTime, & @@ -455,10 +455,10 @@ subroutine ESMF_CFIOEosVarWrite1D_(cfio, vName, field, date, curTime, & end if if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOEosVarWrite1D_ - - + + !------------------------------------------------------------------------------ ! ! `ESMF_CFIOEosVarWrite2D_` -- Write a variable to a output file. @@ -479,22 +479,22 @@ subroutine ESMF_CFIOEosVarWrite2D_(cfio, vName, field, date, curTime, kbeg, & logical, intent(in), OPTIONAL :: doComp !! do szip compression logical, intent(in), OPTIONAL :: doChunk !! do szip compression !! string expression for date and time - + ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well ! !------------------------------------------------------------------------------ integer :: i, rtcode integer :: myKbeg, myKount integer :: myDate, myCurTime logical :: do_comp, do_chunk - + do_comp = .false. do_chunk = .false. - + if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) @@ -505,7 +505,7 @@ subroutine ESMF_CFIOEosVarWrite2D_(cfio, vName, field, date, curTime, kbeg, & do i = 1, cfio%mVars if ( trim(vName) .eq. trim(cfio%varObjs(i)%vName) ) exit end do - + ! write 2D variable if (index(cfio%varObjs(i)%grid%gName,'station') .gt. 0) then if ( cfio%varObjs(i)%twoDimVar ) then @@ -542,15 +542,15 @@ subroutine ESMF_CFIOEosVarWrite2D_(cfio, vName, field, date, curTime, kbeg, & end if end if - + if ( cfio%varObjs(i)%timAve ) then call writeBnds(cfio, vName, myDate, myCurTime, rtcode) end if if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOEosVarWrite2D_ - + !------------------------------------------------------------------------------ !> @@ -560,9 +560,9 @@ subroutine ESMF_CFIOEosFileClose (cfio, rc) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -54 error from NF90_CLOSE (file close) + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -54 error from NF90_CLOSE (file close) ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -578,7 +578,7 @@ subroutine ESMF_CFIOEosFileClose (cfio, rc) else cfio%isOpen = .false. end if - + else rtcode = 0 end if @@ -598,23 +598,23 @@ subroutine writeBnds(cfio, vName, date, curTime, rc) ! type (ESMF_CFIO), intent(in) :: cfio character(len=*), intent(in) :: vName - integer, intent(in) :: date + integer, intent(in) :: date integer, intent(in) :: curTime ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! 1 ... + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! 1 ... ! !------------------------------------------------------------------------------ - integer :: sds_index, sfwdata, sfselect, sfn2index + integer :: sds_index, sfwdata, sfselect, sfn2index integer :: sfsnatt, sfendacc integer :: sds_id, corner(4), edges(4), stride(4) integer :: hour, min, sec, incSecs, timeIndex integer :: seconds, timeinc, curSecs real*4 :: bndsdata(2) - character*8 :: strBuf + character(len=8) :: strBuf integer :: i, rtcode=0 ! make sure user provides the right variable name @@ -629,11 +629,11 @@ subroutine writeBnds(cfio, vName, date, curTime, rc) read (strBuf,204) hour, min, sec 204 format (3I2) incSecs = hour*3600 + min*60 + sec - + write (strBuf,203) curTime read (strBuf,204) hour, min, sec curSecs = hour*3600 + min*60 + sec - + timeIndex = seconds/incSecs + 1 corner(1) = 0 corner(2) = timeIndex-1 @@ -651,23 +651,23 @@ subroutine writeBnds(cfio, vName, date, curTime, rc) bndsdata(1) = curSecs/60. bndsdata(2) = (incSecs + curSecs)/60. end if - + sds_index = sfn2index(cfio%sd_id, 'time_bnds') sds_id = sfselect(cfio%sd_id, sds_index) rtcode = sfwdata (sds_id, corner, stride, edges, bndsdata) - if ( rtcode .ne. 0 ) then + if ( rtcode .ne. 0 ) then print *, "sfwdata failed in time_bnds" if ( present(rc) ) rc = rtcode return end if rtcode = sfendacc(sds_id) end if - + if ( present(rc) ) rc = rtcode end subroutine writeBnds - + !------------------------------------------------------------------------------ !> @@ -699,53 +699,53 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & ! ! !USES: ! - Implicit NONE + Implicit NONE ! -! !INPUT PARAMETERS: +! !INPUT PARAMETERS: ! ! ------- Global Metadata ------ - character*(*) fname !! File name - character*(*) title !! A title for the data set - character*(*) source !! Source of data, e.g. NASA/DAO - character*(*) contact !! Who to contact about the data set, e.g., + character(len=*) fname !! File name + character(len=*) title !! A title for the data set + character(len=*) source !! Source of data, e.g. NASA/DAO + character(len=*) contact !! Who to contact about the data set, e.g., !! 'Contact data@dao.gsfc.nasa.gov' real amiss !! Missing value such as 1.0E15 ! ------- Dimension Metadata ------- integer im !! size of longitudinal dimension integer jm !! size of latitudinal dimension - integer km !! size of vertical dimension + integer km !! size of vertical dimension !! (surface only=1) - real*8 lon(im) !! longitude of center of gridbox in - !! degrees east of Greenwich (can be + real*8 lon(im) !! longitude of center of gridbox in + !! degrees east of Greenwich (can be !! -180 -> 180 or 0 -> 360) - real*8 lat(jm) !! latitude of center of gridbox in + real*8 lat(jm) !! latitude of center of gridbox in !! degrees north of equator real*8 levs(km) !! Level (units given by levunits) of !! center of gridbox - character*(*) levunits !! units of level dimension, e.g., + character(len=*) levunits !! units of level dimension, e.g., !! "millibar", "hPa", or "sigma_level" - integer yyyymmdd_beg !! First year-month-day to be written + integer yyyymmdd_beg !! First year-month-day to be written integer hhmmss_beg !! First hour-minute-second to be written integer timinc !! Increment between output times (HHMMSS) ! ------- Variable Metadata ------- integer nvars !! number of variables in file - character*(*) vname(nvars) !! variable short name, e.g., "hght" - character*(*) vtitle(nvars) !! variable long name, e.g., + character(len=*) vname(nvars) !! variable short name, e.g., "hght" + character(len=*) vtitle(nvars) !! variable long name, e.g., !! "Geopotential Height" - character*(*) vunits(nvars) !! variable units, e.g., "meter/second" + character(len=*) vunits(nvars) !! variable units, e.g., "meter/second" integer kmvar(nvars) !! number of levels for variable; it can !! either be 0 (2-D fields) or equal to km real valid_range(2,nvars) !! Variable valid range; EOS_PutVar - !! will return a non-fatal error if a value is + !! will return a non-fatal error if a value is !! outside of this range. IMPORTANT: If packing !! is not desired for a given variable, YOU MUST !! set both components of valid_range to amiss. ! ------ Packing Metadata ---- - real packing_range(2,nvars) !! Packing range to be used for 16-bit packing - !! of each variable. IMPORTANT: If packing is not + real packing_range(2,nvars) !! Packing range to be used for 16-bit packing + !! of each variable. IMPORTANT: If packing is not !! desired for a given variable, YOU MUST set both !! components of packing_range to amiss. !! NOTE: @@ -756,33 +756,33 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & integer prec !! Desired precision of data: !! 0 = 32 bit !! 1 = 64 bit - !! NOTE: mixing precision in the same - !!* Mixing 32 and 64 bit precision in the + !! NOTE: mixing precision in the same + !!* Mixing 32 and 64 bit precision in the !! same file is not supported. !!* If packing is turned on for a variable, !! the prec flag is ignored. - + ! ! !OUTPUT PARAMETERS: ! integer fid !! File handle - integer rc !! Error return code: - !! rc = 0 all is well - !! rc = -1 time increment is 0 - !! rc = -18 incorrect time increment - !! - !! NetCDF Errors - !! ------------- - !! rc = -30 error creating file - !! rc = -31 error defining a coordinate (dimension) - !! rc = -32 error detaching from grid - !! rc = -33 error associating a dimension with a variable - !! rc = -34 error defining a variable - !! rc = -35 error defining a variable attribute - !! rc = -36 error creating a global attribute - !! rc = -37 error attaching to grid (HDFEOS) - !! rc = -38 error writing a coordinate (dimension) - !! rc = -59 variable name contains only blanks + integer rc !! Error return code: + !! rc = 0 all is well + !! rc = -1 time increment is 0 + !! rc = -18 incorrect time increment + !! + !! NetCDF Errors + !! ------------- + !! rc = -30 error creating file + !! rc = -31 error defining a coordinate (dimension) + !! rc = -32 error detaching from grid + !! rc = -33 error associating a dimension with a variable + !! rc = -34 error defining a variable + !! rc = -35 error defining a variable attribute + !! rc = -36 error creating a global attribute + !! rc = -37 error attaching to grid (HDFEOS) + !! rc = -38 error writing a coordinate (dimension) + !! rc = -59 variable name contains only blanks ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -804,11 +804,11 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & integer dims3D(4), dims2D(3), bnd_dim(2) integer bnd_id, tim_id integer corner(4), edges(4) - character*80 timeUnits - character*(MAXCHR) dimName, dimUnits + character(len=80) timeUnits + character(len=MAXCHR) dimName, dimUnits logical surfaceOnly - character*8 strBuf - character*14 dateString + character(len=8) strBuf + character(len=14) dateString integer year,mon,day,hour,min,sec integer rct integer timeSteps @@ -820,7 +820,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & real*4 pRange_32(2,nvars),vRange_32(2,nvars) logical packflag -! Set metadata strings. These metadata values are specified in the +! Set metadata strings. These metadata values are specified in the ! COARDS conventions character (len=50) :: lonName = "longitude" @@ -836,7 +836,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & character (len=50) :: missing = "missing_value" ! NEW VARIABLES FOR SD INTERFACE - + ! Functions integer sfstart @@ -884,20 +884,20 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & integer gridId real*8, dimension(2) :: uplft = (/-180000000.00, 90000000.00/) real*8, dimension(2) :: lwrgt = (/180000000.00, -90000000.00/) - character*100 cdims2D - character*100 cdims3D - character*100 cdims + character(len=100) cdims2D + character(len=100) cdims3D + character(len=100) cdims integer dims, numType integer start(4), edge(4) - + ! Internal CFIO functions - character (len=60) :: lonStr - character (len=60) :: latStr - character (len=60) :: levStr - character (len=60) :: timStr + character (len=60) :: lonStr + character (len=60) :: latStr + character (len=60) :: levStr + character (len=60) :: timStr logical :: aveFile = .false. character cellMthd amiss_16 = PACK_FILL @@ -905,7 +905,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & if (cfio%tSteps .gt. 0) then timeSteps = cfio%tSteps - else + else timeSteps = SD_UNLIMITED end if @@ -936,7 +936,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & do i=1,nvars if ( cfio%varObjs(i)%timAve ) then aveFile = .true. - cellMthd = cfio%varObjs(i)%cellMthd + cellMthd = cfio%varObjs(i)%cellMthd end if enddo @@ -979,7 +979,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & ! Open new file. -#if defined(HDFSD) +#if defined(HDFSD) ! Create file. sd_id = sfstart (fname, DFACC_CREATE) @@ -989,7 +989,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & endif #endif -#if defined(HDFEOS) +#if defined(HDFEOS) ! Create file, define projection, define origin fid = GDopen (fname, DFACC_CREATE) @@ -1002,7 +1002,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & if (err("Create: error in EHidinfo",rc,-30) .NE. 0) return cfio%sd_id = sd_id - gridId = GDcreate (fid, GRID_NAME, im, jm, uplft, lwrgt) + gridId = GDcreate (fid, GRID_NAME, im, jm, uplft, lwrgt) if (err("Create: error in GDcreate",rc,-30) .NE. 0) return rct = GDdefproj (gridId, GCTP_GEO, 0, 0, 0) if (err("Create: error in GDdefproj",rc,-30) .NE. 0) return @@ -1011,12 +1011,12 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & gridId = GDattach (fid, GRID_NAME) if (err("Create: error in GDattach",rc,-37) .NE. 0) return #endif - + #if defined(HDFEOS) - ! NOTE: X and Y dimensions are created implicitly by the - ! GD interface. These are single-precision coordinate + ! NOTE: X and Y dimensions are created implicitly by the + ! GD interface. These are single-precision coordinate ! variables that satisfy the needs of COARDS. ! The double-precision coordinate variable required by ! HDF-EOS are defined later. @@ -1045,7 +1045,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & dims2D(2) = jm dims2D(1) = im #if defined(HDFEOS) - cdims2D = "XDim,YDim,TIME" + cdims2D = "XDim,YDim,TIME" #endif scale_32 = 1.0 ! No packing for now. @@ -1066,7 +1066,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & else packflag = .FALSE. endif - + if ( kmvar(i) .eq. 0 ) then #if defined(HDFSD) @@ -1078,22 +1078,22 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & vid(i) = sfcreate (sd_id,vname(i),DFNT_FLOAT32,3,dims2D) endif if (err("Create: error defining variable",rc,-34).NE.0) & - then + then print *, 'Error details: Could not define ',vname(i) goto 999 endif dim_id = sfdimid(vid(i),0) if (err("Create: error in sfdimid",rc,-33) goto 999 - rct = sfsdmname(dim_id, 'XDim') + rct = sfsdmname(dim_id, 'XDim') if (err("Create: error in sfsdmname",rc,-33) goto 999 dim_id = sfdimid (vid(i),1) if (err("Create: error in sfdimid",rc,-33) goto 999 - rct = sfsdmname(dim_id, 'YDim') + rct = sfsdmname(dim_id, 'YDim') if (err("Create: error in sfsdmname",rc,-33) goto 999 dim_id = sfdimid (vid(i),2) if (err("Create: error in sfdimid",rc,-33) goto 999 - rct = sfsdmname(dim_id, 'time') + rct = sfsdmname(dim_id, 'time') if (err("Create: error in sfsdmname",rc,-33) goto 999 #endif @@ -1102,19 +1102,19 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & rct = GDdeffld (gridId, vname(i), cdims2D, DFNT_INT16, & HDFE_NOMERGE) if (err("Create: error defining variable",rc,-34).NE.0) & - then + then print *, 'Error details: Could not define ',vname(i) goto 999 endif rct = GDsetfill (gridId, vname(i), amiss_32) ! amiss_16 ? if (err("Create: error in GDsetfill",rc,-34).NE.0) & goto 999 - vid(i) = GetSDSid (fid, vname(i)) + vid(i) = GetSDSid (fid, vname(i)) else if (prec .EQ. 1) then rct = GDdeffld (gridId, vname(i), cdims2D, DFNT_FLOAT64, & HDFE_NOMERGE) if (err("Create: error defining variable",rc,-34).NE.0) & - then + then print *, 'Error details: Could not define ',vname(i) goto 999 endif @@ -1126,7 +1126,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & rct = GDdeffld (gridId, vname(i), cdims2D, DFNT_FLOAT32, & HDFE_NOMERGE) if (err("Create: error defining variable",rc,-34).NE.0) & - then + then print *, 'Error details: Could not define ',vname(i) goto 999 endif @@ -1236,7 +1236,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & print *, "Error details: Can't set long_name to ",vtitle(i) goto 999 endif - + if (LEN_TRIM(vunits(i)) .NE. 0) then rct = sfscatt(vid(i),'units',DFNT_CHAR8,LEN_TRIM(vunits(i)),TRIM(vunits(i)) ) else @@ -1262,7 +1262,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & endif scale_32 = (high_32 - low_32)/PACK_BITS*2 offset_32 = high_32 - scale_32*PACK_BITS - if (scale_32 .EQ. 0.0) then ! If packing range is 0, + if (scale_32 .EQ. 0.0) then ! If packing range is 0, scale_32 = 1.0 ! default to no packing. offset_32 = 0.0 endif @@ -1340,9 +1340,9 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & if (surfaceOnly) then idx=1 else - do idx=1,nvars + do idx=1,nvars if (kmvar(idx) .EQ. km) then - exit + exit endif enddo ! print *, 'idx=',idx,' nvars=',nvars,'km=',km @@ -1392,7 +1392,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & rct = sfscatt (levid,'long_name',DFNT_CHAR8,LEN_TRIM(levName),TRIM(levName)) if (err("Create: error lev attribute",rc,-35).NE.0) goto 999 - ! Check for blanks in levunits because this string is passed in + ! Check for blanks in levunits because this string is passed in ! by the user. if ( LEN_TRIM(levunits) .NE. 0) then @@ -1481,7 +1481,7 @@ subroutine EOS_Create_(cfio, fname, title, source, contact, amiss, & if (err("Create: error writing TIME",rc,-38).NE.0) goto 999 #endif - + ! Define global file attributes. Check for strings containing only blanks. #if defined(HDFEOS) diff --git a/MAPL_cfio/ESMF_CFIOMod.F90 b/MAPL_cfio/ESMF_CFIOMod.F90 index 9af1915c74b1..1429f0b86060 100644 --- a/MAPL_cfio/ESMF_CFIOMod.F90 +++ b/MAPL_cfio/ESMF_CFIOMod.F90 @@ -43,10 +43,10 @@ ! and VarReadT() has been rolled back. !- Dec2006 da Silva Added ESMF_CFIODownBit() to downgrade precision for ! better gzipping. -!- Feb2007 Baoyu Yin This is a new wrapper module for handling SDF or GrADS +!- Feb2007 Baoyu Yin This is a new wrapper module for handling SDF or GrADS ! format output. !- Mar2008 Dan Kokron Replace some code in ESMF_CFIOVarReadT2D__ that prevent -! time increment larger than 99 hours +! time increment larger than 99 hours !- Jun2008 Dan Kokron Replace read(str,fmt) to parse time in VarReadT3D with ! call to parseIntTime ! @@ -72,13 +72,13 @@ module ESMF_CFIOMod public :: ESMF_CFIO ! Main CFIO object - public :: ESMF_CFIOFileCreate ! Create a CFIO file for writing - public :: ESMF_CFIOFileOpen ! Open a CFIO file - public :: ESMF_CFIOVarWrite ! Write a variable to a file + public :: ESMF_CFIOFileCreate ! Create a CFIO file for writing + public :: ESMF_CFIOFileOpen ! Open a CFIO file + public :: ESMF_CFIOVarWrite ! Write a variable to a file public :: ESMF_CFIOVarRead ! Read a variable from a file public :: ESMF_CFIOVarReadT ! Read a variable from a file public :: ESMF_CFIOVarReadT2 ! Read a variable from a file - public :: ESMF_CFIOFileClose ! Close an existing CFIO file. + public :: ESMF_CFIOFileClose ! Close an existing CFIO file. public :: ESMF_CFIOstrTemplate ! replacement for the one in mpeu @@ -95,13 +95,13 @@ module ESMF_CFIOMod ESMF_CFIOVarRead3D_, & ESMF_CFIOVarRead2D_, & ESMF_CFIOVarRead1D_ - end interface + end interface ! AMS: These were split because *D_ and *D__ routines ! had the same signature! interface ESMF_CFIOVarReadT; module procedure & ESMF_CFIOVarReadT3D_, & - ESMF_CFIOVarReadT2D_ + ESMF_CFIOVarReadT2D_ end interface interface ESMF_CFIOVarReadT2; module procedure & @@ -138,40 +138,40 @@ subroutine ESMF_CFIOFileCreate (cfio, rc, expid, format) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -1 Time increment is 0 - !! -2 allocate memory error - !! -3 Num of int/char/real elements and Cnt don't match - !! -12 error determining default precision - !! -18 incorrect time increment - !! -30 can't open file - !! -31 error from NF90_DEF_DIM - !! -32 error from NF90_DEF_VAR (dimension variable) - !! -33 error from NF90_PUT_ATT (dimension attribute) - !! -34 error from NF90_DEF_VAR (variable) - !! -35 error from NF90_PUT_ATT (variable attribute) - !! -36 error from NF90_PUT_ATT (global attribute) - !! -37 error from NF90_ENDDEF - !! -38 error from NF90_PUT_VAR (dimension variable) - !! -39 Num of real var elements and Cnt differ - !! -55 error from NF90_REDEF (enter define mode) - !! -56 error from NF90_ENDDEF (exit define mode) + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -1 Time increment is 0 + !! -2 allocate memory error + !! -3 Num of int/char/real elements and Cnt don't match + !! -12 error determining default precision + !! -18 incorrect time increment + !! -30 can't open file + !! -31 error from NF90_DEF_DIM + !! -32 error from NF90_DEF_VAR (dimension variable) + !! -33 error from NF90_PUT_ATT (dimension attribute) + !! -34 error from NF90_DEF_VAR (variable) + !! -35 error from NF90_PUT_ATT (variable attribute) + !! -36 error from NF90_PUT_ATT (global attribute) + !! -37 error from NF90_ENDDEF + !! -38 error from NF90_PUT_VAR (dimension variable) + !! -39 Num of real var elements and Cnt differ + !! -55 error from NF90_REDEF (enter define mode) + !! -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------------ integer :: rtcode character (len=16) :: myFormat - + myFormat = 'SDF' if (present(format)) then if (trim(ESMF_UtilStringUpperCase(format)) .eq. 'GRADS' ) then call ESMF_CFIOSet(cfio, format='GRADS') - myFormat = 'GRADS' + myFormat = 'GRADS' end if #if defined(HDFEOS) if (ESMF_UtilStringUpperCase(format)) .eq. 'EOS' ) then call ESMF_CFIOSet(cfio, format='EOS') - myFormat = 'EOS' + myFormat = 'EOS' end if #endif end if @@ -219,7 +219,7 @@ subroutine ESMF_CFIOVarRead3D_(cfio, vName, field, date, curTime, & ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well ! !------------------------------------------------------------------------------ @@ -315,7 +315,7 @@ subroutine ESMF_CFIOVarRead2D_(cfio, vName, field, date, curTime, & ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well ! !------------------------------------------------------------------------------ @@ -408,7 +408,7 @@ subroutine ESMF_CFIOVarRead1D_(cfio, vName, field, date, curTime, & ! !OUTPUT PARAMETERS: ! real, pointer :: field(:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well ! !------------------------------------------------------------------------------ @@ -484,30 +484,30 @@ subroutine ESMF_CFIOVarWrite3D_(cfio, vName, field, date, curTime, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_PUT_VAR - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT - !! rc = -54 Format is not known + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_PUT_VAR + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT + !! rc = -54 Format is not known ! !------------------------------------------------------------------------------ @@ -560,8 +560,8 @@ subroutine ESMF_CFIOVarWrite3D_(cfio, vName, field, date, curTime, & end select print *, "CFIO%FORMAT is not known" - if (present(rc)) rc = -54 - return + if (present(rc)) rc = -54 + return end subroutine ESMF_CFIOVarWrite3D_ !------------------------------------------------------------------------------ @@ -587,30 +587,30 @@ subroutine ESMF_CFIOVarWrite2D_(cfio, vName, field, date, curTime, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_PUT_VAR - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT - !! rc = -54 Format is not known + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_PUT_VAR + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT + !! rc = -54 Format is not known ! !------------------------------------------------------------------------------ @@ -644,7 +644,7 @@ subroutine ESMF_CFIOVarWrite2D_(cfio, vName, field, date, curTime, & end if if ( rtcode .ne. 0 ) print *, "problem in ESMF_CFIOVarWrite" if (present(rc)) rc = rtcode - return + return #if defined(HDFEOS) case ('EOS') if (present(kbeg) .and. present(kount)) then @@ -664,8 +664,8 @@ subroutine ESMF_CFIOVarWrite2D_(cfio, vName, field, date, curTime, & end select print *, "CFIO%FORMAT is not known" - if (present(rc)) rc = -54 - return + if (present(rc)) rc = -54 + return end subroutine ESMF_CFIOVarWrite2D_ !------------------------------------------------------------------------------ !> @@ -685,30 +685,30 @@ subroutine ESMF_CFIOVarWrite1D_(cfio, vName, field, date, curTime, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_PUT_VAR - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT - !! rc = -54 Format is not known + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_PUT_VAR + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT + !! rc = -54 Format is not known ! !------------------------------------------------------------------------------ @@ -729,12 +729,12 @@ subroutine ESMF_CFIOVarWrite1D_(cfio, vName, field, date, curTime, & curTime=myCurTime, rc=rtcode) if ( rtcode .ne. 0 ) print *, "problem in ESMF_CFIOVarWrite" if (present(rc)) rc = rtcode - return + return end select print *, "CFIO%FORMAT is not known" - if (present(rc)) rc = -54 - return + if (present(rc)) rc = -54 + return end subroutine ESMF_CFIOVarWrite1D_ !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ @@ -752,28 +752,28 @@ subroutine ESMF_CFIOFileOpen (cfio, fmode, rc, expid, cyclic) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -1 invalid count - !! -2 type mismatch - !! -12 error determining default precision - !! -10 ngatts is incompatible with file - !! -11 character string not long enough - !! -19 unable to identify coordinate variable - !! -36 error from NF90_PUT_ATT (global attribute) - !! -39 error from NF90_OPEN (file open) - !! -40 error from NF90_INQ_VARID - !! -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! -43 error from NF90_INQ_VARID (time variable) - !! -47 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (time) - !! -48 error from NF90_INQUIRE - !! -51 error from NF90_GET_ATT (global attribute) - !! -52 error from NF90_INQUIRE_VARIABLE - !! -53 error from NF90_GET_ATT - !! -57 error from NF90_INQ_ATTNAME - !! -58 error from NF90_INQUIRE_ATTRIBUTE - + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -1 invalid count + !! -2 type mismatch + !! -12 error determining default precision + !! -10 ngatts is incompatible with file + !! -11 character string not long enough + !! -19 unable to identify coordinate variable + !! -36 error from NF90_PUT_ATT (global attribute) + !! -39 error from NF90_OPEN (file open) + !! -40 error from NF90_INQ_VARID + !! -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! -43 error from NF90_INQ_VARID (time variable) + !! -47 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (time) + !! -48 error from NF90_INQUIRE + !! -51 error from NF90_GET_ATT (global attribute) + !! -52 error from NF90_INQUIRE_VARIABLE + !! -53 error from NF90_GET_ATT + !! -57 error from NF90_INQ_ATTNAME + !! -58 error from NF90_INQUIRE_ATTRIBUTE + ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -782,10 +782,10 @@ subroutine ESMF_CFIOFileOpen (cfio, fmode, rc, expid, cyclic) !------------------------------------------------------------------------------ integer :: rtcode character(len=16) :: dset - character(len=16) :: format + character(len=16) :: format logical :: ex character(len=MLEN) :: fileName - logical :: myCyclic + logical :: myCyclic if (present(expid)) call ESMF_CFIOSet(cfio, expid = expid) @@ -810,7 +810,7 @@ subroutine ESMF_CFIOFileOpen (cfio, fmode, rc, expid, cyclic) call ESMF_CFIOSet(cfio, format='GRADS') format = 'GRADS' end if - + select case (format) case ('SDF') if ( present(expid) ) then @@ -833,9 +833,9 @@ subroutine ESMF_CFIOFileClose (cfio, rc) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -54 error from ncclos (file close) + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -54 error from ncclos (file close) ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -867,7 +867,7 @@ end subroutine ESMF_CFIOFileClose !------------------------------------------------------------------------------ !> -! `ESMF_CFIODownBit` - GRIB-based compression pre-conditioner +! `ESMF_CFIODownBit` - GRIB-based compression pre-conditioner ! ! This routine returns a lower precision version of the input array ! `x` which retains `nbits` of precision. See routine @@ -884,7 +884,7 @@ subroutine ESMF_CFIODownBit3D_ ( x, xr, nbits, undef, flops, rc ) ! ! !INPUT PARAMETERS: ! - real, intent(in) :: x(:,:,:) !! input array + real, intent(in) :: x(:,:,:) !! input array integer, intent(in) :: nbits !! number of bits per word to retain !! - no action if nbits<1 real, OPTIONAL, intent(in) :: undef ! missing value @@ -898,7 +898,7 @@ subroutine ESMF_CFIODownBit3D_ ( x, xr, nbits, undef, flops, rc ) !! if it has same kind integer, intent(out) :: rc !! error code !! = 0 - all is well - !! /= 0 - something went wrong + !! /= 0 - something went wrong ! !------------------------------------------------------------------------------ @@ -914,24 +914,24 @@ end subroutine ESMF_CFIODownBit3D_ !------------------------------------------------------------------------------ !> -! `ESMF_CFIODownBit` - GRIB-based compression pre-conditioner +! `ESMF_CFIODownBit` - GRIB-based compression pre-conditioner ! ! This routine returns a lower precision version of the input array ! `x` which retains `nbits` of precision. Two algorithms are ! implemented: 1) a fast one writen in C which downgrades precision ! by shifting `xbits = 24 - nbits` bits of the mantissa, and 2) a slower -! float point based algorithm which is the same algorithm as GRIB -! with fixed number of bits packing. Notice that as in GRIB the scaling -! factor is forced to be a power of 2 rather than a generic float. -! Using this power of 2 binary scaling has the advantage of improving +! float point based algorithm which is the same algorithm as GRIB +! with fixed number of bits packing. Notice that as in GRIB the scaling +! factor is forced to be a power of 2 rather than a generic float. +! Using this power of 2 binary scaling has the advantage of improving ! the GZIP compression rates. ! -! This routine returns an array of the same type and kind as the input array, +! This routine returns an array of the same type and kind as the input array, ! so no data compression has taken place. The goal here is to reduce the -! entropy in the input array, thereby improving compression rates -! by the lossless algorithms implemented internally by HDF-4/5 when writing -! these data to a file. In fact, these GZIP'ed and pre-conditioned files -! have sizes comparable to the equivalent GRIB file, while being a bonafide +! entropy in the input array, thereby improving compression rates +! by the lossless algorithms implemented internally by HDF-4/5 when writing +! these data to a file. In fact, these GZIP'ed and pre-conditioned files +! have sizes comparable to the equivalent GRIB file, while being a bonafide ! self-describing HDF/NetCDF file. ! ! @todo: @@ -999,7 +999,7 @@ subroutine ESMF_CFIODownBit2D_ ( x, xr, nbits, undef, flops, rc ) ! Slow, flops in FORTRAN (GRIB inspired) ! -------------------------------------- - else + else if ( nbits < 1 ) then xr = x @@ -1009,13 +1009,13 @@ subroutine ESMF_CFIODownBit2D_ ( x, xr, nbits, undef, flops, rc ) tol = 0.0001 * undef_ xmin = minval(x,mask=(abs(undef_-x)>tol)) - xr = x - xmin ! As in GRIB, force non-negative values + xr = x - xmin ! As in GRIB, force non-negative values xmax = maxval(xr,mask=(abs(undef_-x)>tol)) ! max of positive if ( xmax <= 0.0 ) then xr = x rc = 0 - return ! this means field is constant + return ! this means field is constant end if E = nint(log(xmax)/log(2.)) - nbits ! GRIB binary scale factor @@ -1053,32 +1053,32 @@ subroutine ESMF_CFIOVarReadT3D_ ( cfio, vName, field, date, curTime, & integer, intent(in), OPTIONAL :: kount !! number of levels to read type(ESMF_CFIO), intent(inOut), OPTIONAL :: cfio2 !! second CFIO obj character(len=*), intent(in), OPTIONAL :: timeString !! string expression for date and time - + ! ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -99 must specify date/curTime of timeString + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -99 must specify date/curTime of timeString ! !------------------------------------------------------------------------------ @@ -1096,7 +1096,7 @@ subroutine ESMF_CFIOVarReadT3D_ ( cfio, vName, field, date, curTime, & return end if - call ESMF_CFIOVarReadT3D__ ( cfio, vName, date_, curTime_, field, & + call ESMF_CFIOVarReadT3D__ ( cfio, vName, date_, curTime_, field, & kbeg, kount, cfio2=cfio2, rc=rc ) end subroutine ESMF_CFIOVarReadT3D_ @@ -1117,32 +1117,32 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & integer, intent(in), OPTIONAL :: kbeg !! first level to read integer, intent(in), OPTIONAL :: kount !! number of levels to read type(ESMF_CFIO), intent(inOut), OPTIONAL :: cfio2 !! second CFIO obj - + ! ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -20 unable to find variable - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -20 unable to find variable + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------------ @@ -1153,7 +1153,7 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & integer im, jm, km integer :: hour, min, sec logical ialloc,foundvar - + real alpha, amiss real, pointer :: field2(:,:,:) => null() ! workspace for interpolation @@ -1188,9 +1188,9 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & begTime = cfio%begTime call CFIO_parseIntTime ( cfio%timeInc, hour, min, sec ) - incSecs = sec + 60 * ( min + 60 * hour ) + incSecs = sec + 60 * ( min + 60 * hour ) secs = DiffDate (begDate, begTime, date, curTime) - + ! Determine brackting times ! ------------------------- if ( secs >= 0 ) then @@ -1203,7 +1203,7 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & secs2 = (timeIndex2-1) * incSecs call GetDate ( begDate, begTime, secs1, nymd1, nhms1, rtcode ) call GetDate ( begDate, begTime, secs2, nymd2, nhms2, rtcode ) - + ! Read grids at first time with GetVar() ! -------------------------------------- call ESMF_CFIOVarRead(cfio, vName, field, date=nymd1, curtime=nhms1, kbeg=kbeg, kount=kount, rc=rtcode) @@ -1211,10 +1211,10 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & call ESMF_CFIOVarRead(cfio2, vName, field, date=nymd1, curtime=nhms1, kbeg=kbeg, kount=kount, rc=rtcode) end if if ( rtcode .ne. 0 ) goto 999 - + if ( secs1 .eq. secs ) goto 999 ! no interpolation needed - allocate(field2(size(field,1),size(field,2),size(field,3))) + allocate(field2(size(field,1),size(field,2),size(field,3))) ! Read grids at second time with GetVar() ! --------------------------------------- call ESMF_CFIOVarRead(cfio, vName, field2, date=nymd2, curtime=nhms2, kbeg=kbeg, kount=kount, rc=rtcode) @@ -1228,14 +1228,14 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & return endif end if - + ! Get missing value ! ----------------- amiss = cfio%varObjs(1)%amiss ! Do interpolation ! ---------------- - alpha = float(secs - secs1)/float(secs2 - secs1) + alpha = real(secs - secs1)/real(secs2 - secs1) do k = 1, size(field,3)!km do j = 1, size(field,2)!jm do i = 1, size(field,1)!im @@ -1249,7 +1249,7 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & end do end do end do - + if ( associated(field2) ) deallocate(field2) if ( ialloc ) deallocate(field) rtcode = 0 @@ -1258,7 +1258,7 @@ subroutine ESMF_CFIOVarReadT3D__(cfio, vName, date, curTime, field, & ! -------- 999 continue if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOVarReadT3D__ @@ -1280,32 +1280,32 @@ subroutine ESMF_CFIOVarReadT2D_ ( cfio, vName, field, date, curTime, & type(ESMF_CFIO), intent(inOut), OPTIONAL :: cfio2 !! second CFIO obj character(len=*), intent(in), OPTIONAL :: timeString !! string expression for date and time - + ! ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -99 must specify date/curTime of timeString + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -99 must specify date/curTime of timeString ! !------------------------------------------------------------------------------ @@ -1331,7 +1331,7 @@ end subroutine ESMF_CFIOVarReadT2D_ !------------------------------------------------------------------------------ !> ! `ESMF_CFIOVarReadT2D_` -- Read a variable from an existing file - + ! !INTERFACE: subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & @@ -1346,32 +1346,32 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & integer, intent(in), OPTIONAL :: kbeg !! first level to read integer, intent(in), OPTIONAL :: kount !! number of levels to read type(ESMF_CFIO), intent(inOut), OPTIONAL :: cfio2 !! second CFIO obj - + ! ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_PUT_VAR (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE -! + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_PUT_VAR (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID or NF90_INQUIRE_DIMENSION (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE +! !------------------------------------------------------------------------------ integer rtcode @@ -1380,7 +1380,7 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & integer i, j integer im, jm, km integer :: hour, min, sec - + real alpha, amiss real, pointer :: field2(:,:) => null() ! workspace for interpolation @@ -1403,7 +1403,7 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & begTime = cfio%begTime call CFIO_parseIntTime ( cfio%timeInc, hour, min, sec ) - incSecs = sec + 60 * ( min + 60 * hour ) + incSecs = sec + 60 * ( min + 60 * hour ) secs = DiffDate (begDate, begTime, date, curTime) ! Determine brackting times ! ------------------------- @@ -1417,7 +1417,7 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & secs2 = (timeIndex2-1) * incSecs call GetDate ( begDate, begTime, secs1, nymd1, nhms1, rtcode ) call GetDate ( begDate, begTime, secs2, nymd2, nhms2, rtcode ) - + ! Read grids at first time with GetVar() ! -------------------------------------- call ESMF_CFIOVarRead(cfio, vName, field, date=nymd1, curtime=nhms1, kbeg=kbeg, kount=kount, rc=rtcode) @@ -1425,11 +1425,11 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & call ESMF_CFIOVarRead(cfio2, vName, field, date=nymd1, curtime=nhms1, kbeg=kbeg, kount=kount, rc=rtcode) end if if ( rtcode .ne. 0 ) goto 999 - + if ( secs1 .eq. secs ) goto 999 ! no interpolation needed allocate(field2(im,jm)) - + ! Read grids at second time with GetVar() ! --------------------------------------- call ESMF_CFIOVarRead(cfio, vName, field2, date=nymd2, curtime=nhms2, kbeg=kbeg, kount=kount, rc=rtcode) @@ -1439,14 +1439,14 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & date=nymd2, curtime=nhms2, kbeg=kbeg, kount=kount, rc=rtcode) if ( rtcode .ne. 0 ) return end if - + ! Get missing value ! ----------------- amiss = cfio%varObjs(1)%amiss ! Do interpolation ! ---------------- - alpha = float(secs - secs1)/float(secs2 - secs1) + alpha = real(secs - secs1)/real(secs2 - secs1) do j = 1, jm do i = 1, im if ( abs(field(i,j)-amiss) .gt. 0.001 .and. & @@ -1457,7 +1457,7 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & end if end do end do - + rtcode = 0 ! All done @@ -1465,7 +1465,7 @@ subroutine ESMF_CFIOVarReadT2D__(cfio, vName, date, curTime, field, & 999 continue if ( associated(field2) ) deallocate(field2) if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOVarReadT2D__ end module ESMF_CFIOMod diff --git a/MAPL_cfio/ESMF_CFIOSdfMod.F90 b/MAPL_cfio/ESMF_CFIOSdfMod.F90 index 952b46b366cf..12e1fc322fea 100644 --- a/MAPL_cfio/ESMF_CFIOSdfMod.F90 +++ b/MAPL_cfio/ESMF_CFIOSdfMod.F90 @@ -35,20 +35,20 @@ module ESMF_CFIOSdfMod !------------------------------------------------------------------------------ ! !PUBLIC MEMBER FUNCTIONS: - public :: ESMF_CFIOSdfFileCreate ! Create a CFIO file for writing - public :: ESMF_CFIOSdfFileOpen ! Open a CFIO file - public :: ESMF_CFIOSdfVarWrite ! Write a variable to a file + public :: ESMF_CFIOSdfFileCreate ! Create a CFIO file for writing + public :: ESMF_CFIOSdfFileOpen ! Open a CFIO file + public :: ESMF_CFIOSdfVarWrite ! Write a variable to a file public :: ESMF_CFIOSdfVarRead ! Read a variable from a file - public :: ESMF_CFIOSdfVarReadT ! Read a variable from two files + public :: ESMF_CFIOSdfVarReadT ! Read a variable from two files ! with time interpolation - public :: ESMF_CFIOSdfFileClose ! Close an existing CFIO file. + public :: ESMF_CFIOSdfFileClose ! Close an existing CFIO file. interface ESMF_CFIOSdfVarWrite; module procedure & ESMF_CFIOSdfVarWrite3D_, & ESMF_CFIOSdfVarWrite2D_, & ESMF_CFIOSdfVarWrite1D_ end interface - + interface ESMF_CFIOSdfVarRead; module procedure & ESMF_CFIOSdfVarRead3D_, & ESMF_CFIOSdfVarRead2D_, & @@ -77,37 +77,37 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -1 Time increment is 0 - !! -2 allocate memory error - !! -3 Num of int/char/real elements and Cnt don't match - !! -12 error determining default precision - !! -18 incorrect time increment - !! -30 can't open file - !! -31 error from NF90_DEF_DIM - !! -32 error from NF90_DEF_VAR (dimension variable) - !! -33 error from NF90_PUT_ATT (dimension attribute) - !! -34 error from NF90_DEF_VAR (variable) - !! -35 error from NF90_PUT_ATT (variable attribute) - !! -36 error from NF90_PUT_ATT (global attribute) - !! -37 error from NF90_ENDDEF - !! -38 error from NF90_VAR_PUT (dimension variable) - !! -39 Num of real var elements and Cnt differ - !! -55 error from NF90_REDEF (enter define mode) - !! -56 error from NF90_ENDDEF (exit define mode) + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -1 Time increment is 0 + !! -2 allocate memory error + !! -3 Num of int/char/real elements and Cnt don't match + !! -12 error determining default precision + !! -18 incorrect time increment + !! -30 can't open file + !! -31 error from NF90_DEF_DIM + !! -32 error from NF90_DEF_VAR (dimension variable) + !! -33 error from NF90_PUT_ATT (dimension attribute) + !! -34 error from NF90_DEF_VAR (variable) + !! -35 error from NF90_PUT_ATT (variable attribute) + !! -36 error from NF90_PUT_ATT (global attribute) + !! -37 error from NF90_ENDDEF + !! -38 error from NF90_VAR_PUT (dimension variable) + !! -39 Num of real var elements and Cnt differ + !! -55 error from NF90_REDEF (enter define mode) + !! -56 error from NF90_ENDDEF (exit define mode) ! !------------------------------------------------------------------------------ integer :: i, rtcode !integer :: maxLen - character(len=MLEN) :: fNameTmp ! file name + character(len=MLEN) :: fNameTmp ! file name integer :: date, begTime character(len=MLEN) :: fName call ESMF_CFIOGet(cfio, date=date, begTime=begTime, fName=fName, rc=rtcode) if (rtcode .ne. 0) print *, "Problems in ESMF_CFIOGet" ! checking file name template - if (present(expid)) then + if (present(expid)) then call ESMF_CFIOSet(cfio, expid=expid) call strTemplate_(fNameTmp,fName,xid=expid,nymd=date, & nhms=begTime, stat=rtcode) @@ -120,7 +120,7 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) end if call CFIO_Create_(cfio, rtcode) - if (err("Error form CFIO_Create_",rtcode,rtcode) .lt. 0) then + if (err("Error form CFIO_Create_",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if @@ -128,35 +128,35 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) ! put global attributes call CFIO_PutCharAtt(cfio%fid, 'History', len(trim(cfio%history)), & cfio%history, rtcode ) - if (err("can't write History",rtcode,rtcode) .lt. 0) then + if (err("can't write History",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if call CFIO_PutCharAtt(cfio%fid, 'Source', len(trim(cfio%source)), & cfio%source, rtcode ) - if (err("can't write Source",rtcode,rtcode) .lt. 0) then + if (err("can't write Source",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if call CFIO_PutCharAtt(cfio%fid, 'Title', len(trim(cfio%title)), & cfio%title, rtcode ) - if (err("can't write Title",rtcode,rtcode) .lt. 0) then + if (err("can't write Title",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if call CFIO_PutCharAtt(cfio%fid, 'Contact', len(trim(cfio%contact)), & cfio%contact, rtcode ) - if (err("can't write Contact",rtcode,rtcode) .lt. 0) then + if (err("can't write Contact",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if call CFIO_PutCharAtt(cfio%fid,'Conventions',len(trim(cfio%convention))& ,cfio%convention, rtcode ) - if (err("can't write Conventions",rtcode,rtcode) .lt. 0) then + if (err("can't write Conventions",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if @@ -164,21 +164,21 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) call CFIO_PutCharAtt(cfio%fid,'Institution', & len(trim(cfio%institution)), & cfio%institution, rtcode ) - if (err("can't write Institution",rtcode,rtcode) .lt. 0) then + if (err("can't write Institution",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if call CFIO_PutCharAtt(cfio%fid,'References',len(trim(cfio%references)),& cfio%references, rtcode ) - if (err("can't write References",rtcode,rtcode) .lt. 0) then + if (err("can't write References",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if call CFIO_PutCharAtt(cfio%fid,'Comment',len(trim(cfio%comment)), & cfio%comment, rtcode ) - if (err("can't write Comment",rtcode,rtcode) .lt. 0) then + if (err("can't write Comment",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if @@ -190,7 +190,7 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) !@@ allocate(cfio%attIntNames(cfio%nAttInt), & !@@ cfio%attIntCnts(cfio%nAttInt), & !@@ cfio%attInts(cfio%nAttInt,maxLen), stat=rtcode) -!@@ if (err("can't allocate mem: attIntCnts",rtcode,-2) .lt. 0) then +!@@ if (err("can't allocate mem: attIntCnts",rtcode,-2) .lt. 0) then !@@ if ( present(rc) ) rc = rtcode !@@ return !@@ end if @@ -226,7 +226,7 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) !@@ allocate(cfio%attRealNames(cfio%nAttReal), & !@@ cfio%attRealCnts(cfio%nAttReal), & !@@ cfio%attReals(cfio%nAttReal,maxLen), stat=rtcode) -!@@ if (err("can't allocate mem: attRealNames",rtcode,-2) .lt. 0) then +!@@ if (err("can't allocate mem: attRealNames",rtcode,-2) .lt. 0) then !@@ if ( present(rc) ) rc = rtcode !@@ return !@@ end if @@ -263,7 +263,7 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) !@@ allocate(cfio%attCharNames(cfio%nAttChar), & !@@ cfio%attCharCnts(cfio%nAttChar), & !@@ cfio%attChars(cfio%nAttChar), stat=rtcode) -!@@ if (err("can't allocate mem: attCharNames",rtcode,-2) .lt. 0) then +!@@ if (err("can't allocate mem: attCharNames",rtcode,-2) .lt. 0) then !@@ if ( present(rc) ) rc = rtcode !@@ return !@@ end if @@ -285,7 +285,7 @@ subroutine ESMF_CFIOSdfFileCreate (cfio, rc, expid) end if cfio%isOpen = .true. - + rtcode = 0 if ( present(rc) ) rc = rtcode @@ -306,27 +306,27 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -1 invalid count - !! -2 type mismatch - !! -12 error determining default precision - !! -10 ngatts is incompatible with file - !! -11 character string not long enough - !! -19 unable to identify coordinate variable - !! -36 error from NF90_PUT_ATT (global attribute) - !! -39 error from ncopn (file open) - !! -40 error from NF90_INQ_VARID - !! -41 error from NF90_INQ_DIMID (lat or lon) - !! -42 error from NF90_INQ_DIMID (lev) - !! -43 error from NF90_INQ_VARID (time variable) - !! -47 error from NF90_INQ_DIMID (time) - !! -48 error from NF90_INQUIRE - !! -51 error from NF90_GET_ATT (global attribute) - !! -52 error from NF90_INQUIRE_VARIABLE - !! -53 error from NF90_GET_ATT - !! -57 error from NF90_INQ_ATTNAME - !! -58 error from NF90_INQUIRE_ATTRIBUTE + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -1 invalid count + !! -2 type mismatch + !! -12 error determining default precision + !! -10 ngatts is incompatible with file + !! -11 character string not long enough + !! -19 unable to identify coordinate variable + !! -36 error from NF90_PUT_ATT (global attribute) + !! -39 error from ncopn (file open) + !! -40 error from NF90_INQ_VARID + !! -41 error from NF90_INQ_DIMID (lat or lon) + !! -42 error from NF90_INQ_DIMID (lev) + !! -43 error from NF90_INQ_VARID (time variable) + !! -47 error from NF90_INQ_DIMID (time) + !! -48 error from NF90_INQUIRE + !! -51 error from NF90_GET_ATT (global attribute) + !! -52 error from NF90_INQUIRE_VARIABLE + !! -53 error from NF90_GET_ATT + !! -57 error from NF90_INQ_ATTNAME + !! -58 error from NF90_INQUIRE_ATTRIBUTE ! ! !INPUT/OUTPUT PARAMETERS: @@ -378,7 +378,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) logical :: cs_found integer :: nf - fNameTmp = '' + fNameTmp = '' ! checking file name template if (present(expid)) cfio%expid = expid if (present(cyclic)) cfio%isCyclic = cyclic @@ -389,7 +389,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) if (cfio%date .gt. 0 .and. cfio%begTime .ge. 0) then call strTemplate_(fNameTmp,cfio%fName,nymd=cfio%date, & nhms=cfio%begTime, stat=rtcode) - else + else if (present(expid)) then call strTemplate_(fNameTmp,cfio%fName,xid=expid, stat=rtcode) end if @@ -414,10 +414,10 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) fid =cfio%fid ! get grid information and global meta data - + call CFIO_DimInquire (cfio%fid, im, jm, km, lm, & cfio%mVars, ngatts, vdir=vdir, rc=rtcode) - if (err("CFIO_DimInquire failed",rtcode,rtcode) .lt. 0) then + if (err("CFIO_DimInquire failed",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if @@ -425,7 +425,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) cfio%vDir = vdir rtcode = NF90_INQUIRE (cfio%fid,nDims,allVars,ngatts,recdim) - if (err("FileOpen: NF90_INQUIRE failed",rtcode,-48) .NE. 0) then + if (err("FileOpen: NF90_INQUIRE failed",rtcode,-48) .NE. 0) then if ( present(rc) ) rc = rtcode return end if @@ -440,7 +440,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) cs_found = .false. do i=1,allVars rtcode = NF90_INQUIRE_VARIABLE(fid,i,vnameTemp,vtype,nvDims,vDims,nvAtts) - if (err("Inquire: variable inquire error",rtcode,-52) .NE. 0) then + if (err("Inquire: variable inquire error",rtcode,-52) .NE. 0) then if ( present(rc) ) rc = rtcode return end if @@ -471,11 +471,11 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) do i=1,allVars rtcode = NF90_INQUIRE_VARIABLE(fid,i,vnameTemp,vtype,nvDims,vDims,nvAtts) - if (err("Inquire: variable inquire error",rtcode,-52) .NE. 0) then + if (err("Inquire: variable inquire error",rtcode,-52) .NE. 0) then if ( present(rc) ) rc = rtcode return end if - if (trim(vnameTemp) .eq. 'time_bnds') then + if (trim(vnameTemp) .eq. 'time_bnds') then cfio%varObjs(nVars)%timAve = .true. cycle end if @@ -497,7 +497,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) cfio%varObjs(nVars)%grid%stnGrid = .false. do iv = 1, nvDims rtcode = NF90_INQUIRE_DIMENSION(fid, vDims(iv), dimName(iv), dimSize(iv)) - if (err("problem in NF90_INQUIRE_DIMENSION",rtcode,-41) .NE. 0) then + if (err("problem in NF90_INQUIRE_DIMENSION",rtcode,-41) .NE. 0) then if ( present(rc) ) rc = rtcode return end if @@ -517,7 +517,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) rtcode = NF90_INQ_VARID(fid,dimName(iv),varId) dimUnits(iv) = ' ' rtcode = NF90_GET_ATT(fid,varId,'units',dimUnits(iv)) - if (err("problem in NF90_GET_ATT",rtcode,-53) .NE. 0) then + if (err("problem in NF90_GET_ATT",rtcode,-53) .NE. 0) then if ( present(rc) ) rc = rtcode return end if @@ -536,7 +536,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) lon =lon_64 deallocate(lon_64) end if - if (err("problem in NF90_GET_VAR",rtcode,-53) .NE. 0) then + if (err("problem in NF90_GET_VAR",rtcode,-53) .NE. 0) then if ( present(rc) ) rc = rtcode return end if @@ -563,7 +563,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) end if !print *, "vDims(iv) varId: ", vDims(iv), varId !print *, "dimName dimUnits: ", trim(dimName(iv)), trim(dimUnits(iv)) - if (err("problem in NF90_GET_VAR",rtcode,-51) .NE. 0) then + if (err("problem in NF90_GET_VAR",rtcode,-51) .NE. 0) then if ( present(rc) ) rc = rtcode return end if @@ -653,18 +653,18 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) cfio%varObjs(nVars)%grid%ptop = ptop end if rtcode = NF90_GET_ATT(fid,varId,'coordinate',cfio%varObjs(nVars)%grid%coordinate) - if (rtcode .ne. 0) cfio%varObjs(nVars)%grid%coordinate = "pressure" + if (rtcode .ne. 0) cfio%varObjs(nVars)%grid%coordinate = "pressure" cfio%varObjs(nVars)%grid%levUnits = trim(dimUnits(iv)) allocate(cfio%varObjs(nVars)%grid%lev(dimSize(iv))) if (.not.associated(lev)) allocate(lev(dimSize(iv))) if ( coZType .eq. NF90_FLOAT ) then - rtcode = NF90_GET_VAR(fid, varId, lev, (/1/), (/dimSize(iv)/)) + rtcode = NF90_GET_VAR(fid, varId, lev, (/1/), (/dimSize(iv)/)) !print *, "Lev from CFIO SDFFileOpen: ", lev else allocate(lev_64(dimSize(iv))) - rtcode = NF90_GET_VAR(fid, varId, lev_64, (/1/), (/dimSize(iv)/)) + rtcode = NF90_GET_VAR(fid, varId, lev_64, (/1/), (/dimSize(iv)/)) lev =lev_64 deallocate(lev_64) end if @@ -675,15 +675,15 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) end if end do rtcode = NF90_INQ_VARID (cfio%fid, cfio%varObjs(nVars)%vName, varId) - if (rtcode .ne. 0) then + if (rtcode .ne. 0) then print *, "problem in getting varId in NF90_INQ_VARID" - if ( present(rc) ) rc = -40 + if ( present(rc) ) rc = -40 return end if rtcode = NF90_GET_ATT(fid,varId,'units',cfio%varObjs(nVars)%vunits) if (rtcode .ne. 0) then print *, "NF90_GET_ATT failed for units" - if ( present(rc) ) rc = -53 + if ( present(rc) ) rc = -53 return end if cfio%varObjs(nVars)%vtitle = ' ' @@ -723,9 +723,9 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) else cfio%varObjs(nVars)%validRange(2) = vRange32(2) endif - + end do - + call GetBegDateTime(fid,cfio%date,cfio%begTime,cfio%timeInc,rtcode) if (rtcode .ne. 0) then print *, "GetBegDateTime failed to get data/time/timeInc" @@ -741,11 +741,11 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) allocate(attNames(ngatts)) attNames = " " call CFIO_GetAttNames ( cfio%fid, ngatts, attNames, rtcode ) - if (err("CFIO_GetAttNames failed",rtcode,rtcode) .lt. 0) then + if (err("CFIO_GetAttNames failed",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if - + iCnt = 0 rCnt = 0 cCnt = 0 @@ -794,14 +794,14 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) ! get attNames and count, then put them into a cfio obj do i =1, ngatts call CFIO_AttInquire (cfio%fid, attNames(i), type, count, rtcode) - if (err("CFIO_AttInquire failed",rtcode,rtcode) .lt. 0) then + if (err("CFIO_AttInquire failed",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if select case (type) case ( 0 ) iCnt = iCnt + 1 - cfio%attIntNames(iCnt) = attNames(i) + cfio%attIntNames(iCnt) = attNames(i) cfio%attIntCnts(iCnt) = count case ( 1 ) rCnt = rCnt + 1 @@ -841,19 +841,19 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) call CFIO_GetRealAtt(cfio%fid,cfio%attRealNames(i), & cfio%attRealCnts(i), & cfio%attReals(i,:), rtcode) - if (err("CFIO_GetRealAtt",rtcode,rtcode) .lt. 0) then + if (err("CFIO_GetRealAtt",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if end do - + ! get global char attributes do i = 1, cCnt allocate(globalAtt(cfio%attCharCnts(i))) call CFIO_GetCharAtt(cfio%fid,cfio%attCharNames(i), & cfio%attCharCnts(i), & globalAtt, rtcode) - if (err("GetCharAtt",rtcode,rtcode) .lt. 0) then + if (err("GetCharAtt",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if @@ -894,13 +894,13 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) ! get variable meta data do i = 1, cfio%mVars rtcode = NF90_INQ_VARID (cfio%fid, cfio%varObjs(i)%vName, varId) - if (err("NF90_INQ_VARID failed for vName",rtcode,rtcode) .lt. 0) then + if (err("NF90_INQ_VARID failed for vName",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = -40 return end if rtcode = NF90_INQUIRE_VARIABLE(cfio%fid, varId, cfio%varObjs(i)%vName, datatype, & nvdims, vdims, nvatts) - if (err("NF90_INQUIRE_VARIABLE failed for vName",rtcode,rtcode) .lt. 0) then + if (err("NF90_INQUIRE_VARIABLE failed for vName",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = -52 return end if @@ -914,13 +914,13 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) ! get variable int/real/char attribute count do iv =1, nvatts rtcode = NF90_INQ_ATTNAME(cfio%fid,varId,iv, vAttName) - if (err("NF90_INQ_ATTNAME failed for vName",rtcode,rtcode) .lt. 0) then - if ( present(rc) ) rc = -57 + if (err("NF90_INQ_ATTNAME failed for vName",rtcode,rtcode) .lt. 0) then + if ( present(rc) ) rc = -57 return end if rtcode = NF90_INQUIRE_ATTRIBUTE (cfio%fid,varId,vAttName,vtype,count) if (err("NF90_INQUIRE_ATTRIBUTE failed for vName",rtcode,rtcode) .lt. 0) then - if ( present(rc) ) rc = -58 + if ( present(rc) ) rc = -58 return end if select case (vtype) @@ -941,14 +941,14 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) if ( count .gt. iMaxLen ) iMaxLen = count end select end do - + cfio%varObjs(i)%nVarAttChar = cCnt cfio%varObjs(i)%nVarAttReal = rCnt cfio%varObjs(i)%nVarAttInt = iCnt - + allocate(cfio%varObjs(i)%attCharCnts(cCnt), & cfio%varObjs(i)%attRealCnts(rCnt), & - cfio%varObjs(i)%attIntCnts(iCnt)) + cfio%varObjs(i)%attIntCnts(iCnt)) allocate(cfio%varObjs(i)%attCharNames(cCnt), & cfio%varObjs(i)%attRealNames(rCnt),& cfio%varObjs(i)%attIntNames(iCnt)) @@ -959,12 +959,12 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) ! get variable int/real/char attribute names and counts do iv =1, nvatts rtcode = NF90_INQ_ATTNAME (cfio%fid, varId, iv, vAttName) - if (err("NF90_INQ_ATTNAME failed for vName",rtcode,rtcode) .lt. 0) then + if (err("NF90_INQ_ATTNAME failed for vName",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = -57 return end if rtcode = NF90_INQUIRE_ATTRIBUTE (cfio%fid,varId,vAttName,vtype,count) - if (err("NF90_INQUIRE_ATTRIBUTE failed for vName",rtcode,rtcode) .lt. 0) then + if (err("NF90_INQUIRE_ATTRIBUTE failed for vName",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = -58 return end if @@ -972,26 +972,26 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) case ( NF90_SHORT ) iCnt = iCnt + 1 cfio%varObjs(i)%attIntNames(iCnt) = vAttName - cfio%varObjs(i)%attIntCnts(iCnt) = count + cfio%varObjs(i)%attIntCnts(iCnt) = count case ( NF90_FLOAT ) rCnt = rCnt + 1 cfio%varObjs(i)%attRealNames(rCnt) = vAttName - cfio%varObjs(i)%attRealCnts(rCnt) = count + cfio%varObjs(i)%attRealCnts(rCnt) = count case ( NF90_CHAR ) cCnt = cCnt + 1 cfio%varObjs(i)%attCharNames(cCnt) = vAttName - cfio%varObjs(i)%attCharCnts(cCnt) = count + cfio%varObjs(i)%attCharCnts(cCnt) = count case ( NF90_DOUBLE ) rCnt = rCnt + 1 cfio%varObjs(i)%attRealNames(rCnt) = vAttName - cfio%varObjs(i)%attRealCnts(rCnt) = count + cfio%varObjs(i)%attRealCnts(rCnt) = count case ( NF90_INT ) iCnt = iCnt + 1 cfio%varObjs(i)%attIntNames(iCnt) = vAttName - cfio%varObjs(i)%attIntCnts(iCnt) = count + cfio%varObjs(i)%attIntCnts(iCnt) = count end select end do - + allocate(cfio%varObjs(i)%varAttReals(rCnt, rMaxLen), & cfio%varObjs(i)%varAttInts(iCnt, iMaxLen), & cfio%varObjs(i)%varAttChars(cCnt)) @@ -1001,7 +1001,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) allocate(itmp(cfio%varObjs(i)%attIntCnts(ii))) rtcode = NF90_GET_ATT(cfio%fid,varId,cfio%varObjs(i)%attIntNames(ii),itmp) if (err("NF90_GET_ATT failed for attIntNames",rtcode,rtcode) .lt. 0) then - if ( present(rc) ) rc = -53 + if ( present(rc) ) rc = -53 return end if cfio%varObjs(i)%varAttInts(ii,1:cfio%varObjs(i)%attIntCnts(ii))& @@ -1026,11 +1026,11 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) do ii = 1, cCnt rtcode = NF90_GET_ATT(cfio%fid,varId,cfio%varObjs(i)%attCharNames(ii),cfio%varObjs(i)%varAttChars(ii)) if (err("NF90_GET_ATT failed for attCharNames",rtcode,rtcode) .lt. 0) then - if ( present(rc) ) rc = -53 + if ( present(rc) ) rc = -53 return end if cfio%varObjs(i)%varAttChars(ii) & - (cfio%varObjs(i)%attCharCnts(ii)+1:MLEN) = ' ' + (cfio%varObjs(i)%attCharCnts(ii)+1:MLEN) = ' ' end do end do @@ -1046,7 +1046,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) end if if ( cfio%mGrids .eq. 1 .and. cfio%varObjs(1)%grid%km .eq. 0) & cfio%grids(1)%km = km - + if ( cfio%mGrids .gt. 1 ) then do i = 2, cfio%mGrids iCnt = 1 @@ -1056,7 +1056,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) do ii = 2, i if (cfio%varObjs(iv)%grid%im .eq. cfio%grids(ii-1)%im .and. & cfio%varObjs(iv)%grid%jm .eq. cfio%grids(ii-1)%jm .and. & - cfio%varObjs(iv)%grid%km .eq. cfio%grids(ii-1)%km ) then + cfio%varObjs(iv)%grid%km .eq. cfio%grids(ii-1)%km ) then new_grid = .false. end if end do @@ -1064,7 +1064,7 @@ subroutine ESMF_CFIOSdfFileOpen (cfio, fmode, rc, expid, cyclic) end do cfio%grids(i) = cfio%varObjs(iCnt)%grid end do - end if + end if rtcode = 0 if ( present(rc) ) rc = rtcode @@ -1080,8 +1080,8 @@ subroutine ESMF_CFIOSdfVarWrite3D_(cfio, vName, field, date, curTime, & ! ! !INPUT PARAMETERS: ! - type(ESMF_CFIO), intent(inOut) :: cfio !! a CFIO obj - character(len=*), intent(in) :: vName !! Variable name + type(ESMF_CFIO), intent(inOut) :: cfio !! a CFIO obj + character(len=*), intent(in) :: vName !! Variable name real, intent(in) :: field(:,:,:) !! array contains data integer, intent(in), OPTIONAL :: date !! yyyymmdd integer, intent(in), OPTIONAL :: curTime !! hhmmss @@ -1091,29 +1091,29 @@ subroutine ESMF_CFIOSdfVarWrite3D_(cfio, vName, field, date, curTime, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -15 data outside of valid range - !! rc = -16 data outside of packing range - !! rc = -17 data outside of pack and valid range - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -45 error from NF90_VAR_PUT - !! rc = -46 error from NF90_GET_VAR - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -53 error from NF90_GET_ATT + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -15 data outside of valid range + !! rc = -16 data outside of packing range + !! rc = -17 data outside of pack and valid range + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -45 error from NF90_VAR_PUT + !! rc = -46 error from NF90_GET_VAR + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -53 error from NF90_GET_ATT ! !------------------------------------------------------------------------------ @@ -1121,8 +1121,8 @@ subroutine ESMF_CFIOSdfVarWrite3D_(cfio, vName, field, date, curTime, & integer :: myKbeg, myKount integer :: myDate, myCurTime logical :: useFaceDim - character(len=MLEN) :: fNameTmp ! file name - + character(len=MLEN) :: fNameTmp ! file name + fNameTmp = '' if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime @@ -1143,7 +1143,7 @@ subroutine ESMF_CFIOSdfVarWrite3D_(cfio, vName, field, date, curTime, & end if end if end if - + ! ! make sure user provides the right variable name do i = 1, cfio%mVars @@ -1157,7 +1157,7 @@ subroutine ESMF_CFIOSdfVarWrite3D_(cfio, vName, field, date, curTime, & end if ! write 2D variable - if ( cfio%varObjs(i)%twoDimVar ) then + if ( cfio%varObjs(i)%twoDimVar ) then call CFIO_PutVar (cfio%fid, vName, myDate, myCurTime, & cfio%varObjs(i)%grid%im, cfio%varObjs(i)%grid%jm, & 0, 1, field, useFaceDim, rtcode ) @@ -1170,7 +1170,7 @@ subroutine ESMF_CFIOSdfVarWrite3D_(cfio, vName, field, date, curTime, & myKbeg = 1 myKount = cfio%varObjs(i)%grid%km - if ( present(kbeg) ) myKbeg = kbeg + if ( present(kbeg) ) myKbeg = kbeg if ( present(kount) ) myKount = kount call CFIO_PutVar (cfio%fid, vName, myDate, myCurTime, & @@ -1208,19 +1208,19 @@ subroutine ESMF_CFIOSdfVarWrite1D_(cfio, vName, field, date, curTime, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well ! !------------------------------------------------------------------------------ integer :: i, rtcode integer :: myDate, myCurTime character(len=MLEN) :: fNameTmp ! file name - + fNameTmp = '' if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) - + if (len(trim(cfio%fNameTmplt)) .gt. 1) then call strTemplate_(fNameTmp,cfio%fNameTmplt,xid=cfio%expid,nymd=myDate, & nhms=myCurTime, stat=rtcode) @@ -1241,7 +1241,7 @@ subroutine ESMF_CFIOSdfVarWrite1D_(cfio, vName, field, date, curTime, & do i = 1, cfio%mVars if ( trim(vName) .eq. trim(cfio%varObjs(i)%vName) ) exit end do - + ! NEED WORK HERE if (index(cfio%varObjs(i)%grid%gName,'station') .gt. 0) then call CFIO_SPutVar (cfio%fid, vName, myDate, myCurTime, & @@ -1260,10 +1260,10 @@ subroutine ESMF_CFIOSdfVarWrite1D_(cfio, vName, field, date, curTime, & end if if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOSdfVarWrite1D_ - - + + !------------------------------------------------------------------------------ !> ! `ESMF_CFIOSdfVarWrite2D_` -- Write a variable to a output file. @@ -1284,8 +1284,8 @@ subroutine ESMF_CFIOSdfVarWrite2D_(cfio, vName, field, date, curTime, & ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well ! !------------------------------------------------------------------------------ integer :: i, rtcode @@ -1293,12 +1293,12 @@ subroutine ESMF_CFIOSdfVarWrite2D_(cfio, vName, field, date, curTime, & integer :: myDate, myCurTime logical :: useFaceDim character(len=MLEN) :: fNameTmp ! file name - + fNameTmp = '' if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) - + if (len(trim(cfio%fNameTmplt)) .gt. 1) then call strTemplate_(fNameTmp,cfio%fNameTmplt,xid=cfio%expid,nymd=myDate, & nhms=myCurTime, stat=rtcode) @@ -1320,7 +1320,7 @@ subroutine ESMF_CFIOSdfVarWrite2D_(cfio, vName, field, date, curTime, & do i = 1, cfio%mVars if ( trim(vName) .eq. trim(cfio%varObjs(i)%vName) ) exit end do - + ! write 2D variable if (index(cfio%varObjs(i)%grid%gName,'station') .gt. 0) then if ( cfio%varObjs(i)%twoDimVar ) then @@ -1360,15 +1360,15 @@ subroutine ESMF_CFIOSdfVarWrite2D_(cfio, vName, field, date, curTime, & end if end if - + if ( cfio%varObjs(i)%timAve ) then call writeBnds(cfio, vName, myDate, myCurTime, rtcode) end if if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOSdfVarWrite2D_ - + !------------------------------------------------------------------------------ !> @@ -1386,36 +1386,36 @@ subroutine ESMF_CFIOSdfVarRead3D_(cfio, vName, field, date, curTime, & integer, intent(in), OPTIONAL :: curTime !! hhmmss integer, intent(in), OPTIONAL :: kbeg !! first level to write integer, intent(in), OPTIONAL :: kount !! number of levels to write - integer, intent(in), OPTIONAL :: xBeg !! first point for lon + integer, intent(in), OPTIONAL :: xBeg !! first point for lon integer, intent(in), OPTIONAL :: xCount !! number of points to read - integer, intent(in), OPTIONAL :: yBeg !! first point for lat + integer, intent(in), OPTIONAL :: yBeg !! first point for lat integer, intent(in), OPTIONAL :: yCount !! number of points to read character(len=*), intent(in), OPTIONAL :: timeString !! string expression for date and time ! ! !OUTPUT PARAMETERS: ! - real, pointer :: field(:,:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -8 vname miss-match - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + real, pointer :: field(:,:,:) !! array contains data + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -8 vname miss-match + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------------ integer :: i, j, k, rtcode @@ -1426,9 +1426,9 @@ subroutine ESMF_CFIOSdfVarRead3D_(cfio, vName, field, date, curTime, & real, pointer :: tmp(:,:,:) ! array contains data character(len=MLEN) :: fNameTmp ! file name logical :: useFaceDim - + fNameTmp = '' - + if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) @@ -1496,12 +1496,12 @@ subroutine ESMF_CFIOSdfVarRead3D_(cfio, vName, field, date, curTime, & allocate(tmp(cfio%varObjs(i)%grid%im,cfio%varObjs(i)%grid%jm,1),& stat=rtcode) if (rtcode /= 0) print *, "cannot allocate tmp in ESMF_CFIOSdfVarRead3D" - + call CFIO_GetVar(cfio%fid,vName,mydate,MYcurTime, & cfio%varObjs(i)%grid%im, & cfio%varObjs(i)%grid%jm, 0, 1, cfio%tSteps, tmp, & cfio%isCyclic, useFaceDim, rtcode ) - if (err("CFIO_GetVar FAILED",rtcode,rtcode) .lt. 0) then + if (err("CFIO_GetVar FAILED",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if @@ -1517,7 +1517,7 @@ subroutine ESMF_CFIOSdfVarRead3D_(cfio, vName, field, date, curTime, & if ( present(yCount) ) myYount = yCount if (associated(field) ) then - if (size(field,1) < myXount .or. size(field,2) < myYount .or. size(field,3) < myKount) then + if (size(field,1) < myXount .or. size(field,2) < myYount .or. size(field,3) < myKount) then print *, "Field is not Large Enough in VarRead3D" if (size(field,1) < myXount) rtcode = -4 if (size(field,2) < myXount) rtcode = -5 @@ -1541,7 +1541,7 @@ subroutine ESMF_CFIOSdfVarRead3D_(cfio, vName, field, date, curTime, & deallocate(tmp) if ( present(rc) ) rc = rtcode - end subroutine ESMF_CFIOSdfVarRead3D_ + end subroutine ESMF_CFIOSdfVarRead3D_ !------------------------------------------------------------------------------ !> @@ -1568,27 +1568,27 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -8 vname miss-match - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -8 vname miss-match + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------------ integer :: i, j, k, rtcode @@ -1599,13 +1599,13 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & real, pointer :: tmp(:,:) ! array contains data character(len=MLEN) :: fNameTmp ! file name logical :: useFaceDim - + fNameTmp = '' if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) - + if (len(trim(cfio%fNameTmplt)) .gt. 1) then call strTemplate_(fNameTmp,cfio%fNameTmplt,xid=cfio%expid,nymd=MYdate, & nhms=MYcurTime, stat=rtcode) @@ -1634,7 +1634,7 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & return endif endif - + myXbeg = 1 myXount = cfio%varObjs(i)%grid%im myYbeg = 1 @@ -1663,13 +1663,13 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & cfio%varObjs(i)%grid%im, & cfio%varObjs(i)%grid%jm, 0, 1, cfio%tSteps, tmp, & cfio%isCyclic, useFaceDim, rtcode ) - if (err("CFIO_GetVar failed",rtcode,rtcode) .lt. 0) then + if (err("CFIO_GetVar failed",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if - + if(associated(field)) then - if (size(field,1) < myXount .or. size(field,2) < myYount) then + if (size(field,1) < myXount .or. size(field,2) < myYount) then print *, "Field is not Large Enough in VarRead2D" if (size(field,1) < myXount) rtcode = -4 if (size(field,2) < myXount) rtcode = -5 @@ -1691,12 +1691,12 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & call CFIO_SGetVar(cfio%fid,vName,MYdate,MYcurTime, & cfio%varObjs(i)%grid%im, cfio%varObjs(i)%grid%jm, & 0,1, cfio%tSteps, tmp, cfio%isCyclic, rtcode ) - if (err("CFIO_SGetVar failed",rtcode,rtcode) .lt. 0) then + if (err("CFIO_SGetVar failed",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if if(associated(field)) then - if (size(field,1) < myXount .or. size(field,2) < 1) then + if (size(field,1) < myXount .or. size(field,2) < 1) then print *, "Field is not Large Enough in VarRead2D" if (size(field,1) < myXount) rtcode = -4 if (size(field,2) < 1) rtcode = -5 @@ -1715,12 +1715,12 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & call CFIO_SGetVar(cfio%fid,vName,MYdate,MYcurTime, & cfio%varObjs(i)%grid%im, cfio%varObjs(i)%grid%jm, & myKbeg, myKount, cfio%tSteps, tmp, cfio%isCyclic, rtcode ) - if (err("CFIO_GetVar failed",rtcode,rtcode) .lt. 0) then + if (err("CFIO_GetVar failed",rtcode,rtcode) .lt. 0) then if ( present(rc) ) rc = rtcode return end if if(associated(field)) then - if (size(field,1) < myXount .or. size(field,2) < myKount) then + if (size(field,1) < myXount .or. size(field,2) < myKount) then print *, "Field is not Large Enough in VarRead2D" if (size(field,1) < myXount) rtcode = -4 if (size(field,2) < myKount) rtcode = -3 @@ -1738,13 +1738,13 @@ subroutine ESMF_CFIOSdfVarRead2D_(cfio, vName, field, date, curTime, & end if end if - + deallocate(tmp) - + if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOSdfVarRead2D_ - + !------------------------------------------------------------------------------ !> ! `ESMF_CFIOSdfVarRead1D_` -- Read a variable from an existing file. @@ -1765,22 +1765,22 @@ subroutine ESMF_CFIOSdfVarRead1D_(cfio, vName, field, date, curTime, & ! !OUTPUT PARAMETERS: ! real, pointer :: field(:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: + integer, intent(out), OPTIONAL :: rc !! Error return code: !! 0 all is well ! !------------------------------------------------------------------------------ integer :: i, rtcode - integer :: myXbeg, myXount + integer :: myXbeg, myXount integer :: myDate, myCurTime real, pointer :: tmp(:) ! array contains data character(len=MLEN) :: fNameTmp ! file name - + fNameTmp = '' if ( present(date) ) myDate = date if ( present(curTime) ) myCurTime = curTime if ( present(timeString) ) call strToInt(timeString,myDate,myCurTime) - + if (len(trim(cfio%fNameTmplt)) .gt. 1) then call strTemplate_(fNameTmp,cfio%fNameTmplt,xid=cfio%expid,nymd=MYdate, & nhms=MYcurTime, stat=rtcode) @@ -1796,12 +1796,12 @@ subroutine ESMF_CFIOSdfVarRead1D_(cfio, vName, field, date, curTime, & end if end if - + ! make sure user provides the right variable name do i = 1, cfio%mVars if ( trim(vName) .eq. trim(cfio%varObjs(i)%vName) ) exit end do - + myXbeg = 1 myXount = cfio%varObjs(i)%grid%im @@ -1819,11 +1819,11 @@ subroutine ESMF_CFIOSdfVarRead1D_(cfio, vName, field, date, curTime, & end do deallocate(tmp) - + if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOSdfVarRead1D_ - + !------------------------------------------------------------------------------ !> @@ -1833,10 +1833,10 @@ subroutine ESMF_CFIOSdfFileClose (cfio, rc) ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! -54 error from ncclos (file close) -! + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! -54 error from ncclos (file close) +! ! !INPUT/OUTPUT PARAMETERS: ! type(ESMF_CFIO), intent(inout) :: cfio !! CFIO object @@ -1844,9 +1844,9 @@ subroutine ESMF_CFIOSdfFileClose (cfio, rc) !------------------------------------------------------------------------------ integer :: rtcode - if ( cfio%isOpen ) then + if ( cfio%isOpen ) then call CFIO_Close(cfio%fid, rtcode) - if (rtcode .ne. 0) then + if (rtcode .ne. 0) then print *, "CFIO_Close failed" else cfio%isOpen = .false. @@ -1867,42 +1867,42 @@ end subroutine ESMF_CFIOSdfFileClose !------------------------------------------------------------------------- !> ! `CFIO_Create_` -- Creates a DAO gridded file for writing. -! +! ! This routine is used to open a new file for a CFIO stream. ! subroutine CFIO_Create_ ( cfio, rc ) ! ! !USES: ! - Implicit NONE + Implicit NONE ! -! !INPUT PARAMETERS: +! !INPUT PARAMETERS: ! ! ! !OUTPUT PARAMETERS: ! integer fid !! File handle - integer rc !! Error return code: - !! 0 All is well - !! -1 Time increment is 0 - !! -18 incorrect time increment - !! -30 can't open file - !! -31 error from NF90_DEF_DIM - !! -32 error from NF90_DEF_VAR (dimension variable) - !! -33 error from NF90_PUT_ATT (dimension attribute) - !! -34 error from NF90_DEF_VAR (variable) - !! -35 error from NF90_PUT_ATT (variable attribute) - !! -36 error from NF90_PUT_ATT (global attribute) - !! -37 error from NF90_ENDDEF - !! -38 error from NF90_VAR_PUT (dimension variable) - !! -39 Num of real var elements and Cnt differ - !! -40 error setting deflate compression routine - !! -41 error setting fletcher checksum routine + integer rc !! Error return code: + !! 0 All is well + !! -1 Time increment is 0 + !! -18 incorrect time increment + !! -30 can't open file + !! -31 error from NF90_DEF_DIM + !! -32 error from NF90_DEF_VAR (dimension variable) + !! -33 error from NF90_PUT_ATT (dimension attribute) + !! -34 error from NF90_DEF_VAR (variable) + !! -35 error from NF90_PUT_ATT (variable attribute) + !! -36 error from NF90_PUT_ATT (global attribute) + !! -37 error from NF90_ENDDEF + !! -38 error from NF90_VAR_PUT (dimension variable) + !! -39 Num of real var elements and Cnt differ + !! -40 error setting deflate compression routine + !! -41 error setting fletcher checksum routine ! ! !INPUT/OUTPUT PARAMETERS: ! - type(ESMF_CFIO), intent(inout) :: cfio + type(ESMF_CFIO), intent(inout) :: cfio ! !------------------------------------------------------------------------- @@ -1946,7 +1946,7 @@ subroutine CFIO_Create_ ( cfio, rc ) integer :: nsize integer, pointer :: lat2id(:), lon2id(:) ! integer corner(4), edges(4) - character*80 timeUnits + character(len=80) :: timeUnits logical surfaceOnly integer year,mon,day,hour,minute,sec integer count @@ -1971,7 +1971,7 @@ subroutine CFIO_Create_ ( cfio, rc ) integer(kind=INT16) amiss_16 real(kind=REAL32), pointer :: pRange_32(:,:),vRange_32(:,:) logical packflag -! Set metadata strings. These metadata values are specified in the +! Set metadata strings. These metadata values are specified in the ! COARDS conventions character (len=50), pointer :: lonDimName @@ -1995,7 +1995,7 @@ subroutine CFIO_Create_ ( cfio, rc ) real(kind=REAL32) :: scale_factor, add_offset character (len=50) :: nameLatDim, nameLonDim character (len=50) :: nameLat, nameLon, nameLev, nameEdge - character (len=50) :: nameAk, nameBk, namePtop, nameStation + character (len=50) :: nameAk, nameBk, namePtop, nameStation logical bTimeSet integer :: sz_lon, sz_lat integer :: jm6, nf @@ -2062,7 +2062,7 @@ subroutine CFIO_Create_ ( cfio, rc ) nf = 6 ncont = 4 end if - + ! Basic error-checking. if (timinc .eq. 0) then @@ -2098,7 +2098,7 @@ subroutine CFIO_Create_ ( cfio, rc ) jm = cfio%grids(ig)%jm km = cfio%grids(ig)%km tm = max(tm,cfio%grids(ig)%tm) - + if ( index(cfio%grids(ig)%gName, 'station') .gt. & 0 ) then if (im .ne. jm) rtcode = err("It isn't station grid",-1,-1) @@ -2507,9 +2507,9 @@ subroutine CFIO_Create_ ( cfio, rc ) end do if( tm .LE. 0 ) then - rc = NF90_DEF_DIM(fid, 'time', NF90_UNLIMITED, timedim) + rc = NF90_DEF_DIM(fid, 'time', NF90_UNLIMITED, timedim) else - rc = NF90_DEF_DIM(fid, 'time', tm, timedim) + rc = NF90_DEF_DIM(fid, 'time', tm, timedim) bTimeSet = .TRUE. endif if (err("Create: error defining time",rc,-31) .LT. 0) return @@ -2553,13 +2553,13 @@ subroutine CFIO_Create_ ( cfio, rc ) rc = NF90_PUT_ATT(fid,timeid,'units',timeUnits) if (err("Create: error creating time attribute",rc,-33) .LT. 0) & return - + !ams write (strBuf,203) timinc !ams 203 format (I6) !ams read (strBuf,204) hour, minute, sec !ams 204 format (3I2) - call CFIO_parseIntTime ( timinc, hour, minute, sec ) + call CFIO_parseIntTime ( timinc, hour, minute, sec ) if ( sec .NE. 0) then print *, 'CFIO_Create: Time increments not on minute', & @@ -2598,7 +2598,7 @@ subroutine CFIO_Create_ ( cfio, rc ) gDims3D(3,ig) = levdim(ig) gDims3D(2,ig) = latdim(ig) gDims3D(1,ig) = londim(ig) - + gDims2D(4,ig) = 0 gDims2D(3,ig) = timedim gDims2D(2,ig) = latdim(ig) @@ -2609,7 +2609,7 @@ subroutine CFIO_Create_ ( cfio, rc ) gDims3D(3,ig) = timedim gDims3D(2,ig) = levdim(ig) gDims3D(1,ig) = stationdim(ig) - + gDims2D(3,ig) = 0 gDims2D(2,ig) = timedim gDims2D(1,ig) = stationdim(ig) @@ -2621,7 +2621,7 @@ subroutine CFIO_Create_ ( cfio, rc ) gDims3D(3,ig) = facedim(ig) gDims3D(2,ig) = latdim(ig) gDims3D(1,ig) = londim(ig) - + gDims2D(4,ig) = timedim gDims2D(3,ig) = facedim(ig) gDims2D(2,ig) = latdim(ig) @@ -2700,7 +2700,7 @@ subroutine CFIO_Create_ ( cfio, rc ) scale_32 = 1.0 ! No packing for now. offset_32 = 0.0 ! No packing for now. -! Set up packing attributes for each variable. +! Set up packing attributes for each variable. ! Define physical variables. Set attributes for physical variables. do i=1,nvars @@ -2767,14 +2767,14 @@ subroutine CFIO_Create_ ( cfio, rc ) ! ! Chunksize is set to IM,JM,1,1 works for 2D and 3D variables ! - if ( (associated(cfio%varObjs(i)%ChunkSize)) ) then + if ( (associated(cfio%varObjs(i)%ChunkSize)) ) then rc=NF90_DEF_VAR_CHUNKING(fid, vid(i), & NF90_CHUNKED, cfio%varObjs(i)%ChunkSize) if (err("Create: error setting Chunked variable",rc,-40) .LT. 0) & return else ! -! Set Chunsize to IM,JM,1,1 by default +! Set Chunsize to IM,JM,1,1 by default ! If Time (tm) has been set in grid, set the file to contiguous ! if( bTimeSet .eqv. .FALSE. ) then @@ -2789,7 +2789,7 @@ subroutine CFIO_Create_ ( cfio, rc ) nDefaultChunkSize(3)=1 !nf nDefaultChunkSize(4)=1 nDefaultChunkSize(5)=1 - rc=NF90_DEF_VAR_CHUNKING(fid, vid(i), NF90_CHUNKED, & + rc=NF90_DEF_VAR_CHUNKING(fid, vid(i), NF90_CHUNKED, & nDefaultChunkSize(1:chunkDim)) endif @@ -2881,7 +2881,7 @@ subroutine CFIO_Create_ ( cfio, rc ) cfio%varObjs(i)%nVarAttReal), stat=rc) realVarAtt = cfio%varObjs(i)%varAttReals(iCnt,:) if (cfio%varObjs(i)%attRealCnts(iCnt) .ne. size(realVarAtt)) then - rc=err("FileCreate: Num of real var elements and Cnt differ",-39,-39) + rc=err("FileCreate: Num of real var elements and Cnt differ",-39,-39) return end if rc = NF90_PUT_ATT(cfio%fid,vid(i),cfio%varObjs(i)%attRealNames(iCnt),& @@ -2913,7 +2913,7 @@ subroutine CFIO_Create_ ( cfio, rc ) cfio%varObjs(i)%nVarAttInt), stat=rc) intVarAtt = cfio%varObjs(i)%varAttInts(iCnt,:) if (cfio%varObjs(i)%attIntCnts(iCnt) .gt. size(intVarAtt)) then - rc=err("FileCreate: Num of int var elements and Cnt differ",-39,-39) + rc=err("FileCreate: Num of int var elements and Cnt differ",-39,-39) return end if rc = NF90_PUT_ATT(cfio%fid,vid(i),cfio%varObjs(i)%attIntNames(iCnt),intVarAtt) @@ -2949,18 +2949,18 @@ subroutine CFIO_Create_ ( cfio, rc ) ! write scaleFactor, addOffSet, and standardName to output ! if ( cfio%varObjs(i)%scaleFactor /= 0 ) then - scale_factor = cfio%varObjs(i)%scaleFactor + scale_factor = cfio%varObjs(i)%scaleFactor rc = NF90_PUT_ATT(cfio%fid, vid(i), 'scale_factor', scale_factor) if (err("FileCreate: error from NF90_PUT_ATT for scale_factor",rc,-35) & .LT. 0) return ! end if ! if ( cfio%varObjs(i)%addOffSet /= 0 ) then - add_offset = cfio%varObjs(i)%addOffSet + add_offset = cfio%varObjs(i)%addOffSet rc = NF90_PUT_ATT(cfio%fid, vid(i), 'add_offset', add_offset) if (err("FileCreate: error from NF90_PUT_ATT for add_offset",rc,-35) & .LT. 0) return ! end if - + if ( LEN_TRIM(cfio%varObjs(i)%standardName) .gt. 0 ) then rc = NF90_PUT_ATT(cfio%fid, vid(i), 'standard_name', & cfio%varObjs(i)%standardName) @@ -3023,7 +3023,7 @@ subroutine CFIO_Create_ ( cfio, rc ) end if enddo - + if ( aveFile ) then dimsbnd(1) = bndsdim dimsbnd(2) = timedim @@ -3052,7 +3052,7 @@ subroutine CFIO_Create_ ( cfio, rc ) sz_lat = jm end if allocate(lon_64(sz_lon), lat_64(sz_lat), levs_64(km), ak_32(km+1), & - bk_32(km+1), layer(km+1), stat = rtcode) + bk_32(km+1), layer(km+1), stat = rtcode) ptop_32(1) = cfio%grids(ig)%ptop do i=1,sz_lon @@ -3070,7 +3070,7 @@ subroutine CFIO_Create_ ( cfio, rc ) xOffset = (im/2)*(jm/6) yOffset = (im/2) end if - allocate(lon2_64(im), lat2_64(jm), stat = rtcode) + allocate(lon2_64(im), lat2_64(jm), stat = rtcode) do i=1,im if (fVersion < 3) then lon2_64(i) = i ! index @@ -3266,10 +3266,10 @@ subroutine CFIO_Create_ ( cfio, rc ) contains logical function isFileExtensionNetCDF4(fileName) character(len=*) :: fileName - + character(len=len(fileName)) :: ext integer :: i - + isFileExtensionNetCDF4 = .false. ext = '' i = index(fileName,'.',back=.true.) @@ -3298,14 +3298,14 @@ subroutine writeBnds(cfio, vName, date, curTime, rc) ! type (ESMF_CFIO), intent(in) :: cfio character(len=*), intent(in) :: vName - integer, intent(in) :: date + integer, intent(in) :: date integer, intent(in) :: curTime ! ! !OUTPUT PARAMETERS: ! - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! 1 ... + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! 1 ... ! !------------------------------------------------------------------------------ @@ -3328,17 +3328,17 @@ subroutine writeBnds(cfio, vName, date, curTime, rc) !ams read (strBuf,204) hour, minute, sec !ams 204 format (3I2) - call CFIO_parseIntTime ( timeinc, hour, minute, sec ) + call CFIO_parseIntTime ( timeinc, hour, minute, sec ) incSecs = hour*3600 + minute*60 + sec !ams write (strBuf,203) curTime !ams read (strBuf,204) hour, minute, sec - call CFIO_parseIntTime ( curTime, hour, minute, sec ) + call CFIO_parseIntTime ( curTime, hour, minute, sec ) curSecs = hour*3600 + minute*60 + sec - + timeIndex = seconds/incSecs + 1 corner(1) = 1 corner(2) = timeIndex @@ -3356,19 +3356,19 @@ subroutine writeBnds(cfio, vName, date, curTime, rc) end if rtcode = NF90_INQ_VARID (cfio%fid, 'time_bnds', vid) - if ( rtcode .ne. 0 ) then + if ( rtcode .ne. 0 ) then print *, "NF90_INQ_VARID failed in NF90_INQ_VARID for time_bnds" if ( present(rc) ) rc = rtcode return end if rtcode = NF90_PUT_VAR(cfio%fid,vid,bndsdata,corner,edges) - if ( rtcode .ne. 0 ) then + if ( rtcode .ne. 0 ) then print *, "NF90_PUT_VAR failed in NF90_PUT_VAR for time_bnds" if ( present(rc) ) rc = rtcode return end if end if - + if ( present(rc) ) rc = rtcode end subroutine writeBnds @@ -3390,27 +3390,27 @@ subroutine ESMF_CFIOSdfVarReadT3D_ ( cfio, vName, field, & ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -99 must specify date/curTime of timeString + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -99 must specify date/curTime of timeString ! !------------------------------------------------------------------------------ @@ -3427,7 +3427,7 @@ subroutine ESMF_CFIOSdfVarReadT3D_ ( cfio, vName, field, & return end if - call ESMF_CFIOSdfVarReadT3D__ ( cfio, vName, date_, curTime_, field, & + call ESMF_CFIOSdfVarReadT3D__ ( cfio, vName, date_, curTime_, field, & cfio2=cfio2, rc=rc ) end subroutine ESMF_CFIOSdfVarReadT3D_ @@ -3445,31 +3445,31 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 integer, intent(in) :: date !! yyyymmdd integer, intent(in) :: curTime !! hhmmss type(ESMF_CFIO), intent(inOut), OPTIONAL :: cfio2 !! second CFIO obj - + ! ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------------ @@ -3478,7 +3478,7 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 integer secs, secs1, secs2, nymd1, nymd2, nhms1, nhms2 integer i, j, k integer im, jm, km - + real alpha, amiss real, pointer :: field2(:,:,:) => null() ! workspace for interpolation @@ -3500,15 +3500,15 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 call GetBegDateTime ( cfio%fid, begDate, begTime, incSecs, rtcode ) if (err("GetVar: could not determine begin_date/begin_time",rtcode,-44)& .NE. 0) go to 999 - + secs = DiffDate (begDate, begTime, date, curTime) - + ! if (date .LT. begDate .OR. (begDate .EQ. date .AND. & ! curTime .LT. begTime) .or. secs .LT. 0) then ! rc = -7 ! return ! endif - + ! Determine brackting times ! ------------------------- if ( secs >= 0 ) then @@ -3521,16 +3521,16 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 secs2 = (timeIndex2-1) * incSecs call GetDate ( begDate, begTime, secs1, nymd1, nhms1, rtcode ) call GetDate ( begDate, begTime, secs2, nymd2, nhms2, rtcode ) - + ! Read grids at first time with GetVar() ! -------------------------------------- call ESMF_CFIOSdfVarRead(cfio, vName, field, date=nymd1, curtime=nhms1, rc=rtcode) if ( rtcode .ne. 0 ) goto 999 - + if ( secs1 .eq. secs ) goto 999 ! no interpolation needed allocate(field2(im,jm,km)) - + ! Read grids at second time with GetVar() ! --------------------------------------- call ESMF_CFIOSdfVarRead(cfio, vName, field2, date=nymd2, curtime=nhms2, rc=rtcode) @@ -3540,7 +3540,7 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 date=nymd2, curtime=nhms2, rc=rtcode) if ( rtcode .ne. 0 ) return end if - + ! Get missing value ! ----------------- amiss = CFIO_GetMissing ( cfio%fid, rtcode ) @@ -3548,7 +3548,7 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 ! Do interpolation ! ---------------- - alpha = float(secs - secs1)/float(secs2 - secs1) + alpha = real(secs - secs1)/real(secs2 - secs1) !ams print *, ' nymd = ', nymd1, nymd2 !ams print *, ' nhms = ', nhms1, nhms2 !ams print *, 'alpha = ', alpha @@ -3565,7 +3565,7 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 end do end do end do - + rtcode = 0 ! All done @@ -3573,7 +3573,7 @@ subroutine ESMF_CFIOSdfVarReadT3D__(cfio, vName, date, curTime, field, rc, cfio2 999 continue if ( associated(field2) ) deallocate(field2) if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOSdfVarReadT3D__ @@ -3592,32 +3592,32 @@ subroutine ESMF_CFIOSdfVarReadT2D_ ( cfio, vName, field, & character(len=*), intent(in) :: vName !! variable name type(ESMF_CFIO), intent(inOut), OPTIONAL :: cfio2 !! second CFIO obj character(len=*), intent(in) :: timeString !! string expression for date and time - + ! ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NV_GET_VARA - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE - !! rc = -99 must specify date/curTime of timeString + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NV_GET_VARA + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE + !! rc = -99 must specify date/curTime of timeString ! !------------------------------------------------------------------------------ @@ -3655,26 +3655,26 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 ! !OUTPUT PARAMETERS: ! real, pointer :: field(:,:) !! array contains data - integer, intent(out), OPTIONAL :: rc !! Error return code: - !! 0 all is well - !! rc = -2 time is inconsistent with increment - !! rc = -3 number of levels is incompatible with file - !! rc = -4 im is incompatible with file - !! rc = -5 jm is incompatible with file - !! rc = -6 time must fall on a minute boundary - !! rc = -7 error in diffdate - !! rc = -12 error determining default precision - !! rc = -13 error determining variable type - !! rc = -19 unable to identify coordinate variable - !! rc = -38 error from NF90_VAR_PUT (dimension variable) - !! rc = -40 error from NF90_INQ_VARID - !! rc = -41 error from NF90_INQ_DIMID (lat or lon) - !! rc = -42 error from NF90_INQ_DIMID (lev) - !! rc = -43 error from NF90_INQ_VARID (time variable) - !! rc = -44 error from NF90_GET_ATT (time attribute) - !! rc = -46 error from NF90_GET_VAR - !! rc = -48 error from NF90_INQUIRE - !! rc = -52 error from NF90_INQUIRE_VARIABLE + integer, intent(out), OPTIONAL :: rc !! Error return code: + !! 0 all is well + !! rc = -2 time is inconsistent with increment + !! rc = -3 number of levels is incompatible with file + !! rc = -4 im is incompatible with file + !! rc = -5 jm is incompatible with file + !! rc = -6 time must fall on a minute boundary + !! rc = -7 error in diffdate + !! rc = -12 error determining default precision + !! rc = -13 error determining variable type + !! rc = -19 unable to identify coordinate variable + !! rc = -38 error from NF90_VAR_PUT (dimension variable) + !! rc = -40 error from NF90_INQ_VARID + !! rc = -41 error from NF90_INQ_DIMID (lat or lon) + !! rc = -42 error from NF90_INQ_DIMID (lev) + !! rc = -43 error from NF90_INQ_VARID (time variable) + !! rc = -44 error from NF90_GET_ATT (time attribute) + !! rc = -46 error from NF90_GET_VAR + !! rc = -48 error from NF90_INQUIRE + !! rc = -52 error from NF90_INQUIRE_VARIABLE ! !------------------------------------------------------------------------------ @@ -3683,7 +3683,7 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 integer secs, secs1, secs2, nymd1, nymd2, nhms1, nhms2 integer i, j integer im, jm, km - + real alpha, amiss real, pointer :: field2(:,:) => null() ! workspace for interpolation @@ -3705,15 +3705,15 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 call GetBegDateTime ( cfio%fid, begDate, begTime, incSecs, rtcode ) if (err("GetVar: could not determine begin_date/begin_time",rtcode,-44)& .NE. 0) go to 999 - + secs = DiffDate (begDate, begTime, date, curTime) - + ! if (date .LT. begDate .OR. (begDate .EQ. date .AND. & ! curTime .LT. begTime) .or. secs .LT. 0) then ! rc = -7 ! return ! endif - + ! Determine brackting times ! ------------------------- if ( secs >= 0 ) then @@ -3726,16 +3726,16 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 secs2 = (timeIndex2-1) * incSecs call GetDate ( begDate, begTime, secs1, nymd1, nhms1, rtcode ) call GetDate ( begDate, begTime, secs2, nymd2, nhms2, rtcode ) - + ! Read grids at first time with GetVar() ! -------------------------------------- call ESMF_CFIOSdfVarRead(cfio, vName, field, date=nymd1, curtime=nhms1, rc=rtcode) if ( rtcode .ne. 0 ) goto 999 - + if ( secs1 .eq. secs ) goto 999 ! no interpolation needed allocate(field2(im,jm)) - + ! Read grids at second time with GetVar() ! --------------------------------------- call ESMF_CFIOSdfVarRead(cfio, vName, field2, date=nymd2, curtime=nhms2, rc=rtcode) @@ -3745,7 +3745,7 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 date=nymd2, curtime=nhms2, rc=rtcode) if ( rtcode .ne. 0 ) return end if - + ! Get missing value ! ----------------- amiss = CFIO_GetMissing ( cfio%fid, rtcode ) @@ -3753,7 +3753,7 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 ! Do interpolation ! ---------------- - alpha = float(secs - secs1)/float(secs2 - secs1) + alpha = real(secs - secs1)/real(secs2 - secs1) do j = 1, jm do i = 1, im if ( abs(field(i,j)-amiss) .gt. 0.001 .and. & @@ -3764,7 +3764,7 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 end if end do end do - + rtcode = 0 ! All done @@ -3772,7 +3772,7 @@ subroutine ESMF_CFIOSdfVarReadT2D__(cfio, vName, date, curTime, field, rc, cfio2 999 continue if ( associated(field2) ) deallocate(field2) if ( present(rc) ) rc = rtcode - + end subroutine ESMF_CFIOSdfVarReadT2D__ !.......................................................................... diff --git a/MAPL_cfio/ESMF_CFIOUtilMod.F90 b/MAPL_cfio/ESMF_CFIOUtilMod.F90 index 0860ce4a0cef..880b9e22bd85 100644 --- a/MAPL_cfio/ESMF_CFIOUtilMod.F90 +++ b/MAPL_cfio/ESMF_CFIOUtilMod.F90 @@ -46,7 +46,7 @@ module ESMF_CFIOUtilMod integer, parameter :: HDFE_GD_LL=2 integer, parameter :: NDIMS_MAX = 4 integer, parameter :: MAX_VAR_DIMS = 32 - character*7, parameter :: GRID_NAME='EOSGRID' + character(len=7), parameter :: GRID_NAME='EOSGRID' integer, parameter :: MAXCHR = 256 integer, parameter :: PACK_BITS = 32766 integer, parameter :: PACK_FILL = 32767 @@ -459,11 +459,11 @@ subroutine CFIO_DimInquire (fid,im,jm,km,lm,nvars,ngatts,vdir,rc) !------------------------------------------------------------------------- integer dimId, i - character*(MAXCHR) dimName - character*(MAXCHR) stdName - character*(MAXCHR) dimUnits - character*(MAXCHR) posStr - character*(MAXCHR) vname + character(len=MAXCHR) dimName + character(len=MAXCHR) stdName + character(len=MAXCHR) dimUnits + character(len=MAXCHR) posStr + character(len=MAXCHR) vname integer dimSize integer nDims logical surfaceOnly @@ -486,7 +486,7 @@ subroutine CFIO_DimInquire (fid,im,jm,km,lm,nvars,ngatts,vdir,rc) ! Check FID here. ! Check to make sure max string lengths are large enough. NetCDF defines -! MAXNCNAM, but it can't be used in a character*MAXNCNAM statement. +! MAXNCNAM, but it can't be used in a character(len=MAXNCNAM) statement. if (MAXCHR .LT. MAXNCNAM) then print *, 'CFIO_DimInquire warning: MAXNCNAM is larger than ', & @@ -644,7 +644,7 @@ subroutine GetDateTimeVec ( fid, begDate, begTime, incVec, rc ) character(len=MAXCHR) timeUnits, dimUnits !character(len=MAXCHR) strTmp - character*(MAXCHR) varName, dimName, stdName + character(len=MAXCHR) varName, dimName, stdName integer type, nvDims, vdims(MAXVDIMS), nvAtts, dimSize integer nDims, nvars, ngatts, dimId @@ -843,7 +843,7 @@ subroutine GetBegDateTime ( fid, begDate, begTime, incSecs, rc ) integer year, month, day character(len=MAXCHR) timeUnits, dimUnits, stdName - character*(MAXCHR) varName, dimName + character(len=MAXCHR) varName, dimName integer type, nvDims, vdims(MAXVDIMS), nvAtts, dimSize integer nDims, nvars, ngatts, dimId @@ -1049,8 +1049,8 @@ integer function IdentifyDim (dimName, dimUnits) ! ! !INPUT PARAMETERS: ! - character*(*) dimName !! Name of the coordinate variable - character*(*) dimUnits !! Units of the coordinate variable + character(len=*) dimName !! Name of the coordinate variable + character(len=*) dimUnits !! Units of the coordinate variable ! !------------------------------------------------------------------------- @@ -1222,7 +1222,7 @@ subroutine CFIO_Open ( fname, fmode, fid, rc ) ! !INPUT PARAMETERS: ! - character*(*) fname !! File name + character(len=*) fname !! File name integer fmode !! File mode: !! 0 for READ-WRITE !! non-zero for READ-ONLY @@ -1318,7 +1318,7 @@ subroutine CFIO_PutIntAtt ( fid, name, count, buf, prec, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute integer count !! Number of integers to write integer buf(count) !! Buffer with integer values integer prec !! Desired precision of attribute value: @@ -1411,7 +1411,7 @@ subroutine CFIO_PutRealAtt ( fid, name, count, buf, prec, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute integer count !! Number of integers to write real buf(count) !! Buffer with real values integer prec !! Desired precision of attribute value: @@ -1505,7 +1505,7 @@ subroutine CFIO_PutCharAtt ( fid, name, count, buf, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute integer count !! Number of characters to write character(len=MLEN) :: buf !! Buffer containing string ! @@ -1569,7 +1569,7 @@ subroutine CFIO_GetAttNames ( fid, ngatts, aname, rc ) ! ! !OUTPUT PARAMETERS: ! - character*(*) aname(ngatts) !! Array of attribute names + character(len=*) aname(ngatts) !! Array of attribute names integer rc !! Error return code: !! rc = 0 all is well !! rc = -10 ngatts is incompatible with file @@ -1654,7 +1654,7 @@ subroutine CFIO_AttInquire ( fid, name, type, count, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute ! ! !OUTPUT PARAMETERS: ! @@ -1720,7 +1720,7 @@ subroutine CFIO_GetIntAtt ( fid, name, count, buf, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -1824,7 +1824,7 @@ subroutine CFIO_GetRealAtt ( fid, name, count, buf, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -1927,7 +1927,7 @@ subroutine CFIO_GetCharAtt ( fid, name, count, buf, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute ! ! !INPUT/OUTPUT PARAMETERS: ! @@ -2165,7 +2165,7 @@ SUBROUTINE CALDAT (JULIAN,MM,ID,IYYY) END subroutine CALDAT integer function err ( outstring, iret, ec ) - character *(*) outstring + character(len=*) outstring integer ec, iret if (iret .EQ. 0) then @@ -2202,7 +2202,7 @@ subroutine ParseTimeUnits ( TimeUnits, year, month, day, hour, min, sec, rc ) ! ! !INPUT PARAMETERS: ! - character*(MAXCHR) TimeUnits !! Units metadata string from the Time coord var + character(len=MAXCHR) TimeUnits !! Units metadata string from the Time coord var ! ! !OUTPUT PARAMETERS: ! @@ -2338,7 +2338,7 @@ subroutine CFIO_SPutVar ( fid, vname, yyyymmdd, hhmmss, & ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) vname !! Variable name + character(len=*) vname !! Variable name integer yyyymmdd !! Year-month-day, e.g., 19971003 integer hhmmss !! Hour-minute-second, e.g., 120000 @@ -2383,7 +2383,7 @@ subroutine CFIO_SPutVar ( fid, vname, yyyymmdd, hhmmss, & !------------------------------------------------------------------------- integer timeid, timeDimId, dimSize, timeType - character*(MAXCHR) dimName + character(len=MAXCHR) dimName integer corner(3), edges(3) integer vid integer(INT64) seconds @@ -2405,7 +2405,7 @@ subroutine CFIO_SPutVar ( fid, vname, yyyymmdd, hhmmss, & ! Variables for NF90_INQUIRE_VARIABLE - character*(MAXCHR) varName + character(len=MAXCHR) varName integer type, nvDims, vdims(MAXVDIMS), nvAtts ! Variables for packing and range checking @@ -2425,7 +2425,7 @@ subroutine CFIO_SPutVar ( fid, vname, yyyymmdd, hhmmss, & outPRange = .FALSE. ! Check to make sure max string lengths are large enough. NetCDF defines -! MAXNCNAM, but it can't be used in a character*MAXNCNAM statement. +! MAXNCNAM, but it can't be used in a character(len=MAXNCNAM) statement. if (MAXCHR .LT. MAXNCNAM) then print *, 'CFIO_PutVar warning: MAXNCNAM is larger than ', & @@ -2717,7 +2717,7 @@ subroutine CFIO_SGetVar ( fid, vname, yyyymmdd, hhmmss,& ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) vname !! Variable name + character(len=*) vname !! Variable name integer yyyymmdd !! Year-month-day, e.g., 19971003 integer hhmmss !! Hour-minute-second, e.g., 120000 integer im !! size of longitudinal dimension @@ -2768,10 +2768,10 @@ subroutine CFIO_SGetVar ( fid, vname, yyyymmdd, hhmmss,& ! Variables for working with dimensions - character*(MAXCHR) dimName - character*(MAXCHR) stdName - character*(MAXCHR) dimUnits - character*(MAXCHR) varName + character(len=MAXCHR) dimName + character(len=MAXCHR) stdName + character(len=MAXCHR) dimUnits + character(len=MAXCHR) varName integer dimSize, dimId integer nDims,nvars,ngatts integer varType, myIndex @@ -2799,7 +2799,7 @@ subroutine CFIO_SGetVar ( fid, vname, yyyymmdd, hhmmss,& ! Check to make sure max string lengths are large enough. NetCDF defines -! MAXNCNAM, but it can't be used in a character*MAXNCNAM statement. +! MAXNCNAM, but it can't be used in a character(len=MAXNCNAM) statement. if (MAXCHR .LT. MAXNCNAM) then print *, 'CFIO_GetVar warning: MAXNCNAM is larger than ', & @@ -3084,7 +3084,7 @@ subroutine CFIO_GetVar ( fid, vname, yyyymmdd, hhmmss,& ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) vname !! Variable name + character(len=*) vname !! Variable name integer yyyymmdd !! Year-month-day, e.g., 19971003 integer hhmmss !! Hour-minute-second, e.g., 120000 integer im !! size of longitudinal dimension @@ -3136,9 +3136,9 @@ subroutine CFIO_GetVar ( fid, vname, yyyymmdd, hhmmss,& ! Variables for working with dimensions - character*(MAXCHR) dimName - character*(MAXCHR) dimUnits - character*(MAXCHR) varName + character(len=MAXCHR) dimName + character(len=MAXCHR) dimUnits + character(len=MAXCHR) varName integer dimSize, dimId integer nDims,nvars,ngatts integer varType @@ -3168,7 +3168,7 @@ subroutine CFIO_GetVar ( fid, vname, yyyymmdd, hhmmss,& edges = 1 ! Check to make sure max string lengths are large enough. NetCDF defines -! MAXNCNAM, but it can't be used in a character*MAXNCNAM statement. +! MAXNCNAM, but it can't be used in a character(len=MAXNCNAM) statement. if (MAXCHR .LT. MAXNCNAM) then print *, 'CFIO_GetVar warning: MAXNCNAM is larger than ',& @@ -3491,7 +3491,7 @@ subroutine CFIO_PutVar ( fid, vname, yyyymmdd, hhmmss, & ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) vname !! Variable name + character(len=*) vname !! Variable name integer yyyymmdd !! Year-month-day, e.g., 19971003 integer hhmmss !! Hour-minute-second, e.g., 120000 @@ -3536,7 +3536,7 @@ subroutine CFIO_PutVar ( fid, vname, yyyymmdd, hhmmss, & !------------------------------------------------------------------------- integer timeid, timeDimId, dimSize, timeType - character*(MAXCHR) dimName + character(len=MAXCHR) dimName integer corner(5), edges(5) integer vid integer(INT64) seconds @@ -3558,7 +3558,7 @@ subroutine CFIO_PutVar ( fid, vname, yyyymmdd, hhmmss, & ! Variables for NF90_INQUIRE_VARIABLE - character*(MAXCHR) varName + character(len=MAXCHR) varName integer type, nvDims, vdims(MAXVDIMS), nvAtts ! Variables for packing and range checking @@ -3576,7 +3576,7 @@ subroutine CFIO_PutVar ( fid, vname, yyyymmdd, hhmmss, & outPRange = .FALSE. ! Check to make sure max string lengths are large enough. NetCDF defines -! MAXNCNAM, but it can't be used in a character*MAXNCNAM statement. +! MAXNCNAM, but it can't be used in a character(len=MAXNCNAM) statement. if (MAXCHR .LT. MAXNCNAM) then print *, 'CFIO_PutVar warning: MAXNCNAM is larger than ',& @@ -3920,7 +3920,7 @@ subroutine GetDateInt8 (yyyymmdd_1,hhmmss_1,offset, & integer year2,mon2,day2,hour2,min2,sec2 integer(kind=INT64) julian1 integer(kind=INT64) julsec, remainder - !character*8 dateString + !character(len=8) dateString ! Error checking. @@ -4058,7 +4058,7 @@ real function CFIO_GetMissing ( fid, rc ) integer nDims, recdim, ngatts integer varType, nvDims, vDims(MAXVDIMS), nvAtts - character*(MAXCHR) vnameTemp + character(len=MAXCHR) vnameTemp integer i integer attType, attLen integer allVars ! all variables - includes dimension vars @@ -4688,7 +4688,7 @@ subroutine EOS_PutIntAtt ( fid, name, count, buf, prec, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute integer count !! Number of integers to write integer buf(count) !! Buffer with integer values integer prec !! Desired precision of attribute value: @@ -4805,7 +4805,7 @@ subroutine EOS_PutRealAtt ( fid, name, count, buf, prec, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute integer count !! Number of integers to write real buf(count) !! Buffer with real values integer prec !! Desired precision of attribute value: @@ -4922,7 +4922,7 @@ subroutine EOS_PutCharAtt ( fid, name, count, buf, rc ) ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) name !! Name of attribute + character(len=*) name !! Name of attribute integer count !! Number of characters to write character(len=MLEN) buf !! Buffer containing string ! @@ -5007,7 +5007,7 @@ subroutine EOS_PutVar ( fid, vname, yyyymmdd, hhmmss, & ! !INPUT PARAMETERS: ! integer fid !! File handle - character*(*) vname !! Variable name + character(len=*) vname !! Variable name integer yyyymmdd !! Year-month-day, e.g., 19971003 integer hhmmss !! Hour-minute-second, e.g., 120000 @@ -5058,9 +5058,9 @@ subroutine EOS_PutVar ( fid, vname, yyyymmdd, hhmmss, & !------------------------------------------------------------------------- integer timeid, dimSize, dimId - character*(MAXCHR) dimName - character*(MAXCHR) attrName - character*(MAXCHR) dimUnits + character(len=MAXCHR) dimName + character(len=MAXCHR) attrName + character(len=MAXCHR) dimUnits integer attrType, attrCount integer corner(4), edges(4), stride(4) integer dim_chunk(4), origin(4) @@ -5069,7 +5069,7 @@ subroutine EOS_PutVar ( fid, vname, yyyymmdd, hhmmss, & integer minutes ! added as a work-around integer idx, i, j, k integer begDate, begTime, timInc - character*8 strBuf + character(len=8) strBuf integer hour,min,sec,incSecs integer rct @@ -5084,7 +5084,7 @@ subroutine EOS_PutVar ( fid, vname, yyyymmdd, hhmmss, & ! Variables for NF90_INQUIRE_VARIABLE - character*(MAXCHR) varName + character(len=MAXCHR) varName integer type, nvDims, dimSizes(MAX_VAR_DIMS), nvAtts ! Variables for packing and range checking @@ -5145,7 +5145,7 @@ subroutine EOS_PutVar ( fid, vname, yyyymmdd, hhmmss, & outPRange = .FALSE. ! Check to make sure max string lengths are large enough. NetCDF defines -! MAXNCNAM, but it can't be used in a character*MAXNCNAM statement. +! MAXNCNAM, but it can't be used in a character(len=MAXNCNAM) statement. if (MAXCHR .LT. MAXNCNAM) then print *, 'EOS_PutVar warning: MAXNCNAM is larger than ', & @@ -5698,7 +5698,7 @@ end subroutine EOS_PutVar INTEGER FUNCTION GetSDSid (fid, varName) IMPLICIT NONE integer fid - character*(*) varName + character(len=*) varName integer sdid, rc, idx integer HDFfid, sd_id diff --git a/MAPL_cfio/netcdf_stub.F90 b/MAPL_cfio/netcdf_stub.F90 index 4ffab9a203f2..25085f657c54 100644 --- a/MAPL_cfio/netcdf_stub.F90 +++ b/MAPL_cfio/netcdf_stub.F90 @@ -8,12 +8,12 @@ ! miscellaneous routines: ! function nf_inq_libvers() result(status) - character*80 :: status + character(len=80) :: status status='' end function nf_inq_libvers function nf_strerror() result(status) - character*80 :: status + character(len=80) :: status status='' end function nf_strerror diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index e9e0244367b8..60126a5d0b26 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -37,15 +37,15 @@ module subroutine MAPL_AllocateCoupling(field, rc) type(ESMF_Field), intent(INOUT) :: field - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status character(len=ESMF_MAXSTR), parameter :: IAm='MAPL_AllocateCouplingFromField' type(ESMF_FieldStatus_Flag) :: fieldStatus - integer :: dims - integer :: location + integer :: dims + integer :: location integer :: knd integer, pointer :: ungrd(:) integer :: hw @@ -119,13 +119,13 @@ end subroutine MAPL_AllocateCoupling module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & hw, ungrid, default_value, rc) type(ESMF_Field), intent(INOUT) :: field - integer, intent(IN ) :: dims - integer, intent(IN ) :: location + integer, intent(IN ) :: dims + integer, intent(IN ) :: location integer, intent(IN ) :: typekind integer, intent(IN ) :: hw !halowidth integer, optional, intent(IN ) :: ungrid(:) real, optional, intent(IN ) :: default_value - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status @@ -161,7 +161,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end do ! ALT: the next allocation should have been griddedDims, ! but this compilcates the code unnecessery - allocate(haloWidth(gridRank), stat=status) + allocate(haloWidth(gridRank), stat=status) _VERIFY(STATUS) haloWidth = (/HW,HW,0/) @@ -185,7 +185,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & rank = szungrd !ALT: This is special case - array does not map any gridded dims - gridToFieldMap= 0 + gridToFieldMap= 0 if (typekind == ESMF_KIND_R4) then select case (rank) case (1) @@ -222,7 +222,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & case(MAPL_DimsVertOnly) !ALT: This is special case - array does not map any gridded dims - gridToFieldMap = 0 + gridToFieldMap = 0 rank=1 lb1 = 1 ub1 = COUNTS(3) @@ -344,7 +344,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end if _VERIFY(STATUS) - ! Horz + Vert + ! Horz + Vert ! ----------- case(MAPL_DimsHorzVert) lb1 = 1-HW @@ -426,7 +426,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & end select RankCase3d ! Tiles - ! ----- + ! ----- case(MAPL_DimsTileOnly) rank = 1 + szungrd _ASSERT(gridRank == 1, 'gridRank /= 1') @@ -522,7 +522,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & ! Invalid dimensionality ! ---------------------- - case default + case default _RETURN(ESMF_FAILURE) end select Dimensionality @@ -531,7 +531,7 @@ module subroutine MAPL_FieldAllocCommit(field, dims, location, typekind, & if (present(default_value)) then call MAPL_AttributeSet(field, NAME="MAPL_InitStatus", & VALUE=MAPL_InitialDefault, RC=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) end if ! Clean up @@ -544,7 +544,7 @@ end subroutine MAPL_FieldAllocCommit module subroutine MAPL_FieldF90Deallocate(field, rc) type(ESMF_Field), intent(INOUT) :: field - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status character(len=ESMF_MAXSTR), parameter :: IAm='MAPL_FieldF90Deallocate' @@ -586,7 +586,7 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) type(ESMF_State), intent(INOUT) :: state real, pointer :: ptr(:,:) character(len=*), intent(IN ) :: name - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status @@ -631,7 +631,7 @@ module subroutine MAPL_SetPointer2DR4(state, ptr, name, rc) _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) _VERIFY(STATUS) - ! MAPL restriction (actually only the first 2 dims are distributted) + ! MAPL restriction (actually only the first 2 dims are distributted) _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') allocate(gridToFieldMap(gridRank), stat=status) _VERIFY(STATUS) @@ -659,7 +659,7 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) type(ESMF_State), intent(INOUT) :: state real, pointer :: ptr(:,:,:) character(len=*), intent(IN ) :: name - integer, optional, intent( OUT) :: rc + integer, optional, intent( OUT) :: rc integer :: status @@ -704,8 +704,8 @@ module subroutine MAPL_SetPointer3DR4(state, ptr, name, rc) _ASSERT(size(ptr,2) == COUNTS(2), 'shape mismatch dim=2') call ESMF_GridGet(GRID, dimCount=gridRank, rc=status) _VERIFY(STATUS) - ! MAPL restriction (actually only the first 2 dims are distributted) - _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') + ! MAPL restriction (actually only the first 2 dims are distributted) + _ASSERT(gridRank <= 3, 'gridRank > 3 not supported') allocate(gridToFieldMap(gridRank), stat=status) _VERIFY(STATUS) do I = 1, gridRank @@ -768,7 +768,7 @@ module subroutine MAPL_DecomposeDim ( dim_world,dim,NDEs, unusable, symmetric, m do ndiv=0,ndivs-1 !modified for mirror-symmetry !original line - ! ie = is + CEILING( float(ieg-is+1)/(ndivs-ndiv) ) - 1 + ! ie = is + CEILING( real(ieg-is+1)/(ndivs-ndiv) ) - 1 !problem of dividing nx points into n domains maintaining symmetry !i.e nx=18 n=4 4554 and 5445 are solutions but 4455 is not. @@ -874,13 +874,13 @@ end subroutine MAPL_MakeDecomposition module subroutine MAPL_Interp_Fac (TIME0, TIME1, TIME2, FAC1, FAC2, RC) - !------------------------------------------------------------ + !------------------------------------------------------------ ! PURPOSE: ! ======== ! - ! Compute interpolation factors, fac, to be used - ! in the calculation of the instantaneous boundary + ! Compute interpolation factors, fac, to be used + ! in the calculation of the instantaneous boundary ! conditions, ie: ! ! q(i,j) = fac1*q1(i,j) + (1.-fac1)*q2(i,j) @@ -893,16 +893,16 @@ module subroutine MAPL_Interp_Fac (TIME0, TIME1, TIME2, FAC1, FAC2, RC) ! INPUT: ! ====== ! time0 : Time of current timestep - ! time1 : Time of boundary data 1 - ! time2 : Time of boundary data 2 + ! time1 : Time of boundary data 1 + ! time2 : Time of boundary data 2 ! OUTPUT: ! ======= ! fac1 : Interpolation factor for Boundary Data 1 ! - ! ------------------------------------------------------------ - ! GODDARD LABORATORY FOR ATMOSPHERES - ! ------------------------------------------------------------ + ! ------------------------------------------------------------ + ! GODDARD LABORATORY FOR ATMOSPHERES + ! ------------------------------------------------------------ type(ESMF_Time), intent(in ) :: TIME0, TIME1, TIME2 real, intent(out) :: FAC1 @@ -924,7 +924,7 @@ end subroutine MAPL_Interp_Fac module subroutine MAPL_ClimInterpFac (CLOCK,I1,I2,FAC, RC) - !------------------------------------------------------------ + !------------------------------------------------------------ type(ESMF_CLOCK), intent(in ) :: CLOCK integer, intent(OUT) :: I1, I2 @@ -1066,7 +1066,7 @@ module subroutine MAPL_tick (nymd,nhms,ndt) ENDIF NHMS = MAPL_NHMSF (NSEC) ENDIF - RETURN + RETURN end subroutine MAPL_tick integer module function MAPL_nsecf2 (nhhmmss,nmmdd,nymd) @@ -1111,7 +1111,7 @@ integer module function MAPL_nhmsf (nsec) end function MAPL_nhmsf ! A year is a leap year if - ! 1) it is divible by 4, and + ! 1) it is divible by 4, and ! 2) it is not divisible by 100, unless ! 3) it is also divisible by 400. logical module function MAPL_LEAP(NY) @@ -1122,34 +1122,34 @@ logical module function MAPL_LEAP(NY) end function MAPL_LEAP - integer module function MAPL_incymd (NYMD,M) + integer module function MAPL_incymd (NYMD,M) integer nymd,ny,nm,nd,m - INTEGER NDPM(12) - DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ - NY = NYMD / 10000 - NM = MOD(NYMD,10000) / 100 - ND = MOD(NYMD,100) + M - IF (ND.EQ.0) THEN - NM = NM - 1 - IF (NM.EQ.0) THEN - NM = 12 - NY = NY - 1 + INTEGER NDPM(12) + DATA NDPM /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/ + NY = NYMD / 10000 + NM = MOD(NYMD,10000) / 100 + ND = MOD(NYMD,100) + M + IF (ND.EQ.0) THEN + NM = NM - 1 + IF (NM.EQ.0) THEN + NM = 12 + NY = NY - 1 ENDIF - ND = NDPM(NM) - IF (NM.EQ.2 .AND. MAPL_LEAP(NY)) ND = 29 + ND = NDPM(NM) + IF (NM.EQ.2 .AND. MAPL_LEAP(NY)) ND = 29 ENDIF - IF (ND.EQ.29 .AND. NM.EQ.2 .AND. MAPL_LEAP(NY)) GO TO 20 - IF (ND.GT.NDPM(NM)) THEN - ND = 1 - NM = NM + 1 - IF (NM.GT.12) THEN - NM = 1 - NY = NY + 1 + IF (ND.EQ.29 .AND. NM.EQ.2 .AND. MAPL_LEAP(NY)) GO TO 20 + IF (ND.GT.NDPM(NM)) THEN + ND = 1 + NM = NM + 1 + IF (NM.GT.12) THEN + NM = 1 + NY = NY + 1 ENDIF ENDIF -20 CONTINUE - MAPL_INCYMD = NY*10000 + NM*100 + ND - RETURN +20 CONTINUE + MAPL_INCYMD = NY*10000 + NM*100 + ND + RETURN end function MAPL_incymd @@ -1192,7 +1192,7 @@ module subroutine MAPL_PICKEM(II,JJ,IM,JM,COUNT) enddo !!$ DO L=1,JM -!!$ PRINT '(144L1)',MASK(:,L) +!!$ PRINT '(144L1)',MASK(:,L) !!$ ENDDO !!$ !!$ PRINT *, COUNT, NN @@ -1224,7 +1224,7 @@ module subroutine MAPL_GetFieldTimeFromField ( FIELD, TIME, RC ) call ESMF_AttributeGet(FIELD, NAME="TimeStamp", VALUE=TIMESTAMP, RC=STATUS) _VERIFY(STATUS) - call MAPL_TimeStringGet (TIMESTAMP, YY=YEAR, MM=MONTH, DD=DAY, & + call MAPL_TimeStringGet (TIMESTAMP, YY=YEAR, MM=MONTH, DD=DAY, & H =HOUR, M =MINUTE, S =SCND ) _VERIFY(STATUS) call ESMF_TimeSet (TIME, YY=YEAR, MM=MONTH, DD=DAY, & @@ -1306,7 +1306,7 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) type (ESMF_Field) :: F ! we are creating new field so that we can change the name of the field; - ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) + ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) ! are the SAME as the one in the original Field, if DoCopy flag is present ! and set to true we create a new array and copy the data, not just reference it @@ -1355,7 +1355,7 @@ module function MAPL_FieldCreateRename(FIELD, NAME, DoCopy, RC) RESULT(F) hasUngridDims = .true. endif - if (doCopy_) then + if (doCopy_) then datacopy = ESMF_DATACOPY_VALUE else datacopy = ESMF_DATACOPY_REFERENCE @@ -1458,13 +1458,13 @@ module function MAPL_FieldCreateNewgrid(FIELD, GRID, LM, NEWNAME, RC) RESULT(F) integer, optional, intent( OUT) :: RC type (ESMF_Field) :: F - ! we are creating new field so that we can change the grid of the field + ! we are creating new field so that we can change the grid of the field ! (and allocate array accordingly); !ALT: This function is currently used only in History for regridding on an output grid !ALT halowidth assumed 0 - ! type(ESMF_FieldDataMap) :: datamap + ! type(ESMF_FieldDataMap) :: datamap type (ESMF_Grid) :: fGRID type(ESMF_Array) :: array type (ESMF_LocalArray), target :: larrayList(1) @@ -1595,7 +1595,7 @@ module function MAPL_FieldCreateR4(FIELD, RC) RESULT(F) type (ESMF_Field) :: F ! we are creating new field so that we can change the name of the field; - ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) + ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) ! are the SAME as the one in the original Field, if DoCopy flag is present ! and set to true we create a new array and copy the data, not just reference it @@ -1712,8 +1712,8 @@ module subroutine MAPL_FieldCopyAttributes(FIELD_IN, FIELD_OUT, RC) type (ESMF_Field), intent(INOUT) :: FIELD_OUT integer, optional, intent( OUT) :: RC integer :: status - - call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, rc=status) + + call ESMF_AttributeCopy(field_in, field_out, attcopy=ESMF_ATTCOPY_VALUE, rc=status) _VERIFY(status) _RETURN(ESMF_SUCCESS) end subroutine MAPL_FieldCopyAttributes @@ -1724,7 +1724,7 @@ module subroutine MAPL_FieldCopy(from, to, RC) integer, optional, intent( OUT) :: RC ! we are creating new field so that we can change the name of the field; - ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) + ! the important thing is that the data (ESMF_Array) and the grid (ESMF_Grid) ! are the SAME as the one in the original Field, if DoCopy flag is present ! and set to true we create a new array and copy the data, not just reference it @@ -1863,19 +1863,19 @@ end subroutine MAPL_GRID_INTERIOR ! grid with 72 layers: !% !``` -! GDEF: LatLon -! IDEF: 32 -! JDEF: 16 -! LDEF: 1 +! GDEF: LatLon +! IDEF: 32 +! JDEF: 16 +! LDEF: 1 ! XDEF: 288 LINEAR -180. 1.25 ! YDEF: 181 LINEAR -90. 1. ! ZDEF: 72 LINEAR 1 1 !``` ! -! More generally, +! More generally, !``` -! GDEF: LatLon -! IDEF: Nx +! GDEF: LatLon +! IDEF: Nx ! JDEF: Ny ! LDEF: Nz ! XDEF: IM_World XCoordType BegLon, DelLon @@ -1883,23 +1883,23 @@ end subroutine MAPL_GRID_INTERIOR ! ZDEF: LM_World ZCoordType 1 1 !``` ! -! The attribute **GDEF** must always be *LatLon* for Lat/Lon grids. +! The attribute **GDEF** must always be *LatLon* for Lat/Lon grids. ! The remaining parameters are: ! !- **Nx** is the number of processors used to decompose the X dimension !- **Ny** is the number of processors used to decompose the Y dimension -!- **Nz** is the number of processors used to decompose the Z dimension; must be 1 for now. +!- **Nz** is the number of processors used to decompose the Z dimension; must be 1 for now. !- **IM_World** is the number of longitudinal grid points; if `IM_World=0` then the ! grid has no zonal dimension. !- **XCoordType** must be set to LINEAR -!- **BegLon** is the longitude (in degrees) of the *center* of the first +!- **BegLon** is the longitude (in degrees) of the *center* of the first ! gridbox !- **DelLon** is the constant mesh size (in degrees); if `DelLon<1` then a ! global grid is assumed. !- **JM_World** is the number of meridional grid points if `JM_World=0` then ! the grid has no meridional dimension. !- **YCoordType** must be set to LINEAR -!- **BegLat** is the latitude (in degrees) of the *center* of the first +!- **BegLat** is the latitude (in degrees) of the *center* of the first ! gridbox !- **DelLat** is the constant mesh size (in degrees); if `DelLat<1` then a ! global grid is assumed. @@ -1918,7 +1918,7 @@ end subroutine MAPL_GRID_INTERIOR ! ! Alternatively, one can specify coordinate information in the argument ! list; their units and meaning is as in the resource file above. In -! this case you must specify at least `Nx, Ny, IM_World, JM_World`, and +! this case you must specify at least `Nx, Ny, IM_World, JM_World`, and ! `LM\_World`. The other parameters have default values !- **BegLon** defaults to -180. (the date line) !- **DelLon** defaults to -1. (meaning a global grid) @@ -1928,23 +1928,23 @@ end subroutine MAPL_GRID_INTERIOR !### Restrictions ! The current implementation imposes the following restrictions: !1. Only uniform longitude/latitude grids are supported (no Gaussian grids). -!2. Only 2D Lon-Lat or 3D Lon-Lat-Lev grids are currently supported +!2. Only 2D Lon-Lat or 3D Lon-Lat-Lev grids are currently supported ! (no Lat-Lev or Lon-Lev grids supprted yet). !3. No vertical decomposition yet (`Nz=1`). ! !### Future enhancements ! The `IDEF/JDEF/LDEF` records in the resource file should be ! extended as to allow specification of a more general distribution. -! For consistency with the `XDEF/YDEF/ZDEF` records a similar +! For consistency with the `XDEF/YDEF/ZDEF` records a similar ! syntax could be adopted. For example, -! +! !``` -! IDEF 4 LEVELS 22 50 50 22 -! XDEF 144 LINEAR -180 2.5 +! IDEF 4 LEVELS 22 50 50 22 +! XDEF 144 LINEAR -180 2.5 !``` ! would indicate that longitudes would be decomposed in 4 PETs, ! with the first PET having 22 grid points, the second 50 gridpoints, -! and so on. +! and so on. ! module function MAPL_LatLonGridCreate (Name, vm, & Config, ConfigFile, & @@ -1965,8 +1965,8 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! There are 3 possibilities to provide the coordinate information: ! 1) Thru Config object: - type(ESMF_Config), OPTIONAL, target, & - intent(in) :: Config + type(ESMF_Config), OPTIONAL, target, & + intent(in) :: Config ! 2) Thru a resource file: character(len=*), OPTIONAL, intent(in) :: ConfigFile @@ -1974,7 +1974,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! 3) Thru argument list: integer, OPTIONAL, intent(in) :: Nx, Ny ! Layout - integer, OPTIONAL, intent(in) :: IM_World ! Zonal + integer, OPTIONAL, intent(in) :: IM_World ! Zonal real, OPTIONAL, intent(in) :: BegLon, DelLon ! in degrees integer, OPTIONAL, intent(in) :: JM_World ! Meridional @@ -1990,13 +1990,13 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Internal version of the input arguments ! --------------------------------------- type(ESMF_Config), pointer :: Config_ - integer :: IM_World_ + integer :: IM_World_ real(kind=REAL64) :: BegLon_ - real(kind=REAL64) :: DelLon_ - integer :: JM_World_ + real(kind=REAL64) :: DelLon_ + integer :: JM_World_ real(kind=REAL64) :: BegLat_ real(kind=REAL64) :: DelLat_ - integer :: LM_World_ + integer :: LM_World_ integer :: Nx_, Ny_, Nz_ integer, allocatable :: IMs(:), JMs(:), LMs(:) @@ -2019,7 +2019,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Defaults ! -------- - BegLon_ = -180.0 ! centered at date line + BegLon_ = -180.0 ! centered at date line DelLon_ = -1.0 ! means global grid BegLat_ = -90.0 ! centered at south pole DelLat_ = -1.0 ! means global grid @@ -2100,14 +2100,14 @@ module function MAPL_LatLonGridCreate (Name, vm, & if ( DelLon_ < 0.0 ) then ! convention for global grids if ( IM_World_ == 1 ) then DelLon_ = 0.0 - else + else DelLon_ = 360.d0 / IM_World_ end if end if if ( DelLat_ < 0.0 ) then ! convention for global grids if ( JM_World_ == 1 ) then DelLat_ = 0.0 - else + else DelLat_ = 180.d0 / ( JM_World_ - 1) end if end if @@ -2115,7 +2115,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! Give the IMs, JMs and LMs the MAPL default distribution ! ------------------------------------------------------- allocate( IMs(0:Nx_-1), JMs(0:Ny_-1), LMs(0:Nz_-1), stat=STATUS) - _VERIFY(STATUS) + _VERIFY(STATUS) call MAPL_DecomposeDim ( IM_World_, IMs, Nx_ ) call MAPL_DecomposeDim ( JM_World_, JMs, Ny_ ) call MAPL_DecomposeDim ( LM_World_, LMs, Nz_ ) @@ -2127,7 +2127,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! 3D Lat-Lon-Lev Grid ! ------------------- - if ( LM_World_>0 .AND. IM_World_>0 .AND. JM_World_>0 ) then + if ( LM_World_>0 .AND. IM_World_>0 .AND. JM_World_>0 ) then !ALT creat actually 2-d grid the SAME way MAPL_GridCreate #if 0 Grid = ESMF_GridCreateShapeTile ( & @@ -2162,7 +2162,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & ! 2D Lat-Lon Grid ! --------------- - else if ( LM_World_==0 .AND. IM_World_>0 .AND. JM_World>0 ) then + else if ( LM_World_==0 .AND. IM_World_>0 .AND. JM_World>0 ) then Grid = ESMF_GridCreate( & name=Name, & countsPerDEDim1=IMs, & @@ -2175,7 +2175,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & _VERIFY(STATUS) ! Other possibilities not implemented yet - ! --------------------------------------- + ! --------------------------------------- else STATUS = 300 @@ -2184,8 +2184,8 @@ module function MAPL_LatLonGridCreate (Name, vm, & endif ! ------------------------------------------------------------------- - ! NOTE: In the remaining part of this routine it is assumed that the - ! 1st and 2nd axes correspond to lat/lon; revise this for other + ! NOTE: In the remaining part of this routine it is assumed that the + ! 1st and 2nd axes correspond to lat/lon; revise this for other ! arrangements (say, YZ grids) ! ------------------------------------------------------------------- @@ -2199,7 +2199,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & deltaX = MAPL_DEGREES_TO_RADIANS_R8 * DelLon_ deltaY = MAPL_DEGREES_TO_RADIANS_R8 * DelLat_ minCoord(1) = MAPL_DEGREES_TO_RADIANS_R8 * BegLon_ - deltaX/2 - minCoord(2) = MAPL_DEGREES_TO_RADIANS_R8 * BegLat_ - deltaY/2 + minCoord(2) = MAPL_DEGREES_TO_RADIANS_R8 * BegLat_ - deltaY/2 allocate(cornerX(IM_World_+1),cornerY(JM_World_+1), stat=STATUS) _VERIFY(STATUS) @@ -2229,7 +2229,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & FirstOut(1)=BegLon_ FirstOut(2)=-90. LastOut(1)=360.+BegLon_ - 360./im_world_ - LastOut(2)=90. + LastOut(2)=90. block use MAPL_Constants, only: MAPL_DEGREES_TO_RADIANS_R8 @@ -2260,7 +2260,7 @@ module function MAPL_LatLonGridCreate (Name, vm, & _VERIFY(STATUS) ! Clean up - ! -------- + ! -------- deallocate(cornerY,cornerX) deallocate(IMs,JMs,LMs) if ( present(ConfigFile) ) deallocate(Config_) @@ -2376,7 +2376,7 @@ module subroutine MAPL_GridGetCorners(grid,gridCornerLons, gridCornerLats, RC) gridCornerLats=ptr(1:im+1,1:jm+1) deallocate(ptr) - call ESMF_FieldDestroy(field,rc=status) + call ESMF_FieldDestroy(field,rc=status) _VERIFY(status) call ESMF_FieldHaloRelease(rh,rc=status) _VERIFY(status) @@ -2659,7 +2659,7 @@ module subroutine MAPL_FieldBundleDestroy(Bundle,RC) isCreated = ESMF_FieldBundleIsCreated(bundle,rc=status) - _VERIFY(STATUS) + _VERIFY(STATUS) if(isCreated) then call ESMF_FieldBundleGet(BUNDLE, FieldCount=FIELDCOUNT, RC=STATUS) _VERIFY(STATUS) @@ -2958,7 +2958,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) ! if the grid is present then we can just get the prestored edges and the dimensions of the grid ! this also means we are running on a distributed grid ! if grid not present then the we just be running outside of ESMF and the user must - ! pass in the the dimensions of the grid and we must compute them + ! pass in the the dimensions of the grid and we must compute them ! and assume search on the global domain if (present(Grid)) then call MAPL_GridGet(grid, localCellCountPerDim=counts,globalCellCountPerDim=dims,rc=status) @@ -2980,7 +2980,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) target_lats = latR8 end if - _ASSERT(localSearch,"Global Search for IJ not implemented") + _ASSERT(localSearch,"Global Search for IJ not implemented") !AOO change tusing GridType atribute if (im_world*6==jm_world) then call ESMF_AttributeGet(grid, name='GridType', value=grid_type, _RC) @@ -3148,7 +3148,7 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, JM_World = dims(2) _ASSERT( IM_WORLD*6 == JM_WORLD, "It only works for cubed-sphere grid") - dalpha = 2.0d0*alpha/IM_WORLD + dalpha = 2.0d0*alpha/IM_WORLD ! make sure the grid can be used in this subroutine good_grid = grid_is_ok(grid) @@ -3224,7 +3224,7 @@ elemental subroutine calculate(x, y, z, i, j) J = J + IM_WORLD*4 ! face = 6 elseif (abs(z+1.0d0) <= tolerance) then - call angle_to_index( y, x, i, j) + call angle_to_index( y, x, i, j) J = J + IM_WORLD*5 endif @@ -3249,10 +3249,10 @@ function grid_is_ok(grid) result(OK) real(ESMF_KIND_R8), allocatable :: corner_lons(:,:), corner_lats(:,:) real(ESMF_KIND_R8) :: accurate_lat, accurate_lon real :: tolerance - + tolerance = epsilon(1.0) call MAPL_GridGetInterior(grid,I1,I2,J1,J2) - OK = .true. + OK = .true. ! check the edge of face 1 along longitude allocate(corner_lons(I2-I1+2, J2-J1+2)) allocate(corner_lats(I2-I1+2, J2-J1+2)) @@ -3343,7 +3343,7 @@ module subroutine MAPL_GenGridName(im, jm, lon, lat, xyoffset, gridname, geos_st pole='PE' case (3) dateline='DE' - pole='PE' + pole='PE' end select endif @@ -3411,7 +3411,7 @@ module subroutine MAPL_GeosNameNew(name) character(len=8) :: imsz character(len=8) :: jmsz - ! Parse name for grid info + ! Parse name for grid info !------------------------- Gridname = AdjustL(name) @@ -3429,7 +3429,7 @@ module subroutine MAPL_GeosNameNew(name) write(name,'(a,i4.4,a,a,i4.4)') dateline,im,'x',pole,jm else ! Cubed-sphere - pole='6C' + pole='6C' if (dateline=='CF') then write(name,'(a,i4.4,a,a)') dateline,im,'x',pole else @@ -3472,7 +3472,7 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un _ASSERT(size(fieldNames) == size(is2D),'inconsistent size of is2D array') localIs2D = is2D else - localIs2D = .false. + localIs2D = .false. end if allocate(localIsEdge(size(fieldNames)),stat=status) _VERIFY(STATUS) @@ -3480,7 +3480,7 @@ module function MAPL_BundleCreate(name,grid,fieldNames,is2D,isEdge,long_names,un _ASSERT(size(fieldNames) == size(isEdge), 'inconsistent size of isEdge array') localIsEdge = isEdge else - localIsEdge = .false. + localIsEdge = .false. end if if (present(long_names)) then _ASSERT(size(fieldNames) == size(long_names), 'inconsistent size of long_names array') @@ -3858,7 +3858,7 @@ subroutine genAlias(name, n, splitNameArray, aliasName, rc) do i=nn+1,n write(splitNameArray(i),'(A,I3.3)') trim(name), i end do - + _RETURN(ESMF_SUCCESS) end subroutine GenAlias end subroutine MAPL_FieldSplit @@ -3867,7 +3867,7 @@ module function MAPL_GetCorrectedPhase(gc,rc) result(phase) type(ESMF_GridComp), intent(inout) :: gc integer, optional, intent(out) :: rc integer :: phase - + integer :: status call ESMF_GridCompGet(gc,currentPhase=phase,rc=status) diff --git a/base/ESMFL_Mod.F90 b/base/ESMFL_Mod.F90 index dc93ed89be5e..20b9eb258d4e 100644 --- a/base/ESMFL_Mod.F90 +++ b/base/ESMFL_Mod.F90 @@ -40,7 +40,7 @@ module ESMFL_MOD private ! -!ALT These need to be changed +!ALT These need to be changed ! values here are just to compile ! @@ -1138,7 +1138,7 @@ end subroutine ESMFL_FieldRegrid !------------------------------------------------------------------------- !> ! Given a `srcFLD` and its associated `3dGrid` and a `dstFLD` and its associated -! `3DGrid`, the subroutine `ESMFL_RegridStore` creates their corresponding +! `3DGrid`, the subroutine `ESMFL_RegridStore` creates their corresponding ! `2DGrids` and a 2D routehandle. ! !#### History @@ -1641,7 +1641,7 @@ end subroutine FieldRegrid1 ! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.3, GMAO ! !------------------------------------------------------------------------- !> -! The subroutine `BundleRegrid1` +! The subroutine `BundleRegrid1` ! regrids members of a bundle using ESMF_FieldRegrid. ! !#### History @@ -1852,11 +1852,11 @@ end subroutine BundleRegrid1 !- 24Apr2006 Cruz Initial code. ! subroutine BundleRegrid (srcBUN, dstBUN, rc) -! +! implicit NONE ! !ARGUMENTS: - + type(ESMF_FieldBundle), intent(inout) :: srcBUN !! source bundle type(ESMF_FieldBundle), intent(inout) :: dstBUN !! destination bundle integer, optional, intent(out) :: rc !! return code @@ -2151,7 +2151,7 @@ end subroutine Bundle_Prep_ ! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.3, GMAO ! !------------------------------------------------------------------------- !> -! The subroutine `assign_slices_` +! The subroutine `assign_slices_` ! determines number of bundle slices per PE and "load balanced" ! map of slices-to-pes (slice_pe). ! @@ -3001,7 +3001,7 @@ subroutine stats_ (lu,mx,my,k,a1,& character(*), intent(in) :: atype ! Type of the variable character(*), intent(in) :: htype ! Typf of the levels real amiss ! missing value flag of a - character*(*) header ! A header message + character(len=*) header ! A header message integer inc ! order of the listing real,optional :: a2(mx,my) ! The array2 ! @@ -3019,7 +3019,7 @@ subroutine stats_ (lu,mx,my,k,a1,& real rfrcval parameter(rfrcval=1.e-5) - character*255 dash + character(len=255) dash ! ..function @@ -3143,7 +3143,7 @@ end subroutine BundleDiff !------------------------------------------------------------------------- !> ! Determine the diff of two state. -! +! !#### History !- 19Apr2006 Cruz Initial code. ! @@ -4351,7 +4351,7 @@ function ESMFL_field_is_undefined(field,rc) result(field_is_undefined) else _FAIL("Unsupported rank when checking for undef") end if - + _RETURN(_SUCCESS) end function diff --git a/base/MAPL_CFIO.F90 b/base/MAPL_CFIO.F90 index 65806d540f7c..eeef17d68e43 100644 --- a/base/MAPL_CFIO.F90 +++ b/base/MAPL_CFIO.F90 @@ -4127,7 +4127,7 @@ subroutine MAPL_CFIOSet( MCFIO, Root, Psize, fName, Krank, IOWorker, globalComm, ! type(MAPL_CFIO), intent(INOUT) :: MCFIO integer, optional, intent(IN ) :: Root, Psize - character*(*), optional, intent(IN ) :: fName + character(len=*), optional, intent(IN ) :: fName integer, optional, intent(IN ) :: Krank(:) integer, optional, intent(IN ) :: IOWorker integer, optional, intent(IN ) :: globalComm diff --git a/base/MAPL_LocStreamMod.F90 b/base/MAPL_LocStreamMod.F90 index a721dfa71079..a5628dcc7f53 100644 --- a/base/MAPL_LocStreamMod.F90 +++ b/base/MAPL_LocStreamMod.F90 @@ -1004,7 +1004,7 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, ! Compute coefficients for interpolating in G2T if the grid is lat-lon !--------------------------------------------------------------------- - DX = 360./float(tiling%IM) + DX = 360./real(tiling%IM) I = index(TILING%NAME,'-',.true.) !bmaa got rid if ( I <=0) then @@ -1023,10 +1023,10 @@ subroutine MAPL_LocStreamCreateFromFile(LocStream, LAYOUT, FILENAME, NAME, MASK, end if if (TILING%NAME(1:2)=='PE') then - DY = 180./float(tiling%JM ) + DY = 180./real(tiling%JM ) Y0 = -90. + DY*0.5 elseIF(TILING%NAME(1:2)=='PC') then - DY = 180./float(tiling%JM-1) + DY = 180./real(tiling%JM-1) Y0 = -90. else DoCoeffs = .false. diff --git a/base/MAPL_MaxMinMod.F90 b/base/MAPL_MaxMinMod.F90 index a8103600c66b..8aa0bef53b4e 100644 --- a/base/MAPL_MaxMinMod.F90 +++ b/base/MAPL_MaxMinMod.F90 @@ -44,7 +44,7 @@ module MAPL_MaxMinMod subroutine pmaxmin3d_r4 ( qname, a, pmin, pmax, fac ) implicit none - character*(*), intent(in) :: qname ! label to print + character(len=*), intent(in) :: qname ! label to print real(ESMF_KIND_R4), intent(in) :: a(:,:,:) ! input array real(ESMF_KIND_R4), optional, intent(in) :: fac ! multiplication factor real(ESMF_KIND_R4), optional, intent(out) :: pmax, pmin ! min/max value @@ -58,7 +58,7 @@ end subroutine pmaxmin3d_r4 subroutine pmaxmin2d_r4 ( qname, a, pmin_, pmax_, fac_ ) implicit none - character*(*), intent(in) :: qname ! label to print + character(len=*), intent(in) :: qname ! label to print real(ESMF_KIND_R4), intent(in) :: a(:,:) ! input array real(ESMF_KIND_R4), optional, intent(in) :: fac_ ! multiplication factor real(ESMF_KIND_R4), optional, intent(out) :: pmax_, pmin_ ! min/max value @@ -115,7 +115,7 @@ subroutine pmaxmin2d_r4 ( qname, a, pmin_, pmax_, fac_ ) call MAPL_CommsAllReduceMax(vm, sendbuf=pm1, recvbuf=pm_res, cnt=two, RC=status) pmax=pm_res(1) pmin=-pm_res(2) - + if ( present(pmax_) ) pmax_ = pmax if ( present(pmin_) ) pmin_ = pmin deallocate(qmax,qmin) @@ -135,7 +135,7 @@ end subroutine pmaxmin2d_r4 subroutine pmaxmin1d_r4 ( qname, a, pmin, pmax, fac ) implicit none - character*(*), intent(in) :: qname ! label to print + character(len=*), intent(in) :: qname ! label to print real(ESMF_KIND_R4), intent(in) :: a(:) ! input array real(ESMF_KIND_R4), optional, intent(in) :: fac ! multiplication factor real(ESMF_KIND_R4), optional, intent(out) :: pmax, pmin ! min/max value @@ -150,12 +150,12 @@ end subroutine pmaxmin1d_r4 subroutine pmaxmin3d_r8 ( qname, a, pmin, pmax, fac ) implicit none - character*(*), intent(in) :: qname ! label to print + character(len=*), intent(in) :: qname ! label to print real(ESMF_KIND_R8), intent(in) :: a(:,:,:) ! input array real(ESMF_KIND_R8), optional, intent(in) :: fac ! multiplication factor real(ESMF_KIND_R8), optional, intent(out) :: pmax, pmin ! min/max value ! --- - real(ESMF_KIND_R4) :: pmin_r4, pmax_r4, fac_r4 + real(ESMF_KIND_R4) :: pmin_r4, pmax_r4, fac_r4 if ( present(fac) ) then fac_r4 = fac else @@ -168,12 +168,12 @@ end subroutine pmaxmin3d_r8 subroutine pmaxmin2d_r8 ( qname, a, pmin, pmax, fac ) implicit none - character*(*), intent(in) :: qname ! label to print + character(len=*), intent(in) :: qname ! label to print real(ESMF_KIND_R8), intent(in) :: a(:,:) ! input array real(ESMF_KIND_R8), optional, intent(in) :: fac ! multiplication factor real(ESMF_KIND_R8), optional, intent(out) :: pmax, pmin ! min/max value ! --- - real(ESMF_KIND_R4) :: pmin_r4, pmax_r4, fac_r4 + real(ESMF_KIND_R4) :: pmin_r4, pmax_r4, fac_r4 if ( present(fac) ) then fac_r4 = fac else @@ -186,12 +186,12 @@ end subroutine pmaxmin2d_r8 subroutine pmaxmin1d_r8 ( qname, a, pmin, pmax, fac ) implicit none - character*(*), intent(in) :: qname ! label to print + character(len=*), intent(in) :: qname ! label to print real(ESMF_KIND_R8), intent(in) :: a(:) ! input array real(ESMF_KIND_R8), optional, intent(in) :: fac ! multiplication factor real(ESMF_KIND_R8), optional, intent(out) :: pmax, pmin ! min/max value ! --- - real(ESMF_KIND_R4) :: pmin_r4, pmax_r4, fac_r4 + real(ESMF_KIND_R4) :: pmin_r4, pmax_r4, fac_r4 if ( present(fac) ) then fac_r4 = fac else diff --git a/base/Regrid_Functions_Mod.F90 b/base/Regrid_Functions_Mod.F90 index 4fd879fb6f53..0c17900df41c 100644 --- a/base/Regrid_Functions_Mod.F90 +++ b/base/Regrid_Functions_Mod.F90 @@ -177,7 +177,7 @@ Subroutine Set_fID(fIDIn, fIDOut, RC) Call Assert(-1,'Set_fID','fIDIn already set') End If End If - + If (Present(fIDOut)) Then If (fIDOutLocal.lt.0) Then fIDOutLocal = fIDOut @@ -224,7 +224,7 @@ Subroutine Cleanup(RC) RC = NF90_CLOSE(ncid=fIDInLocal) Write(6,'(a,I0.3)') 'Closed input file. Result: ', RC End If - + If (fIDOutLocal.gt.-1) Then RC = NF90_CLOSE(ncid=fIDOutLocal) Write(6,'(a,I0.3)') 'Closed output file. Result: ', RC @@ -237,7 +237,7 @@ Subroutine Cleanup(RC) If (Allocated(JJ_Out)) Deallocate(JJ_Out) If (Allocated(W)) Deallocate(W) If (Allocated(outSum)) Deallocate(outSum) - + End Subroutine Cleanup !EOC !----------------------------------------------------------------------- @@ -301,7 +301,7 @@ subroutine readTileFileNC(TFDir,gridIn,gridOut,RC) call readTileFileNC_file(fName, rc=status) if (present(rc)) rc = status - + end subroutine readTileFileNC subroutine readTileFileNC_file(fName, RC) @@ -356,7 +356,7 @@ subroutine readTileFileNC_file(fName, RC) If (nDimIn == 1) Then ! Cubed-sphere grid I = resInFile(1) - resInFile(1) = Int(sqrt(float(I/6))) + resInFile(1) = Int(sqrt(real(I/6))) resInFile(2) = resInFile(1) * 6 End If @@ -370,7 +370,7 @@ subroutine readTileFileNC_file(fName, RC) If (nDimOut == 1) Then ! Cubed-sphere grid I = resOutFile(1) - resOutFile(1) = Int(sqrt(float(I/6))) + resOutFile(1) = Int(sqrt(real(I/6))) resOutFile(2) = resOutFile(1) * 6 End If @@ -454,7 +454,7 @@ subroutine readTileFileNC_file(fName, RC) RC = NF90_GET_VAR(ncid=fID, varid=I, values=RTemp) W = RTemp - ! Close the tile file + ! Close the tile file RC = NF90_CLOSE(ncid=fID) ! Remap the cube faces @@ -715,13 +715,13 @@ Subroutine readTileFile(TFDir,gridIn,gridOut,RC) Close(Unit=fID) Call Assert(-1,'readTileFile','Bad grid count') End If - + Do I=1,nGrids Read(fID) STemp Read(fID) nX(I) Read(fID) nY(I) gridNameTF(I) = Trim(STemp) - End Do + End Do Found = .False. Do I=1,nGrids @@ -819,7 +819,7 @@ Subroutine readTileFile(TFDir,gridIn,gridOut,RC) !Read(fID) RTemp !W = RTemp - ! Close the tile file + ! Close the tile file Close(Unit=fID) ! Allocate the counting variable @@ -927,8 +927,8 @@ Subroutine genGridName(nX, nY, gridName, xVec, yVec, & pole='6C' write(gridname,'(a,i4.4,a,a)') dateline,nX,'x',pole end if - - ! Assign outputs + + ! Assign outputs If (present(isCS)) isCS = isCS_ If (present(isDE)) isDE = isDE_ If (present(isPC)) isPC = isPC_ @@ -1074,8 +1074,8 @@ Subroutine parseGridName( gridName, nX, nY, isCS, isDE, isPC ) End If End If End If - - ! Assign outputs + + ! Assign outputs If (present(isCS)) isCS = isCS_ If (present(isDE)) isDE = isDE_ If (present(isPC)) isPC = isPC_ @@ -1133,41 +1133,41 @@ Subroutine nXYtoVec(xVec,yVec,isCS,isPC,isDE,RC) Else ! Simple system Do I = 1, nX - xVec(I) = Float(I) + xVec(I) = real(I) End Do Do I = 1, nY - yVec(I) = Float(I) + yVec(I) = real(I) End Do End If Else - ! Longitude first - fStride = 360.0/Float(nX) + ! Longitude first + fStride = 360.0/real(nX) If (isDE) Then fMin = (-180.0) - (fStride/2.0) Else fMin = (-180.0) - fStride End If Do I = 1, nX - xVec(I) = fMin + (fStride * Float(I)) + xVec(I) = fMin + (fStride * real(I)) End Do ! Now latitude If (isPC) Then - fStride = (180.0 / Float(nY - 1)) + fStride = (180.0 / real(nY - 1)) fMin = (-90.0) - fStride Else - fStride = (180.0 / Float(nY)) + fStride = (180.0 / real(nY)) fMin = (-90.0) - (fStride/2.0) End If Do I = 1, nY - yVec(I) = fMin + (fStride * Float(I)) + yVec(I) = fMin + (fStride * real(I)) End Do If (isPC) Then yVec(1) = (-90.0) + (fStride/4.0) yVec(nY) = ( 90.0) - (fStride/4.0) - End If + End If End If If (Present(RC)) RC = RC_ - + End Subroutine nXYToVec !EOC !----------------------------------------------------------------------- @@ -1221,7 +1221,7 @@ Subroutine GetLUN(LUN,RC) End Do If (isOpen) RC_ = -1 If (Present(RC)) RC = RC_ - + End Subroutine GetLUN !EOC !----------------------------------------------------------------------- @@ -1288,11 +1288,11 @@ Subroutine regridData(in2D,out2D,RC) wVal = outSum(iX,iY) out2D(iX,iY) = out2D(iX,iY)/wVal End If - End Do + End Do End Do If (Present(RC)) RC = 0 - - End Subroutine regridData + + End Subroutine regridData !EOC !----------------------------------------------------------------------- ! GEOS-Chem Global Chemical Transport Model ! @@ -1329,7 +1329,7 @@ Subroutine ReadInput(resOut,fNameIn,fNameOut,reverseLev,& ! Integer :: fIDGCHP, RC_, I Integer :: resTemp(2) - Character(Len=255) :: currLine, strRead + Character(Len=255) :: currLine, strRead Logical :: Found, logRead !================================================================= @@ -1381,18 +1381,18 @@ Subroutine ReadInput(resOut,fNameIn,fNameOut,reverseLev,& RC_ = -10 End If resOut = resTemp - + ! Input file name Read(fIDGCHP,'(a)',IOStat=RC_) currLine I = SCAN(currLine,':') Read(currLine((I+1):),*,IOStat=RC_) strRead fNameIn = Trim(AdjustL(strRead)) - + ! Output file name Read(fIDGCHP,'(a)',IOStat=RC_) currLine I = SCAN(currLine,':') Read(currLine((I+1):),*,IOStat=RC_) strRead - + fNameOut = Trim(AdjustL(strRead)) ! Reverse vertical grid? @@ -1400,14 +1400,14 @@ Subroutine ReadInput(resOut,fNameIn,fNameOut,reverseLev,& I = SCAN(currLine,':') Read(currLine((I+1):),*,IOStat=RC_) logRead reverseLev = logRead - Else + Else ! Report failure RC_ = -1 End If Close(Unit=fIDGCHP) If (Present(RC)) RC = RC_ - + End Subroutine ReadInput !EOC End Module Regrid_Functions_Mod diff --git a/base/cub2latlon_regridder.F90 b/base/cub2latlon_regridder.F90 index 0c511d29cf17..db789f275cf5 100644 --- a/base/cub2latlon_regridder.F90 +++ b/base/cub2latlon_regridder.F90 @@ -1025,7 +1025,7 @@ subroutine create_cubed_sphere_grid(this, rc) end if nPetPerTile = pet_count/n_tiles - nx = nint(sqrt(float(nPetPerTile*this%Xdim)/this%Xdim)) + nx = nint(sqrt(real(nPetPerTile*this%Xdim)/this%Xdim)) nx = max(nx,1) do while( mod(nPetPerTile,nx).NE.0) nx = nx - 1 diff --git a/base/sun.H b/base/sun.H index bb58867bc8f4..7b68dfd9cfcd 100644 --- a/base/sun.H +++ b/base/sun.H @@ -44,9 +44,9 @@ integer :: nits ! Begin - + _ASSERT(MAPL_SunOrbitCreated(ORBIT),'MAPL_SunOrbit not yet created!') - + ! which time mode? if (present(TIME)) then TIME_ = TIME @@ -76,7 +76,7 @@ ZTP = 0. ! analytic two-body currently only works with TIME_=0 currently - _ASSERT(.NOT.(ORBIT%ANAL2B.AND.TIME_/=0),'analytic two-body orbit currently requires TIME_=0') + _ASSERT(.NOT.(ORBIT%ANAL2B.AND.TIME_/=0),'analytic two-body orbit currently requires TIME_=0') MEAN_OR_INST: if(.not.present(INTV) .or. TIME_==MAPL_SunDailyMean & .or. TIME_==MAPL_SunAnnualMean) then @@ -108,8 +108,8 @@ ! pmn: EOT will just displace sunlit period wrt mean noon, ! but the daily mean values will not change - _FAIL('pmn: MAPL_SunDailyMean probably in error!') - _ASSERT(.NOT.ORBIT%ANAL2B,'not implemented for analytic two-body orbit') + _FAIL('pmn: MAPL_SunDailyMean probably in error!') + _ASSERT(.NOT.ORBIT%ANAL2B,'not implemented for analytic two-body orbit') SLR = sin(LATS)*ORBIT%ZS(IDAY) ZTH = cos(LATS)*ORBIT%ZC(IDAY) @@ -139,7 +139,7 @@ ZTH = 0.0 endwhere - _ASSERT(.not.present(ZTHP),'ZTHP not implemented for SunDailyMean') + _ASSERT(.not.present(ZTHP),'ZTHP not implemented for SunDailyMean') case(MAPL_SunAnnualMean) @@ -149,8 +149,8 @@ ! its a mean over the whole currently fixed 4-year cycle. ! see above - _FAIL('pmn: MAPL_SunAnnualMean probably in error!') - _ASSERT(.NOT.ORBIT%ANAL2B,'not implemented for analytic two-body orbit') + _FAIL('pmn: MAPL_SunAnnualMean probably in error!') + _ASSERT(.NOT.ORBIT%ANAL2B,'not implemented for analytic two-body orbit') SLR = 0.0 ZTH = 0.0 @@ -171,18 +171,18 @@ ZTH = ZTH + ZTT end do - SLR = SLR / float(ORBIT%DAYS_PER_CYCLE) - ZTH = ZTH / float(ORBIT%DAYS_PER_CYCLE) + SLR = SLR / real(ORBIT%DAYS_PER_CYCLE) + ZTH = ZTH / real(ORBIT%DAYS_PER_CYCLE) if(present(DIST)) DIST = 1.0 - _ASSERT(.not.present(ZTHP),'ZTHP not implemented for SunAnnualMean') + _ASSERT(.not.present(ZTHP),'ZTHP not implemented for SunAnnualMean') case (0, & - MAPL_SunAutumnalEquinox, & - MAPL_SunWinterSolstice , & - MAPL_SunVernalEquinox , & - MAPL_SunSummerSolstice ) + MAPL_SunAutumnalEquinox, & + MAPL_SunWinterSolstice , & + MAPL_SunVernalEquinox , & + MAPL_SunSummerSolstice ) ! Greenwich MEAN solar hour angle OFFSET by PI ! (since FAC is zero at mignight) @@ -303,7 +303,7 @@ ! at TOA, which is then divided through by again at the end of REFRESH ! to get the required NORMALIZED fluxes. So this is probably only a small ! non-linear effect. In the solar UPDATE_EXPORT() at the heartbeat the -! normalized fluxes are always re-multiplied by SLR, and so the SLR +! normalized fluxes are always re-multiplied by SLR, and so the SLR ! values below will be used directly (without reference to DIST.) case(10) diff --git a/base/tests/testbin.F90 b/base/tests/testbin.F90 index cf9d69a843c5..42aa43702368 100644 --- a/base/tests/testbin.F90 +++ b/base/tests/testbin.F90 @@ -11,7 +11,7 @@ program testbin do j=1,jmin do i=1,IMin -ain(i,j) = sin(2*2.*3.1415926*(i-10)/float(IMin))*sin(-0.5*3.1415926 + 3.1415926*(j-1)/float(JMin)) +ain(i,j) = sin(2*2.*3.1415926*(i-10)/real(IMin))*sin(-0.5*3.1415926 + 3.1415926*(j-1)/real(JMin)) end do end do @@ -23,7 +23,7 @@ program testbin stop __LINE__ endif call system_clock(ic1,icr) -print *, 'Create transform: ',float(ic1-ic0)/float(icr) +print *, 'Create transform: ',real(ic1-ic0)/real(icr) call system_clock(ic0) do l=1,72 @@ -34,7 +34,7 @@ program testbin endif enddo call system_clock(ic1,icr) -print *, 'Do 72 fields',float(ic1-ic0)/float(icr) +print *, 'Do 72 fields',real(ic1-ic0)/real(icr) print *, rc open(10,file='ain',form='unformatted',status='unknown') @@ -65,7 +65,7 @@ program testbin endif enddo call system_clock(ic1,icr) -print *, 'Do 72 fields',float(ic1-ic0)/float(icr) +print *, 'Do 72 fields',real(ic1-ic0)/real(icr) print *, rc write(10) ain @@ -82,7 +82,7 @@ program testbin endif enddo call system_clock(ic1,icr) -print *, 'Do 72 fields',float(ic1-ic0)/float(icr) +print *, 'Do 72 fields',real(ic1-ic0)/real(icr) print *, rc diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 8737508c9bfd..62068fe63901 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -3022,12 +3022,12 @@ subroutine MAPL_DateStampGet (clock, DateStamp, rc) character(len=ESMF_MAXSTR) :: IAm integer :: status - 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 equivalence ( string(01),TimeString ) equivalence ( string(01),year ) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 6569a303ce35..6d3ce14d0c95 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3861,9 +3861,9 @@ subroutine MAPL_GradsCtlWrite ( clock, state,list,fname,expid,expdsc,output_grid call MAPL_GridGet(pgrid,globalCellCountPerDim=dims,_RC) IM = dims(1) JM = dims(2) - DLON = 360._REAL64/float(IM) + DLON = 360._REAL64/real(IM) if (JM /= 1) then - DLAT = 180._REAL64/float(JM-1) + DLAT = 180._REAL64/real(JM-1) else DLAT = 1.0 end if diff --git a/gridcomps/Orbit/MAPL_OrbGridCompMod.F90 b/gridcomps/Orbit/MAPL_OrbGridCompMod.F90 index 0ee925fea9ec..993fd2dcb436 100644 --- a/gridcomps/Orbit/MAPL_OrbGridCompMod.F90 +++ b/gridcomps/Orbit/MAPL_OrbGridCompMod.F90 @@ -31,7 +31,7 @@ MODULE MAPL_OrbGridCompMod Use MAPL_Constants Use MAPL_CommsMod, only: MAPL_AM_I_ROOT Use MAPL_ErrorHandlingMod - + IMPLICIT NONE PRIVATE ! @@ -68,7 +68,7 @@ MODULE MAPL_OrbGridCompMod CONTAINS !------------------------------------------------------------------------------ !> -! Sets IRF services for the Orb Grid Component. +! Sets IRF services for the Orb Grid Component. ! Sets Initialize, Run and Finalize services. ! SUBROUTINE SetServices ( GC, RC ) @@ -85,7 +85,7 @@ SUBROUTINE SetServices ( GC, RC ) integer :: i, nCols _Iam_('SetServices') - integer :: status + integer :: status logical :: found ! ------------ @@ -105,15 +105,15 @@ SUBROUTINE SetServices ( GC, RC ) allocate ( self, stat=STATUS ) _VERIFY(STATUS) wrap%ptr => self - + ! Load private Config Attributes ! ------------------------------ self%CF = ESMF_ConfigCreate(_RC) inquire(file="MAPL_OrbGridComp.rc", exist=found) if (found) then call ESMF_ConfigLoadFile ( self%CF,'MAPL_OrbGridComp.rc',rc=status) - _VERIFY(STATUS) - + _VERIFY(STATUS) + call ESMF_ConfigGetAttribute(self%CF, self%verbose, Label='verbose:', default=.false. , _RC ) ! ------------------------ @@ -122,7 +122,7 @@ SUBROUTINE SetServices ( GC, RC ) call ESMF_ConfigGetDim(self%CF, self%no, nCols, LABEL='Nominal_Orbits::',_RC) _ASSERT(self%no>0,'needs informative message') - allocate(self%Instrument(self%no), self%Satellite(self%no), & + allocate(self%Instrument(self%no), self%Satellite(self%no), & self%Swath(self%no), self%halo(self%no), __STAT__) if ( self%verbose .AND. MAPL_AM_I_ROOT() ) then write(*,*)" Swath" @@ -154,12 +154,12 @@ SUBROUTINE SetServices ( GC, RC ) _VERIFY(STATUS) call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run_, RC=STATUS) _VERIFY(STATUS) - + ! Store internal state in GC ! -------------------------- call ESMF_UserCompSetInternalState ( GC, 'Orb_state', wrap, STATUS ) _VERIFY(STATUS) - + ! ------------------ ! MAPL Data Services ! @@ -186,7 +186,7 @@ SUBROUTINE SetServices ( GC, RC ) ! Generic Set Services ! -------------------- call MAPL_GenericSetServices ( GC, _RC ) - + ! All done ! -------- _RETURN(ESMF_SUCCESS) @@ -199,7 +199,7 @@ END SUBROUTINE SetServices ! subroutine Initialize_( GC, IMPORT, EXPORT, CLOCK, RC ) - type(ESMF_GridComp), intent(inout) :: GC !! Gridded component + type(ESMF_GridComp), intent(inout) :: GC !! Gridded component type(ESMF_State), intent(inout) :: IMPORT !! Import state type(ESMF_State), intent(inout) :: EXPORT !! Export state type(ESMF_Clock), intent(inout) :: CLOCK !! The clock @@ -228,7 +228,7 @@ subroutine Initialize_( GC, IMPORT, EXPORT, CLOCK, RC ) ! extra things for cubed sphere integer :: IM, JM, face real(ESMF_KIND_R8), pointer :: EdgeLons(:,:), EdgeLats(:,:) -! Begin... +! Begin... ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- @@ -250,7 +250,7 @@ subroutine Initialize_( GC, IMPORT, EXPORT, CLOCK, RC ) call ESMF_StateGet(EXPORT,'SATORB',BUNDLE,RC=STATUS) _VERIFY(STATUS) - + call ESMF_GridCompGet ( GC, grid=GRID, RC=STATUS) _VERIFY(STATUS) @@ -268,7 +268,7 @@ subroutine Initialize_( GC, IMPORT, EXPORT, CLOCK, RC ) _VERIFY(STATUS) enddo - ! find out what type of grid we are on, if so + ! find out what type of grid we are on, if so gridtype_default='Lat-Lon' call ESMF_AttributeGet(Grid,'GridType',gridtype,gridtype_default) if (gridtype=='Cubed-Sphere') then @@ -277,7 +277,7 @@ subroutine Initialize_( GC, IMPORT, EXPORT, CLOCK, RC ) _VERIFY(STATUS) call MAPL_Get(MAPL_OBJ, im=im, jm=jm, rc=status) _VERIFY(STATUS) - + allocate(EdgeLons(IM+1,JM+1),stat=status) _VERIFY(STATUS) allocate(EdgeLats(IM+1,JM+1),stat=status) @@ -316,9 +316,9 @@ SUBROUTINE Run_ ( gc, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_GridComp), intent(inout) :: GC !! Grid Component type(ESMF_State), intent(inout) :: IMPORT !! Import State type(ESMF_State), intent(inout) :: EXPORT !! Export State - integer, optional :: rc !! Error return code: - !! 0 - all is well - !! 1 - + integer, optional :: rc !! Error return code: + !! 0 - all is well + !! 1 - ! local type (ESMF_VM) :: VM type (MAPL_MetaComp), pointer :: MAPL_OBJ @@ -339,7 +339,7 @@ SUBROUTINE Run_ ( gc, IMPORT, EXPORT, CLOCK, rc ) type(ESMF_Grid) :: Grid ! Grid type(ESMF_Time) :: Time ! Current time - type(ESMF_Config) :: CF ! Universal Config + type(ESMF_Config) :: CF ! Universal Config integer :: k, nymd, nhms ! date, time @@ -380,7 +380,7 @@ SUBROUTINE Run_ ( gc, IMPORT, EXPORT, CLOCK, rc ) RC=STATUS ) _VERIFY(STATUS) -! Figure out what type of grid we are on +! Figure out what type of grid we are on gridtype_default='Lat-Lon' call ESMF_AttributeGet(Grid,'GridType',gridtype,gridtype_default) @@ -459,10 +459,10 @@ SUBROUTINE Run_ ( gc, IMPORT, EXPORT, CLOCK, rc ) ihalo, jhalo, self%face, rc=status ) endif ! if HISTORY is asking for mask to write this will be allocated - if (associated(PTR_TMP_EX)) PTR_TMP_EX=PTR_TMP + if (associated(PTR_TMP_EX)) PTR_TMP_EX=PTR_TMP if (associated(PTR_TMP)) nullify(PTR_TMP) if (associated(PTR_TMP_EX)) nullify(PTR_TMP_EX) - + enddo ! All done @@ -481,7 +481,7 @@ subroutine extract_ ( GC, CLOCK, self, GRID, CF, time, nymd, nhms, timeinterval, type(Orb_state), pointer :: self ! Legacy state type(ESMF_Grid), intent(out) :: GRID ! Grid - type(ESMF_Config), intent(out) :: CF ! Universal Config + type(ESMF_Config), intent(out) :: CF ! Universal Config type(ESMF_TIME), intent(out) :: Time ! Time type(ESMF_TimeInterval), intent(out) :: TimeInterval ! Time Intervale integer, intent(out) :: nymd, nhms ! date, time @@ -490,7 +490,7 @@ subroutine extract_ ( GC, CLOCK, self, GRID, CF, time, nymd, nhms, timeinterval, ! --- character(len=ESMF_MAXSTR) :: comp_name - + _Iam_('extract_') type(Orb_Wrap) :: wrap @@ -558,9 +558,9 @@ subroutine DoMasking_ (field, im, jm, lons, lats, undef, & ! !OUTPUT PARAMETERS: real, intent(inout) :: field(im,jm) - integer, intent(out), optional :: rc !! Error return code - !! = 0 all is well - !! = 3 memory allocation error + integer, intent(out), optional :: rc !! Error return code + !! = 0 all is well + !! = 3 memory allocation error ! ---- @@ -599,7 +599,7 @@ subroutine DoMasking_ (field, im, jm, lons, lats, undef, & ! -------------- mask=0 call orb_mask_lonlat(mask,im,jm,lons,lats,tlons,tlats,size(tlons),jsegs,-180.,180.) - + deallocate(tlons,tlats) else @@ -660,13 +660,13 @@ subroutine DoMasking_CS (field, im, jm, x, y, undef, & integer, intent(in) :: nymd(2) !! Beginning/ending date: YYYYMMDD integer, intent(in) :: nhms(2) !! Beginning/ending time: HHMMSS integer, intent(in) :: face - + ! !OUTPUT PARAMETERS: real, intent(inout) :: field(im,jm) - integer, optional :: rc !! Error return code - !! = 0 all is well - !! = 3 memory allocation error + integer, optional :: rc !! Error return code + !! = 0 all is well + !! = 3 memory allocation error ! ---- @@ -684,7 +684,7 @@ subroutine DoMasking_CS (field, im, jm, x, y, undef, & real(dp), pointer :: slons(:,:) => null() real(dp), pointer :: slats(:,:) => null() -! character*(12) :: Iam="DoMasking_CS" +! character(len=12) :: Iam="DoMasking_CS" SwathWidth(1:2) = swath(1:2) ! type conversion @@ -779,7 +779,7 @@ subroutine flatten_xy(x,y,x_1d,y_1d,im,jm,im_1d,jm_1d,switch) do i =1,jm_1d y_1d(i)=y(i,1) enddo - endif + endif return end subroutine flatten_xy @@ -806,11 +806,11 @@ subroutine orb_mask_xy(mask,im,jm,x,y,tlons,tlats,nobs,jsegs,lb,ub,face,rc) integer, optional, intent(out) :: rc real, pointer :: ex(:), ey(:) - real(dp) :: tlons(nobs), tlats(nobs) + real(dp) :: tlons(nobs), tlats(nobs) real(dp) :: beta integer, intent(out) :: mask(im,jm) real :: x_loc, y_loc - + integer i, j, m, n, nfail, inbox, imp1, jmp1, face_pnt integer im_1d, jm_1d, itmp logical switch @@ -821,8 +821,8 @@ subroutine orb_mask_xy(mask,im,jm,x,y,tlons,tlats,nobs,jsegs,lb,ub,face,rc) if (present(rc)) then rc = ESMF_SUCCESS end if - - + + switch = .false. if ( abs(x(1,1)-x(2,1)) < abs(x(1,1)-x(1,2)) ) switch = .true. if (.not.switch) then @@ -904,18 +904,18 @@ subroutine orb_mask_lonlat(mask,im,jm,lons,lats,tlons,tlats,nobs,jsegs,lb,ub) real :: lons_1d(im), lats_1d(jm) real :: elons(im+1), elats(jm+1) - real(dp) :: tlons(nobs), tlats(nobs) + real(dp) :: tlons(nobs), tlats(nobs) real(dp) :: beta integer, intent(out) :: mask(im,jm) - + integer i, j, m, n, inbox, imp1, jmp1 real :: wcorner_lat(4),wcorner_lon(4) ! corners of world for this proc real :: lat,lon - + ! Build edge coords ! ----------------- - call flatten_latlon(lats,lons,lats_1d,lons_1d,im,jm) + call flatten_latlon(lats,lons,lats_1d,lons_1d,im,jm) call orb_edges_1d(elons,lons_1d,im) call orb_edges_1d(elats,lats_1d,jm) ! since we will need these @@ -971,11 +971,11 @@ subroutine orb_swath_mask_xy(mask,im,jm,x,y,slons,slats,nobs,isegs,jsegs,lb,ub,f integer, intent(in) :: face real, pointer :: ex(:), ey(:) - real(dp) :: slons(3,nobs), slats(3,nobs) + real(dp) :: slons(3,nobs), slats(3,nobs) real(dp) :: alpha, beta, lon1, lon2, lat1, lat2 integer, intent(out) :: mask(im,jm) real :: x_loc, y_loc - + integer :: i, j, k, m, n, imp1, jmp1, inbox, itmp integer :: im_1d, jm_1d real :: wcorner_x(4),wcorner_y(4) @@ -1020,7 +1020,7 @@ subroutine orb_swath_mask_xy(mask,im,jm,x,y,slons,slats,nobs,isegs,jsegs,lb,ub,f alpha = (k - 1.0 ) / ( isegs - 1.0 ) do n = 2, nobs if (abs(slons(1,n-1)-slons(3,n-1)) < 180.) then - lon1 = (1.0-alpha) * slons(1,n-1) + alpha * slons(3,n-1) + lon1 = (1.0-alpha) * slons(1,n-1) + alpha * slons(3,n-1) eplonl1 = slons(1,n-1) eplonr1 = slons(3,n-1) else if (slons(1,n-1) > slons(3,n-1)) then @@ -1028,12 +1028,12 @@ subroutine orb_swath_mask_xy(mask,im,jm,x,y,slons,slats,nobs,isegs,jsegs,lb,ub,f eplonl1 = slons(1,n-1) eplonr1 = slons(3,n-1)+360. else - lon1 = (1.0-alpha) * (slons(1,n-1)+360.) + alpha * slons(3,n-1) + lon1 = (1.0-alpha) * (slons(1,n-1)+360.) + alpha * slons(3,n-1) eplonl1 = slons(1,n-1)+360. eplonr1 = slons(3,n-1) endif if (abs(slons(1,n)-slons(3,n)) < 180.) then - lon2 = (1.0-alpha) * slons(1,n) + alpha * slons(3,n) + lon2 = (1.0-alpha) * slons(1,n) + alpha * slons(3,n) eplonl2 = slons(1,n) eplonr2 = slons(3,n) else if (slons(1,n) > slons(3,n)) then @@ -1048,27 +1048,27 @@ subroutine orb_swath_mask_xy(mask,im,jm,x,y,slons,slats,nobs,isegs,jsegs,lb,ub,f ! interpolate along great circle unless endpoints of interpolation have same lon associate(d2r => MAPL_DEGREES_TO_RADIANS_R8, r2d => MAPL_RADIANS_TO_DEGREES) - eplatl1 = slats(1,n-1) - eplatr1 = slats(3,n-1) - eplatl2 = slats(1,n) - eplatr2 = slats(3,n) + eplatl1 = slats(1,n-1) + eplatr1 = slats(3,n-1) + eplatl2 = slats(1,n) + eplatr2 = slats(3,n) sdnom1 = sin((eplonl1-eplonr1)*d2r) - sdnom2 = sin((eplonl2-eplonr2)*d2r) + sdnom2 = sin((eplonl2-eplonr2)*d2r) if (abs(sdnom1) /= 0.) then sp1 = sin((lon1-eplonr1)*d2r)/sdnom1 sp2 = sin((lon1-eplonl1)*d2r)/sdnom1 lat1 = atan(tan(eplatl1*d2r)*sp1 - tan(eplatr1*d2r)*sp2) lat1 = lat1*r2d else - lat1 = (1.0-alpha) * slats(1,n-1) + alpha * slats(3,n-1) + lat1 = (1.0-alpha) * slats(1,n-1) + alpha * slats(3,n-1) endif if (abs(sdnom2) /= 0.) then sp1 = sin((lon2-eplonr2)*d2r)/sdnom2 sp2 = sin((lon2-eplonl2)*d2r)/sdnom2 lat2 = atan(tan(eplatl2*d2r)*sp1 - tan(eplatr2*d2r)*sp2) - lat2 = lat2*r2d + lat2 = lat2*r2d else - lat2 = (1.0-alpha) * slats(1,n) + alpha * slats(3,n) + lat2 = (1.0-alpha) * slats(1,n) + alpha * slats(3,n) endif do m = 1, jsegs ! along track refinement @@ -1090,12 +1090,12 @@ subroutine orb_swath_mask_xy(mask,im,jm,x,y,slons,slats,nobs,isegs,jsegs,lb,ub,f eplat2=lat2 sdnom=sin((eplon1-eplon2)*d2r) if (abs(sdnom) /= 0. ) then - sp1=sin((lon-eplon2)*d2r)/sdnom + sp1=sin((lon-eplon2)*d2r)/sdnom sp2=sin((lon-eplon1)*d2r)/sdnom latf = atan(tan(eplat1*d2r)*sp1-tan(eplat2*d2r)*sp2) latf = latf*r2d lat = latf - else + else lat = (1.0-beta) * lat1 + beta * lat2 endif if (lon < lb) lon=lon+360. @@ -1110,7 +1110,7 @@ subroutine orb_swath_mask_xy(mask,im,jm,x,y,slons,slats,nobs,isegs,jsegs,lb,ub,f if (inbox == 1) then i = ijsearch(ex,im_1d,x_loc,.false.) j = ijsearch(ey,jm_1d,y_loc,.false.) - if (switch) then + if (switch) then itmp = i i = j j = itmp @@ -1141,11 +1141,11 @@ subroutine orb_swath_mask_lonlat(mask,im,jm,lons,lats,slons,slats,nobs,isegs,jse real :: lons_1d(im),lats_1d(jm) real :: elons(im+1), elats(jm+1) - real(dp) :: slons(3,nobs), slats(3,nobs) + real(dp) :: slons(3,nobs), slats(3,nobs) real(dp) :: alpha, beta, lon1, lon2, lat1, lat2 integer, intent(out) :: mask(im,jm) - + integer i, j, k, m, n, nfail, imp1, jmp1, inbox real :: wcorner_lat(4),wcorner_lon(4) real :: lat,lon @@ -1177,7 +1177,7 @@ subroutine orb_swath_mask_lonlat(mask,im,jm,lons,lats,slons,slats,nobs,isegs,jse alpha = (k - 1.0 ) / ( isegs - 1.0 ) do n = 2, nobs if (abs(slons(1,n-1)-slons(3,n-1)) < 180.) then - lon1 = (1.0-alpha) * slons(1,n-1) + alpha * slons(3,n-1) + lon1 = (1.0-alpha) * slons(1,n-1) + alpha * slons(3,n-1) eplonl1 = slons(1,n-1) eplonr1 = slons(3,n-1) else if (slons(1,n-1) > slons(3,n-1)) then @@ -1185,12 +1185,12 @@ subroutine orb_swath_mask_lonlat(mask,im,jm,lons,lats,slons,slats,nobs,isegs,jse eplonl1 = slons(1,n-1) eplonr1 = slons(3,n-1)+360. else - lon1 = (1.0-alpha) * (slons(1,n-1)+360.) + alpha * slons(3,n-1) + lon1 = (1.0-alpha) * (slons(1,n-1)+360.) + alpha * slons(3,n-1) eplonl1 = slons(1,n-1)+360. eplonr1 = slons(3,n-1) endif if (abs(slons(1,n)-slons(3,n)) < 180.) then - lon2 = (1.0-alpha) * slons(1,n) + alpha * slons(3,n) + lon2 = (1.0-alpha) * slons(1,n) + alpha * slons(3,n) eplonl2 = slons(1,n) eplonr2 = slons(3,n) else if (slons(1,n) > slons(3,n)) then @@ -1205,27 +1205,27 @@ subroutine orb_swath_mask_lonlat(mask,im,jm,lons,lats,slons,slats,nobs,isegs,jse ! interpolate along great circle unless endpoints of interpolation have same lon associate(d2r => MAPL_DEGREES_TO_RADIANS_R8, r2d => MAPL_RADIANS_TO_DEGREES) - eplatl1 = slats(1,n-1) - eplatr1 = slats(3,n-1) - eplatl2 = slats(1,n) - eplatr2 = slats(3,n) + eplatl1 = slats(1,n-1) + eplatr1 = slats(3,n-1) + eplatl2 = slats(1,n) + eplatr2 = slats(3,n) sdnom1 = sin((eplonl1-eplonr1)*d2r) - sdnom2 = sin((eplonl2-eplonr2)*d2r) + sdnom2 = sin((eplonl2-eplonr2)*d2r) if (abs(sdnom1) /= 0.) then sp1 = sin((lon1-eplonr1)*d2r)/sdnom1 sp2 = sin((lon1-eplonl1)*d2r)/sdnom1 lat1 = atan(tan(eplatl1*d2r)*sp1 - tan(eplatr1*d2r)*sp2) lat1 = lat1*r2d else - lat1 = (1.0-alpha) * slats(1,n-1) + alpha * slats(3,n-1) + lat1 = (1.0-alpha) * slats(1,n-1) + alpha * slats(3,n-1) endif if (abs(sdnom2) /= 0.) then sp1 = sin((lon2-eplonr2)*d2r)/sdnom2 sp2 = sin((lon2-eplonl2)*d2r)/sdnom2 lat2 = atan(tan(eplatl2*d2r)*sp1 - tan(eplatr2*d2r)*sp2) - lat2 = lat2*r2d + lat2 = lat2*r2d else - lat2 = (1.0-alpha) * slats(1,n) + alpha * slats(3,n) + lat2 = (1.0-alpha) * slats(1,n) + alpha * slats(3,n) endif do m = 1, jsegs ! along track refinement @@ -1247,12 +1247,12 @@ subroutine orb_swath_mask_lonlat(mask,im,jm,lons,lats,slons,slats,nobs,isegs,jse eplat2=lat2 sdnom=sin((eplon1-eplon2)*d2r) if (abs(sdnom) /= 0. ) then - sp1=sin((lon-eplon2)*d2r)/sdnom + sp1=sin((lon-eplon2)*d2r)/sdnom sp2=sin((lon-eplon1)*d2r)/sdnom latf = atan(tan(eplat1*d2r)*sp1-tan(eplat2*d2r)*sp2) latf = latf*r2d lat = latf - else + else lat = (1.0-beta) * lat1 + beta * lat2 endif if (lon < lb) lon=lon+360. @@ -1352,7 +1352,7 @@ integer function ijsearch(coords,idim,value,periodic) ! fast bisection version i2 = i endif end do - else + else do k = 1, idim ! it should never take take long i = (i1 + i2) / 2 if ( (value .lt. coords(i)) ) then @@ -1367,7 +1367,7 @@ integer function ijsearch(coords,idim,value,periodic) ! fast bisection version endif end do endif - end function + end function subroutine check_face(IM,JM,LONS,LATS,face) @@ -1390,7 +1390,7 @@ subroutine check_face(IM,JM,LONS,LATS,face) if (xyz(1) /= 0.0) then s(1)=rsq3/xyz(1) s(2)=-rsq3/xyz(1) - else + else s(1)=1000.0 s(2)=1000.0 endif @@ -1409,7 +1409,7 @@ subroutine check_face(IM,JM,LONS,LATS,face) s(6)=1000.0 endif do k=1,6 - if (s(k) > 0) then + if (s(k) > 0) then if (s(k) < smin) then smin = s(k) fmin = k @@ -1464,7 +1464,7 @@ subroutine cube_xy(IM,JM,x,y,LONS,LATS,face) end select enddo enddo - + end subroutine cube_xy subroutine cube_xy_point(x,y,LAT,LON,face) @@ -1497,7 +1497,7 @@ subroutine cube_xy_point(x,y,LAT,LON,face) y = -rsq3*cos(LLON)*cos(LLAT)/sin(LLAT) end select - end subroutine cube_xy_point + end subroutine cube_xy_point subroutine check_face_pnt(LON,LAT,face) real, intent(in) :: LON,LAT @@ -1546,9 +1546,9 @@ subroutine check_face_pnt(LON,LAT,face) endif endif enddo - if (fmin /= 7) then + if (fmin /= 7) then face = fmin - endif + endif end subroutine check_face_pnt subroutine orb_halo(im,jm,mask,ihalo,jhalo,rc) @@ -1577,7 +1577,7 @@ subroutine orb_halo(im,jm,mask,ihalo,jhalo,rc) end do ! is loop end if ! (i,j) has mask = 1 end do ! j loop - end do ! i loop + end do ! i loop mask = tmask diff --git a/pfio/HistoryCollection.F90 b/pfio/HistoryCollection.F90 index e191a19922fb..4a4214834ea4 100644 --- a/pfio/HistoryCollection.F90 +++ b/pfio/HistoryCollection.F90 @@ -37,14 +37,14 @@ function new_HistoryCollection(fmd) result(collection) type (FilemetaData), intent(in) :: fmd collection%fmd = fmd - collection%formatters = StringNetCDF4_FileFormatterMap() + collection%formatters = StringNetCDF4_FileFormatterMap() end function new_HistoryCollection function find(this, file_name,rc) result(formatter) class (HistoryCollection), target, intent(inout) :: this character(len=*), intent(in) :: file_name - integer,optional,intent(out) :: rc + integer,optional,intent(out) :: rc type (NetCDF4_FileFormatter), pointer :: formatter type (NetCDF4_FileFormatter) :: fm @@ -57,7 +57,7 @@ function find(this, file_name,rc) result(formatter) iter = this%formatters%find(trim(file_name)) if (iter == this%formatters%end()) then inquire(file=file_name, exist=f_exist) - if(.not. f_exist) then + if(.not. f_exist) then call fm%create(trim(file_name),rc=status) _VERIFY(status) call fm%write(this%fmd, rc=status) @@ -75,14 +75,14 @@ end function find subroutine ModifyMetadata(this,var_map,rc) class (HistoryCollection), target, intent(inout) :: this type (StringVariableMap), intent(in) :: var_map - integer, optional, intent(out) :: rc + integer, optional, intent(out) :: rc type(StringVariableMapIterator) :: iter integer :: status character(len=*), parameter :: Iam = "HistoryCollection::ModifyMetadata()" iter = var_map%begin() - do while (iter /= var_map%end()) + do while (iter /= var_map%end()) call this%fmd%modify_variable(iter%key(), iter%value(), rc=status) _VERIFY(status) call iter%next() @@ -94,9 +94,8 @@ end subroutine ModifyMetadata subroutine ReplaceMetadata(this, fmd,rc) class (HistoryCollection), intent(inout) :: this type (FileMetadata), intent(in) :: fmd - integer, optional, intent(out) :: rc + integer, optional, intent(out) :: rc - integer :: status character(len=*), parameter :: Iam = "HistoryCollection::ReplaceMetadata()" this%fmd = fmd @@ -106,7 +105,7 @@ end subroutine ReplaceMetadata subroutine clear(this, rc) class (HistoryCollection), target, intent(inout) :: this - integer, optional, intent(out) :: rc + integer, optional, intent(out) :: rc type(NetCDF4_FileFormatter), pointer :: f_ptr type(StringNetCDF4_FileFormatterMapIterator) :: iter @@ -131,15 +130,15 @@ end module pFIO_HistoryCollectionMod module pFIO_HistoryCollectionVectorMod use pFIO_HistoryCollectionMod - + ! Create a map (associative array) between names and pFIO_Attributes. - + #define _type type (HistoryCollection) #define _vector HistoryCollectionVector #define _iterator HistoryCollectionVectorIterator #include "templates/vector.inc" - + end module pFIO_HistoryCollectionVectorMod module pFIO_HistoryCollectionVectorUtilMod @@ -164,11 +163,11 @@ subroutine HistoryCollectionVector_serialize(histVec,buffer) if (allocated(buffer)) deallocate(buffer) allocate(buffer(0)) - + n = histVec%size() do i = 1, n hist_ptr=>histVec%at(i) - call hist_ptr%fmd%serialize(tmp) + call hist_ptr%fmd%serialize(tmp) buffer = [buffer,tmp] enddo @@ -190,7 +189,7 @@ subroutine HistoryCollectionVector_deserialize(buffer, histVec) call FileMetadata_deserialize(buffer(n:), hist%fmd) call histVec%push_back(hist) call deserialize_intrinsic(buffer(n:),fmd_len) - n = n + fmd_len + n = n + fmd_len enddo end subroutine diff --git a/profiler/AbstractMeter.F90 b/profiler/AbstractMeter.F90 index 8963cd337dc7..4c34b1a19980 100644 --- a/profiler/AbstractMeter.F90 +++ b/profiler/AbstractMeter.F90 @@ -60,16 +60,17 @@ subroutine finalize(this, rc) class(AbstractMeter), intent(in) :: this integer, optional, intent(out) :: rc integer :: ierror - + ierror = 0 if (dist_initialized) then call MPI_type_free(type_dist_struct, ierror) call MPI_type_free(type_dist_real64, ierror) call MPI_type_free(type_dist_integer, ierror) - call MPI_Op_free(dist_reduce_op,ierror) + call MPI_Op_free(dist_reduce_op,ierror) dist_initialized = .false. endif if (present(rc)) rc = ierror + _UNUSED_DUMMY(this) end subroutine end module MAPL_AbstractMeter diff --git a/profiler/TimeProfiler.F90 b/profiler/TimeProfiler.F90 index 260239a03818..9b6fd64bf87a 100644 --- a/profiler/TimeProfiler.F90 +++ b/profiler/TimeProfiler.F90 @@ -109,6 +109,7 @@ subroutine initialize_global_time_profiler(unusable, name, comm) time_profiler => get_global_time_profiler() time_profiler = TimeProfiler(name_, comm_world = world_comm) + _UNUSED_DUMMY(unusable) end subroutine initialize_global_time_profiler subroutine finalize_global_time_profiler() @@ -130,8 +131,9 @@ subroutine start_global_time_profiler(unusable, rc) call time_profiler%start(rc=status) _VERIFY(status) _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) end subroutine start_global_time_profiler - + subroutine stop_global_time_profiler(unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc @@ -142,6 +144,7 @@ subroutine stop_global_time_profiler(unusable, rc) call time_profiler%stop(rc=status) _VERIFY(status) _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) end subroutine stop_global_time_profiler end module mapl_TimeProfiler diff --git a/shared/MAPL_ErrorHandling.F90 b/shared/MAPL_ErrorHandling.F90 index 862af416055e..f2eef1f3447c 100644 --- a/shared/MAPL_ErrorHandling.F90 +++ b/shared/MAPL_ErrorHandling.F90 @@ -53,17 +53,17 @@ module MAPL_ErrorHandlingMod module procedure MAPL_VRFY module procedure MAPL_VRFYt end interface MAPL_VRFY - + interface MAPL_ASRT module procedure MAPL_ASRT module procedure MAPL_ASRTt end interface MAPL_ASRT - + interface MAPL_RTRN module procedure MAPL_RTRN module procedure MAPL_RTRNt end interface MAPL_RTRN - + contains @@ -94,7 +94,7 @@ logical function MAPL_Assert_return_code(condition, return_code, filename, line, integer, intent(in) :: line integer, optional, intent(out) :: rc ! Not present in MAIN character(:), allocatable :: message - + fail = .not. condition if (fail) then @@ -129,11 +129,11 @@ logical function MAPL_Verify(status, filename, line, rc) result(fail) !$omp end critical (MAPL_ErrorHandling3) if (present(rc)) rc = status end if - + end function MAPL_Verify - subroutine MAPL_Return(status, filename, line, rc) + subroutine MAPL_Return(status, filename, line, rc) integer, intent(in) :: status character(*), intent(in) :: filename integer, intent(in) :: line @@ -152,13 +152,13 @@ subroutine MAPL_Return(status, filename, line, rc) !$omp end critical (MAPL_ErrorHandling4) end if ! Regardless of error: - if (present(rc)) rc = status - + if (present(rc)) rc = status + end subroutine MAPL_Return logical function MAPL_RTRN(A,iam,line,rc) integer, intent(IN ) :: A - character*(*), intent(IN ) :: iam + character(len=*), intent(IN ) :: iam integer, intent(IN ) :: line integer, optional, intent(OUT) :: RC @@ -171,7 +171,7 @@ end function MAPL_RTRN logical function MAPL_VRFY(A,iam,line,rc) integer, intent(IN ) :: A - character*(*), intent(IN ) :: iam + character(len=*), intent(IN ) :: iam integer, intent(IN ) :: line integer, optional, intent(OUT) :: RC MAPL_VRFY = A/=0 @@ -187,7 +187,7 @@ end function MAPL_VRFY logical function MAPL_ASRT(A,iam,line,rc) logical, intent(IN ) :: A - character*(*), intent(IN ) :: iam + character(len=*), intent(IN ) :: iam integer, intent(IN ) :: line integer, optional, intent(OUT) :: RC MAPL_ASRT = .not.A @@ -199,11 +199,11 @@ logical function MAPL_ASRT(A,iam,line,rc) RC=1 endif endif - end function MAPL_ASRT + end function MAPL_ASRT logical function MAPL_ASRTt(A,text,iam,line,rc) logical, intent(IN ) :: A - character*(*), intent(IN ) :: iam,text + character(len=*), intent(IN ) :: iam,text integer, intent(IN ) :: line integer, optional, intent(OUT) :: RC MAPL_ASRTt = MAPL_ASRT(A,iam,line,rc) @@ -214,7 +214,7 @@ end function MAPL_ASRTT logical function MAPL_RTRNt(A,text,iam,line,rc) integer, intent(IN ) :: A - character*(*), intent(IN ) :: text,iam + character(len=*), intent(IN ) :: text,iam integer, intent(IN ) :: line integer, optional, intent(OUT) :: RC @@ -231,7 +231,7 @@ end function MAPL_RTRNT logical function MAPL_VRFYt(A,text,iam,line,rc) integer, intent(IN ) :: A - character*(*), intent(IN ) :: iam,text + character(len=*), intent(IN ) :: iam,text integer, intent(IN ) :: line integer, optional, intent(OUT) :: RC MAPL_VRFYt = MAPL_VRFY(A,iam,line,rc) diff --git a/shared/MAPL_ISO8601_DateTime.F90 b/shared/MAPL_ISO8601_DateTime.F90 index 58816b391042..c5e99d521574 100644 --- a/shared/MAPL_ISO8601_DateTime.F90 +++ b/shared/MAPL_ISO8601_DateTime.F90 @@ -339,7 +339,7 @@ pure function undelimit(string, delimiter) result(undelimited) character(len=len(string)) :: undelimited integer :: i integer :: j - + undelimited = '' j = 0 do i=1,len(string) @@ -564,7 +564,7 @@ pure function parse_time(timestring) result(fields) integer, parameter :: MSTOP = 4 integer, parameter :: SSTART = 5 integer, parameter :: SSTOP = 6 - integer, parameter :: MS_START = 7 + integer, parameter :: MS_START = 7 integer, parameter :: MS_STOP = 9 logical :: has_millisecond integer :: pos @@ -586,7 +586,7 @@ pure function parse_time(timestring) result(fields) fields%is_valid_ = .FALSE. return end if - + ! Find timezone portion pos = scan(timestring, '-Z+') @@ -642,7 +642,7 @@ pure function parse_time(timestring) result(fields) if(.not. fields%is_valid_) return - ! Read time fields + ! Read time fields fields%hour_ = read_whole_number(undelimited(HSTART:HSTOP)) fields%minute_ = read_whole_number(undelimited(MSTART:MSTOP)) fields%second_ = read_whole_number(undelimited(SSTART:SSTOP)) @@ -665,7 +665,6 @@ function construct_ISO8601Date(isostring, rc) result(date) integer, intent(out) :: rc type(ISO8601Date) :: date type(date_fields) :: fields - integer :: status fields = parse_date(trim(adjustl(isostring))) if(fields%is_valid_) then date%year_ = fields%year_ @@ -681,7 +680,6 @@ function construct_ISO8601Time(isostring, rc) result(time) integer, intent(inout) :: rc type(ISO8601Time) :: time type(time_fields) :: fields - integer :: status fields = parse_time(trim(adjustl(isostring))) if(fields%is_valid_) then time%hour_ = fields%hour_ @@ -735,15 +733,15 @@ function construct_ISO8601Duration(isostring, imin, imax, rc) result(duration) ! Check indices and first character is 'P' successful = ((imin > 0) .and. (imax <= len(isostring)) .and. & - (imin <= imax) .and. (isostring(imin:imin) == 'P')) + (imin <= imax) .and. (isostring(imin:imin) == 'P')) pos = imin + 1 ! This do loop reads a character at a time, digit and nondigit. ! A field string consists of digits forming an integer n followed by - ! a field character. A field character must be preceded by an integer. + ! a field character. A field character must be preceded by an integer. ! A field character indicates that the preceding digit characters - ! should be processed as values for the corresponding field. + ! should be processed as values for the corresponding field. ! The field characters are: ! Y(ear) ! M(onth) @@ -760,12 +758,12 @@ function construct_ISO8601Duration(isostring, imin, imax, rc) result(duration) c = isostring(pos:pos) if(time_found) then ! Once the time is found, M should be processed as M(inute). - select case(c) + select case(c) case('H') ! Verify the field or preceding fields have not been set. ! Then process the preceding digit character as an integer. ! Once processed reset the istart index to start processing - ! digits. The same logic applies for each case below. + ! digits. The same logic applies for each case below. if(hours >= 0 .or. minutes >= 0 .or. & seconds >= 0 .or. istart < 1) cycle hours = read_whole_number_indexed(isostring, istart, istop) @@ -801,7 +799,7 @@ function construct_ISO8601Duration(isostring, imin, imax, rc) result(duration) if(years >= 0 .or. months >= 0 .or. & days >= 0 .or. istart < 1) cycle years = read_whole_number_indexed(isostring, istart, istop) - if(years < 0) cycle + if(years < 0) cycle istart = 0 case('M') if(months >= 0 .or. days >= 0 .or. istart < 1) cycle diff --git a/shared/MAPL_LoadBalance.F90 b/shared/MAPL_LoadBalance.F90 index 1f7cec1ebc6d..b38fd791b427 100644 --- a/shared/MAPL_LoadBalance.F90 +++ b/shared/MAPL_LoadBalance.F90 @@ -39,7 +39,7 @@ module MAPL_LoadBalanceMod integer, parameter :: MAX_NUM_STRATEGIES=1000 type(TBalanceStrategy), save :: THE_STRATEGIES(0:MAX_NUM_STRATEGIES) - character*30 :: Iam="MAPL_LoadBalanceMod in line " + character(len=30) :: Iam="MAPL_LoadBalanceMod in line " !--------------------------------------------------------------------------- !> @@ -96,8 +96,8 @@ module MAPL_LoadBalanceMod ! Work (Results) is distributed (retrieved) using the buffer A, which is assumed ! to consist of Jdim contiguous blocks of size Idim. Of course, Jdim can be 1. ! The blocksize of A (Idim) must be at least as large as the BufLen associated -! with the strategy. This size can be obtained by quering the strategy using -! its handle or be saving it from the MAPL_BalanceCreate call. Again, see +! with the strategy. This size can be obtained by quering the strategy using +! its handle or be saving it from the MAPL_BalanceCreate call. Again, see ! MAPL_BalanceCreate for details. subroutine MAPL_BalanceWork4(A, Idim, Direction, Handle, rc) @@ -122,7 +122,7 @@ subroutine MAPL_BalanceWork4(A, Idim, Direction, Handle, rc) if(THE_STRATEGIES(ISTRAT)%PASSES>0) then ! We have a defined strategy _ASSERT(associated(THE_STRATEGIES(ISTRAT)%NOP),'needs informative message') -! Initialize CURSOR, which is the location in the first block of A where +! Initialize CURSOR, which is the location in the first block of A where ! the next read or write is to occur. K1 and K2 are the limits if (Direction==MAPL_Distribute) then @@ -200,8 +200,8 @@ end subroutine MAPL_BalanceWork4 ! Work (Results) is distributed (retrieved) using the buffer A, which is assumed ! to consist of Jdim contiguous blocks of size Idim. Of course, Jdim can be 1. ! The blocksize of A (Idim) must be at least as large as the BufLen associated -! with the strategy. This size can be obtained by quering the strategy using -! its handle or be saving it from the MAPL_BalanceCreate call. Again, see +! with the strategy. This size can be obtained by quering the strategy using +! its handle or be saving it from the MAPL_BalanceCreate call. Again, see ! MAPL_BalanceCreate for details. subroutine MAPL_BalanceWork8(A, Idim, Direction, Handle, rc) @@ -226,7 +226,7 @@ subroutine MAPL_BalanceWork8(A, Idim, Direction, Handle, rc) if(THE_STRATEGIES(ISTRAT)%PASSES>0) then ! We have a defined strategy _ASSERT(associated(THE_STRATEGIES(ISTRAT)%NOP),'needs informative message') -! Initialize CURSOR, which is the location in the first block of A where +! Initialize CURSOR, which is the location in the first block of A where ! the next read or write is to occur. K1 and K2 are the limits if (Direction==MAPL_Distribute) then @@ -324,7 +324,7 @@ subroutine MAPL_BalanceCreate(OrgLen, Comm, MaxPasses, BalCond, & integer :: KPASS, STATUS, Balance, MyNewWork, MyBufSize integer :: NPES, MyPE, J - integer, allocatable :: WORK(:), RANK(:), NOP(:,:) + integer, allocatable :: WORK(:), RANK(:), NOP(:,:) ! Defaults of optional Inputs !---------------------------- @@ -386,7 +386,7 @@ subroutine MAPL_BalanceCreate(OrgLen, Comm, MaxPasses, BalCond, & if(present(BalLen)) BalLen = MyNewWork if(present(BufLen)) BufLen = MyBufSize - + ! Save the Strategy !------------------ @@ -410,7 +410,7 @@ subroutine CreateStrategy(Work, Rank, MyPE, BalCond, KPASS, MyNewWork, MyBufSize integer, intent(IN ) :: MyPE real , intent(IN ) :: BalCond integer, intent( OUT) :: NOP(:,:), KPASS, MyNewWork, MyBufSize - + integer :: NPES, J, JSPARD, LEN, MaxPasses real :: MEAN @@ -421,7 +421,7 @@ subroutine CreateStrategy(Work, Rank, MyPE, BalCond, KPASS, MyNewWork, MyBufSize !------------------------------------------------------------------- KPASS = 0 - MEAN = sum(Work)/float(NPES) + MEAN = sum(Work)/real(NPES) MyNewWork = OrgLen MyBufSize = OrgLen @@ -488,7 +488,7 @@ subroutine MAPL_BalanceDestroy(Handle, rc) integer :: Handle_ - if (present(Handle)) then + if (present(Handle)) then _ASSERT(Handle>=0, 'Handle is less than 0') _ASSERT(Handle<=MAX_NUM_STRATEGIES,'Handle is greater than MAX_NUM_STRATEGIES') Handle_ = Handle @@ -519,9 +519,9 @@ subroutine MAPL_BalanceGet(Handle, BalLen, BufLen, Passes, Comm, rc) integer, optional, intent(OUT) :: BalLen, BufLen, Passes, Comm integer, optional, intent(OUT) :: rc - _ASSERT(Handle>=0, 'Handle is less than 0') + _ASSERT(Handle>=0, 'Handle is less than 0') _ASSERT(Handle<=MAX_NUM_STRATEGIES,'Handle is greater than MAX_NUM_STATEGIES') - + _ASSERT(associated(THE_STRATEGIES(Handle)%NOP),'needs informative message') if(present(BalLen)) & diff --git a/shared/Shmem/Shmem.F90 b/shared/Shmem/Shmem.F90 index 5b0e6104573c..4c2fea2c63ad 100644 --- a/shared/Shmem/Shmem.F90 +++ b/shared/Shmem/Shmem.F90 @@ -29,7 +29,7 @@ module MAPL_Shmem public :: MAPL_GetNewRank - character*30 :: Iam="MAPL_ShmemMod in line " + character(len=30) :: Iam="MAPL_ShmemMod in line " integer(c_int), parameter :: IPC_CREAT = 512 integer(c_int), parameter :: IPC_RMID = 0 From 1fc15310ad3d53f1cbfdad4cec806076333973e2 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 31 Aug 2023 16:26:28 -0400 Subject: [PATCH 03/13] Add to changelog --- CHANGELOG.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 54f13d2dbb7b..5b44bd7cb54a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,13 +14,19 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Trajectory sampler with Epoch time span - Added utility to convert binary files used by MAPL\_ReadForcing to NetCDF - Allow a negative "update\_offset" keyword in the sampling section of ExtData2G's input file by prepending the ISO time duration with a negative sign. I.E -PT12H for example +- Added three new macros + - `_HERE`: Returns the current file and line number + - `_RETURN_IF(cond)`: Returns if the condition is true + - `_RETURN_UNLESS(cond)`: Returns if the condition is false ### Changed - Modified tilegrid creation to use index flag ESMF_INDEX_DELOCAL instead of ESMF_INDEX_USER - Renamed "geom" subdir and library to "field_utils" - Updated CircleCI to use v11.2.0 bcs -- Converted all uses of `mpif.h` to `use mpi` +- Cleanup Fortran + - Converted all uses of `mpif.h` to `use mpi` + - Converted all uses of `character*` to `character(len=)` ### Fixed From 83ba83320385dda3debd9b899919e65fcd3cd4da Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 31 Aug 2023 16:32:55 -0400 Subject: [PATCH 04/13] Have to include unused_dummy --- profiler/AbstractMeter.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/profiler/AbstractMeter.F90 b/profiler/AbstractMeter.F90 index 4c34b1a19980..7c91982c1b62 100644 --- a/profiler/AbstractMeter.F90 +++ b/profiler/AbstractMeter.F90 @@ -1,3 +1,4 @@ +#include "unused_dummy.H" module MAPL_AbstractMeter use, intrinsic :: iso_fortran_env, only: REAL64 implicit none From 1eb53b2249fe6f73c874a3eee6956fb47bde439d Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 1 Sep 2023 14:29:32 -0400 Subject: [PATCH 05/13] Cleaning code to reduce warning messages. --- shared/CMakeLists.txt | 1 - shared/Constants/PhysicalConstants.F90 | 96 ++++---- shared/MAPL_HeapMod.F90 | 295 ------------------------- shared/MaplShared.F90 | 1 - shared/Shmem/Shmem.F90 | 6 +- shared/Shmem/Shmem_implementation.F90 | 7 +- shared/hinterp.F | 3 - 7 files changed, 53 insertions(+), 356 deletions(-) delete mode 100644 shared/MAPL_HeapMod.F90 diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index 46389b996a12..12b41561bb01 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -6,7 +6,6 @@ set (srcs MAPL_DirPath.F90 MAPL_ErrorHandling.F90 MAPL_Hash.F90 - MAPL_HeapMod.F90 MAPL_KeywordEnforcer.F90 MAPL_LoadBalance.F90 MAPL_MinMax.F90 diff --git a/shared/Constants/PhysicalConstants.F90 b/shared/Constants/PhysicalConstants.F90 index f575204d212a..e1579707bb2b 100644 --- a/shared/Constants/PhysicalConstants.F90 +++ b/shared/Constants/PhysicalConstants.F90 @@ -13,67 +13,67 @@ module MAPL_PhysicalConstantsMod ! Universal Constants #if defined(CODATA_2018_CONSTANTS) - real, parameter :: MAPL_STFBOL = 5.670374419E-8 ! W/(m^2 K^4) - real, parameter :: MAPL_AVOGAD = 6.02214076E26 ! 1/kmol - real, parameter :: MAPL_RUNIV = 8314.462618 ! J/(Kmole K) + real, parameter :: MAPL_STFBOL = 5.670374419E-8 ! W/(m^2 K^4) + real, parameter :: MAPL_AVOGAD = 6.02214076E26 ! 1/kmol + real, parameter :: MAPL_RUNIV = 8314.462618 ! J/(Kmole K) #else - real, parameter :: MAPL_STFBOL = 5.6734E-8 ! W/(m^2 K^4) - real, parameter :: MAPL_AVOGAD = 6.023E26 ! 1/kmol - real, parameter :: MAPL_RUNIV = 8314.47 ! J/(Kmole K) + real, parameter :: MAPL_STFBOL = 5.6734E-8 ! W/(m^2 K^4) + real, parameter :: MAPL_AVOGAD = 6.023E26 ! 1/kmol + real, parameter :: MAPL_RUNIV = 8314.47 ! J/(Kmole K) #endif ! Earth Constants - real(kind=REAL64), parameter :: MAPL_PSDRY = 98305.0_REAL64 ! Pa - real, parameter :: MAPL_SECONDS_PER_SIDEREAL_DAY = 86164.0 ! s - real, parameter :: MAPL_GRAV = 9.80665 ! m^2/s - real, parameter :: MAPL_RADIUS = 6371.0E3 ! m + real(kind=REAL64), parameter :: MAPL_PSDRY = 98305.0_REAL64 ! Pa + real, parameter :: MAPL_SECONDS_PER_SIDEREAL_DAY = 86164.0 ! s + real, parameter :: MAPL_GRAV = 9.80665 ! m^2/s + real, parameter :: MAPL_RADIUS = 6371.0E3 ! m real(kind=REAL64), parameter :: MAPL_OMEGA_R8 = 2.0_REAL64*MAPL_PI_R8/MAPL_SECONDS_PER_SIDEREAL_DAY ! 1/s real(kind=REAL32), parameter :: MAPL_OMEGA = 2.0*MAPL_PI/MAPL_SECONDS_PER_SIDEREAL_DAY ! 1/s real(kind=REAL64), parameter :: MAPL_EARTH_ECCENTRICITY = 8.181919084262200d-2 ! -- real(kind=REAL64), parameter :: MAPL_EARTH_SEMIMAJOR_AXIS = 6378137.0_REAL64 ! m - real(kind=REAL64), parameter :: MAPL_KM_PER_DEG = (1.0_REAL64/(MAPL_RADIUS/1000.0_REAL64)) * MAPL_RADIANS_TO_DEGREES - real(kind=REAL64), parameter :: MAPL_DEG_PER_KM = (MAPL_RADIUS/1000.0_REAL64) * MAPL_DEGREES_TO_RADIANS_R8 + real(kind=REAL64), parameter :: MAPL_KM_PER_DEG = (1.0_REAL64/(MAPL_RADIUS/1000.0_REAL64)) * MAPL_RADIANS_TO_DEGREES + real(kind=REAL64), parameter :: MAPL_DEG_PER_KM = (MAPL_RADIUS/1000.0_REAL64) * MAPL_DEGREES_TO_RADIANS_R8 ! Physical properties - real, parameter :: MAPL_H2OMW = 18.015 ! kg/Kmole - real, parameter :: MAPL_O3MW = 47.9982 ! kg/Kmole - real, parameter :: MAPL_LATENT_HEAT_VAPORIZATION = 2.4665E6 ! J/kg @15C @1atm - real, parameter :: MAPL_ALHL = MAPL_LATENT_HEAT_VAPORIZATION ! J/kg - real, parameter :: MAPL_LATENT_HEAT_FUSION = 3.3370E5 ! J/kg @1atm - real, parameter :: MAPL_ALHF = MAPL_LATENT_HEAT_FUSION ! J/kg - real, parameter :: MAPL_LATENT_HEAT_SUBLIMATION = MAPL_ALHL+MAPL_ALHF ! J/kg - real, parameter :: MAPL_ALHS = MAPL_LATENT_HEAT_SUBLIMATION ! J/kg + real, parameter :: MAPL_H2OMW = 18.015 ! kg/Kmole + real, parameter :: MAPL_O3MW = 47.9982 ! kg/Kmole + real, parameter :: MAPL_LATENT_HEAT_VAPORIZATION = 2.4665E6 ! J/kg @15C @1atm + real, parameter :: MAPL_ALHL = MAPL_LATENT_HEAT_VAPORIZATION ! J/kg + real, parameter :: MAPL_LATENT_HEAT_FUSION = 3.3370E5 ! J/kg @1atm + real, parameter :: MAPL_ALHF = MAPL_LATENT_HEAT_FUSION ! J/kg + real, parameter :: MAPL_LATENT_HEAT_SUBLIMATION = MAPL_ALHL+MAPL_ALHF ! J/kg + real, parameter :: MAPL_ALHS = MAPL_LATENT_HEAT_SUBLIMATION ! J/kg ! Earth Specific Chemistry and Thermodynamic Constants - real, parameter :: MAPL_AIRMW = 28.965 ! kg/Kmole - real, parameter :: MAPL_RDRY = MAPL_RUNIV/MAPL_AIRMW ! J/(kg K) - real, parameter :: MAPL_CPDRY = 3.5*MAPL_RDRY ! J/(kg K) - real, parameter :: MAPL_CVDRY = MAPL_CPDRY-MAPL_RDRY ! J/(kg K) - real, parameter :: MAPL_RVAP = MAPL_RUNIV/MAPL_H2OMW ! J/(kg K) - real, parameter :: MAPL_CPVAP = 4.*MAPL_RVAP ! J/(kg K) - real, parameter :: MAPL_CVVAP = MAPL_CPVAP-MAPL_RVAP ! J/(kg K) - real, parameter :: MAPL_KAPPA = MAPL_RDRY/MAPL_CPDRY ! (2.0/7.0) - real, parameter :: MAPL_EPSILON = MAPL_H2OMW/MAPL_AIRMW ! -- - real, parameter :: MAPL_DELTAP = MAPL_CPVAP/MAPL_CPDRY ! -- - real, parameter :: MAPL_DELTAV = MAPL_CVVAP/MAPL_CVDRY ! -- - real, parameter :: MAPL_GAMMAD = MAPL_CPDRY/MAPL_CVDRY ! -- - real, parameter :: MAPL_RGAS = MAPL_RDRY ! J/(kg K) (DEPRECATED) - real, parameter :: MAPL_CP = MAPL_RGAS/MAPL_KAPPA ! J/(kg K) (DEPRECATED) - real, parameter :: MAPL_VIREPS = 1.0/MAPL_EPSILON-1.0 ! (DEPRECATED) - real, parameter :: MAPL_P00 = 100000.0 ! Pa - real, parameter :: MAPL_CAPICE = 2000. ! J/(K kg) - real, parameter :: MAPL_CAPWTR = 4218. ! J/(K kg) - real, parameter :: MAPL_RHOWTR = 1000. ! kg/m^3 - real, parameter :: MAPL_NUAIR = 1.533E-5 ! m^2/S (@ 18C) - real, parameter :: MAPL_TICE = 273.16 ! K - real, parameter :: MAPL_SRFPRS = 98470 ! Pa - real, parameter :: MAPL_KARMAN = 0.40 ! -- - real, parameter :: MAPL_USMIN = 1.00 ! m/s - real, parameter :: MAPL_RHO_SEAWATER = 1026.0 ! sea water density [kg/m^3] - real, parameter :: MAPL_RHO_SEAICE = 917.0 ! sea ice density [kg/m^3] - real, parameter :: MAPL_RHO_SNOW = 330.0 ! snow density [kg/m^3] - real, parameter :: MAPL_CELSIUS_TO_KELVIN = 273.15 ! K + real, parameter :: MAPL_AIRMW = 28.965 ! kg/Kmole + real, parameter :: MAPL_RDRY = MAPL_RUNIV/MAPL_AIRMW ! J/(kg K) + real, parameter :: MAPL_CPDRY = 3.5*MAPL_RDRY ! J/(kg K) + real, parameter :: MAPL_CVDRY = MAPL_CPDRY-MAPL_RDRY ! J/(kg K) + real, parameter :: MAPL_RVAP = MAPL_RUNIV/MAPL_H2OMW ! J/(kg K) + real, parameter :: MAPL_CPVAP = 4.*MAPL_RVAP ! J/(kg K) + real, parameter :: MAPL_CVVAP = MAPL_CPVAP-MAPL_RVAP ! J/(kg K) + real, parameter :: MAPL_KAPPA = MAPL_RDRY/MAPL_CPDRY ! (2.0/7.0) + real, parameter :: MAPL_EPSILON = MAPL_H2OMW/MAPL_AIRMW ! -- + real, parameter :: MAPL_DELTAP = MAPL_CPVAP/MAPL_CPDRY ! -- + real, parameter :: MAPL_DELTAV = MAPL_CVVAP/MAPL_CVDRY ! -- + real, parameter :: MAPL_GAMMAD = MAPL_CPDRY/MAPL_CVDRY ! -- + real, parameter :: MAPL_RGAS = MAPL_RDRY ! J/(kg K) (DEPRECATED) + real, parameter :: MAPL_CP = MAPL_RGAS/MAPL_KAPPA ! J/(kg K) (DEPRECATED) + real, parameter :: MAPL_VIREPS = 1.0/MAPL_EPSILON-1.0 ! (DEPRECATED) + real, parameter :: MAPL_P00 = 100000.0 ! Pa + real, parameter :: MAPL_CAPICE = 2000. ! J/(K kg) + real, parameter :: MAPL_CAPWTR = 4218. ! J/(K kg) + real, parameter :: MAPL_RHOWTR = 1000. ! kg/m^3 + real, parameter :: MAPL_NUAIR = 1.533E-5 ! m^2/S (@ 18C) + real, parameter :: MAPL_TICE = 273.16 ! K + real, parameter :: MAPL_SRFPRS = 98470 ! Pa + real, parameter :: MAPL_KARMAN = 0.40 ! -- + real, parameter :: MAPL_USMIN = 1.00 ! m/s + real, parameter :: MAPL_RHO_SEAWATER = 1026.0 ! sea water density [kg/m^3] + real, parameter :: MAPL_RHO_SEAICE = 917.0 ! sea ice density [kg/m^3] + real, parameter :: MAPL_RHO_SNOW = 330.0 ! snow density [kg/m^3] + real, parameter :: MAPL_CELSIUS_TO_KELVIN = 273.15 ! K !EOP diff --git a/shared/MAPL_HeapMod.F90 b/shared/MAPL_HeapMod.F90 deleted file mode 100644 index ffab5917c1aa..000000000000 --- a/shared/MAPL_HeapMod.F90 +++ /dev/null @@ -1,295 +0,0 @@ - - -#include "MAPL_ErrLog.h" -#define ADDRS_POSITION 1 - -!BOP - -! !MODULE: MAPL_HeapMod -- A Module that implements a private heap - -! !INTERFACE: - - module MAPL_HeapMod - -! !USES: - - use MAPL_ErrorHandlingMod - use, intrinsic :: iso_fortran_env, only: INT64 - implicit none - private - -! !PUBLIC TYPES: - - - integer, parameter :: NumSegments=20 - integer, parameter :: DefaultSize=1000000 - - - type :: RealPtr1 - real, pointer :: a(:) - end type RealPtr1 - - - type :: MAPL_Heap - private - character(len=256) :: NAME="" - integer :: HP_start(NumSegments) = -1 - integer :: HP_end (NumSegments) = -1 - real, pointer :: BUFFER(:)=>null() - type(RealPtr1) :: PTRS(NumSegments) - end type MAPL_Heap - - type(MAPL_Heap), save :: HEAP - - -! !PUBLIC MEMBER FUNCTIONS: - - public MAPL_Alloc - public MAPL_DeAlloc - public MAPL_HeapSet - public MAPL_HeapGet - -!EOP - - interface MAPL_Alloc - module procedure MAPL_Alloc_R_2D - end interface - - interface MAPL_DeAlloc - module procedure MAPL_DeAlloc_R_2D - end interface - - contains - -!******************************************************** - - subroutine MAPL_HeapSet(HeapSize, RC) - integer, optional, intent(IN ) :: HeapSize - integer, optional, intent(OUT ) :: RC - - integer :: status - - _ASSERT(.not.associated(HEAP%BUFFER),'needs informative message') - - if(present(HeapSize)) then - _ASSERT(HeapSize > 0,'needs informative message') - allocate(HEAP%BUFFER(1:HeapSize), STAT=STATUS) - _VERIFY(STATUS) - end if - - _RETURN(_SUCCESS) - - end subroutine MAPL_HeapSet - -!******************************************************** - - subroutine MAPL_HeapGet(HeapSize, RC) - integer, optional, intent(OUT ) :: HeapSize - integer, optional, intent(OUT ) :: RC - - - if(present(HeapSize)) then - HeapSize = size(heap%buffer) - end if - - _RETURN(_SUCCESS) - - end subroutine MAPL_HeapGet - - -!******************************************************** - - - subroutine MAPL_Alloc_R_2D(A,IM, JM, RC) - - integer, intent(IN ) :: IM, JM - integer, optional, intent(OUT) :: RC - real, pointer :: A(:,:) - - integer :: gap, len, i, j - - integer :: status - - interface loadr2d - function loadr2d(P1,I1,I2) result(P2) - real :: P1 - real, pointer :: P2(:,:) - integer, intent(IN) :: I1, I2 - end function loadr2d - end interface - - if(.not.associated(heap%buffer)) then - call MAPL_HeapSet(HeapSize=DefaultSize,RC=status) - _VERIFY(STATUS) - end if - - len = im*jm - -! Look for space between or after used segments -!---------------------------------------------- - - do i=1,NumSegments-1 - if(heap%HP_start(i)<0) exit ! found the last segment - if(i==1 ) cycle ! first segment is taken - ! Beginning at the second segment, check if there is room - ! between the previous and current segments - gap = heap%HP_start(i)-heap%HP_end(i-1)-1 - if(gap >= len) exit - end do - - if(I>=NumSegments) then - print *, 'MAPL_Alloc: Out of Segments. Need: ', I - _FAIL('needs informative message') - end if - -! If we are filling a gap, move trailing segments down -!----------------------------------------------------- - - if(heap%HP_start(i)>0) then - j = NumSegments-2 - do while (j >= i) - heap%HP_start(j+1) = heap%HP_start(j) - heap%HP_end (j+1) = heap%HP_end (j) - j = j-1 - end do - end if - -! Record the start and end of the segment -!---------------------------------------- - - if(i == 1) then - heap%HP_start(i) = 1 - else - heap%HP_start(i) = heap%HP_end(i-1) + 1 - end if - - heap%HP_end(i) = heap%HP_start(i) + (len-1) - -! Pass that space back in the pointer -!------------------------------------ - - if(heap%HP_end(i) > size(heap%buffer)) then - print *, 'MAPL_Alloc: Out of Space. Need: ', len, & - ' Have: ', size(heap%buffer)-heap%HP_start(i)+1 - do i=1,NumSegments - print *, i, heap%HP_start(i), heap%HP_end(i) - end do - _FAIL('needs informative message') - end if - - heap%ptrs(i)%a => heap%buffer(heap%HP_start(i):heap%HP_end(i)) - - a => loadr2d(heap%buffer(heap%HP_start(i)),im,jm) - - - _RETURN(_SUCCESS) - end subroutine MAPL_Alloc_R_2D - - - - subroutine MAPL_DeAlloc_R_2D(A, RC) - real, pointer :: A(:,:) - integer, optional, intent(OUT) :: RC - - interface ival2 - integer(kind=INT64) function ival2(Ptr) - use, intrinsic :: iso_fortran_env, only: INT64 - real, pointer :: Ptr(:,:) - end function ival2 - end interface - - interface ival1 - integer(kind=INT64) function ival1(Ptr) - use, intrinsic :: iso_fortran_env, only: INT64 - real, pointer :: Ptr(:) - end function ival1 - end interface - - integer :: i - - -! Look for the pointer in the list of allocated segments -!------------------------------------------------------- - - i = 1 - do while ( ival2(a) /= ival1(heap%ptrs(i)%a) ) - i = i+1 - if(i==NumSegments) then - print *, 'MAPL_DeAlloc: Bad Pointer' - _FAIL('needs informative message') - end if - end do - -! I is the segment to be freed. If it is not the last one, -! move up all segments below it. -!--------------------------------------------------------- - - do while (heap%HP_start(i+1) /= -1) - heap%HP_start(i) = heap%HP_start(i+1) - heap%HP_end (i) = heap%HP_end (i+1) - i = i+1 - if(i==NumSegments-1) then - print *, 'MAPL_DeAlloc: Something wrong. Missed bottom mark' - _FAIL('needs informative message') - end if - end do - -! Mark bottom segment as free -!---------------------------- - - heap%HP_start(I) = -1 - heap%HP_end (I) = -1 - - _RETURN(_SUCCESS) - end subroutine MAPL_DeAlloc_R_2D - - - - end module MAPL_HeapMod - - - integer(kind=INT64) function ival1(i) - use, intrinsic :: iso_fortran_env, only: INT64 - implicit none - integer(kind=INT64), intent(IN) :: I(ADDRS_POSITION) - ival1 = i(ADDRS_POSITION) - end function ival1 - - integer(kind=INT64) function ival2(i) - use, intrinsic :: iso_fortran_env, only: INT64 - implicit none - integer(kind=INT64), intent(IN) :: I(ADDRS_POSITION) - ival2 = i(ADDRS_POSITION) - end function ival2 - - integer(kind=INT64) function ival3(i) - use, intrinsic :: iso_fortran_env, only: INT64 - implicit none - integer(kind=INT64), intent(IN) :: I(ADDRS_POSITION) - ival3 = i(ADDRS_POSITION) - end function ival3 - - - function loadr1d(a,i ) result(ptr2) - implicit none - integer, intent(IN) :: i - real, target, intent(IN) :: a(I) - real, pointer :: ptr2(:) - ptr2 => a - end function loadr1d - - function loadr2d(a,i,j) result(ptr2) - implicit none - integer, intent(IN) :: i,j - real, target, intent(IN) :: a(i,j) - real, pointer :: ptr2(:,:) - ptr2 => a - end function loadr2d - - function loadr3d(a,i,j,k) result(ptr2) - implicit none - integer, intent(IN) :: i,j,k - real, target, intent(IN) :: a(i,j,k) - real, pointer :: ptr2(:,:,:) - ptr2 => a - end function loadr3d diff --git a/shared/MaplShared.F90 b/shared/MaplShared.F90 index 859c3e5392c4..fedcb4a2c93b 100644 --- a/shared/MaplShared.F90 +++ b/shared/MaplShared.F90 @@ -13,7 +13,6 @@ module MaplShared use mapl_LoadBalanceMod use mapl_KeywordEnforcerMod use mapl_InterpMod - use mapl_HeapMod use mapl_HashMod use mapl_ErrorHandlingMod use mapl_DirPathMod diff --git a/shared/Shmem/Shmem.F90 b/shared/Shmem/Shmem.F90 index 4c2fea2c63ad..aeb4f6d631cd 100644 --- a/shared/Shmem/Shmem.F90 +++ b/shared/Shmem/Shmem.F90 @@ -180,7 +180,7 @@ module subroutine MAPL_FinalizeShmem(rc) end subroutine MAPL_FinalizeShmem module subroutine MAPL_DeAllocNodeArray_1DL4(Ptr,rc) - logical, pointer :: Ptr(:) + logical, pointer :: Ptr(:) integer, optional, intent(OUT) :: rc end subroutine MAPL_DeAllocNodeArray_1DL4 @@ -259,7 +259,7 @@ module subroutine MAPL_DeAllocNodeArray_6DR8(Ptr,rc) end subroutine MAPL_DeAllocNodeArray_6DR8 module subroutine MAPL_AllocNodeArray_1DL4(Ptr, Shp, lbd, rc) - logical, pointer, intent(INOUT) :: Ptr(:) + logical(kind=C_Bool), pointer, intent(INOUT) :: Ptr(:) integer, intent(IN ) :: Shp(1) integer, optional, intent(IN ) :: lbd(1) integer, optional, intent( OUT) :: rc @@ -368,7 +368,7 @@ module subroutine MAPL_AllocNodeArray_6DR8(Ptr, Shp, lbd, rc) end subroutine MAPL_AllocNodeArray_6DR8 module subroutine MAPL_AllocateShared_1DL4(Ptr, Shp, lbd, TransRoot, rc) - logical, pointer, intent(INOUT) :: Ptr(:) + logical(kind=C_BOOL), pointer, intent(INOUT) :: Ptr(:) integer, intent(IN ) :: Shp(1) integer, optional, intent(IN ) :: lbd(1) logical, intent(IN ) :: TransRoot diff --git a/shared/Shmem/Shmem_implementation.F90 b/shared/Shmem/Shmem_implementation.F90 index 33b45db32218..31021663f597 100644 --- a/shared/Shmem/Shmem_implementation.F90 +++ b/shared/Shmem/Shmem_implementation.F90 @@ -586,7 +586,6 @@ _VERIFY(STATUS) call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr -! _ASSERT(size(Ptr)==len,'needs informative message') ! Thomas Clune suggested that this ASSERT is unnecessary. if(present(lbd)) Ptr(lbd(1):) => Ptr @@ -709,7 +708,6 @@ module procedure MAPL_AllocateShared_1DL4 - integer :: status if(MAPL_ShmInitialized) then @@ -882,7 +880,6 @@ end procedure ReleaseSharedMemory - module procedure GetSharedMemory integer :: status, pos @@ -890,8 +887,8 @@ integer(c_size_t) :: numBytes integer, parameter :: WORD_SIZE = 4 integer(c_int), parameter :: C_ZERO = 0 - integer(c_int), parameter :: myflg = o'666' - integer(c_int), parameter :: shmflg = ior(IPC_CREAT,myflg) + integer(c_int), parameter :: myflg = int(o'666') + integer(c_int), parameter :: shmflg = int(ior(IPC_CREAT,myflg)) integer(c_key_t), parameter :: keypre = 456000000 !!! Get an empty spot in the list of allocated segments diff --git a/shared/hinterp.F b/shared/hinterp.F index dd34b12fd36f..0ec8eadb1fea 100644 --- a/shared/hinterp.F +++ b/shared/hinterp.F @@ -261,7 +261,6 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, real pi,d real lam,lam_ip1,lam_ip0,lam_im1,lam_im2 real phi,phi_jp1,phi_jp0,phi_jm1,phi_jm2 - real dl,dp real lam_cmp real phi_cmp real undef @@ -271,8 +270,6 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, c Initialization c -------------- pi = 4.*atan(1.) - dl = 2*pi/ im ! Uniform Grid Delta Lambda - dp = pi/(jm-1) ! Uniform Grid Delta Phi c Allocate Memory for Weights and Index Locations c ----------------------------------------------- From f633d688e0c3f6647e0457dca63d8274edd1a68c Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 1 Sep 2023 14:46:29 -0400 Subject: [PATCH 06/13] Eliminating compiler warning messages. --- CHANGELOG.md | 3 + shared/CMakeLists.txt | 2 +- shared/Interp/Interp.F90 | 1 - shared/MAPL_LoadBalance.F90 | 2 - shared/Shmem/Shmem.F90 | 5 - shared/Shmem/Shmem_implementation.F90 | 7 + shared/{hinterp.F => hinterp.F90} | 338 +++++++++++++------------- 7 files changed, 180 insertions(+), 178 deletions(-) rename shared/{hinterp.F => hinterp.F90} (58%) diff --git a/CHANGELOG.md b/CHANGELOG.md index 09952d6f2c7a..669e4e83569d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -21,6 +21,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Converted hinterp.F to free format (hinterp.F90) - Modified tilegrid creation to use index flag ESMF_INDEX_DELOCAL instead of ESMF_INDEX_USER - Renamed "geom" subdir and library to "field_utils" - Updated CircleCI to use v11.2.0 bcs @@ -35,6 +36,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Removed +- Deleted MAPL_HeapMod.F90. This file was doing crazy nonstandard things and is not used anywhere else. A new cleaner implementation based upon containers could be readily created if the functionality is ever missed. + ### Deprecated ## [2.40.3] - 2023-08-03 diff --git a/shared/CMakeLists.txt b/shared/CMakeLists.txt index 12b41561bb01..637e0f615ea8 100644 --- a/shared/CMakeLists.txt +++ b/shared/CMakeLists.txt @@ -2,7 +2,7 @@ esma_set_this (OVERRIDE MAPL.shared) set (srcs hash.c - hinterp.F + hinterp.F90 MAPL_DirPath.F90 MAPL_ErrorHandling.F90 MAPL_Hash.F90 diff --git a/shared/Interp/Interp.F90 b/shared/Interp/Interp.F90 index 9ea0fe65c990..f6c2c0a28b67 100644 --- a/shared/Interp/Interp.F90 +++ b/shared/Interp/Interp.F90 @@ -1,6 +1,5 @@ module MAPL_InterpMod - use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none diff --git a/shared/MAPL_LoadBalance.F90 b/shared/MAPL_LoadBalance.F90 index b38fd791b427..642dcd3a14a9 100644 --- a/shared/MAPL_LoadBalance.F90 +++ b/shared/MAPL_LoadBalance.F90 @@ -39,8 +39,6 @@ module MAPL_LoadBalanceMod integer, parameter :: MAX_NUM_STRATEGIES=1000 type(TBalanceStrategy), save :: THE_STRATEGIES(0:MAX_NUM_STRATEGIES) - character(len=30) :: Iam="MAPL_LoadBalanceMod in line " - !--------------------------------------------------------------------------- !> !### EXAMPLE diff --git a/shared/Shmem/Shmem.F90 b/shared/Shmem/Shmem.F90 index aeb4f6d631cd..dbb851dc9afe 100644 --- a/shared/Shmem/Shmem.F90 +++ b/shared/Shmem/Shmem.F90 @@ -98,11 +98,6 @@ module function shmctl(shmid, cmd, buf) bind(c, name="shmctl") type (c_ptr), value :: buf end function shmctl - subroutine perror(s) bind(c,name="perror") - use, intrinsic :: ISO_C_BINDING - character(c_char), intent(in) :: s(*) - end subroutine perror - end interface interface MAPL_AllocNodeArray diff --git a/shared/Shmem/Shmem_implementation.F90 b/shared/Shmem/Shmem_implementation.F90 index 31021663f597..0e3f8b1550de 100644 --- a/shared/Shmem/Shmem_implementation.F90 +++ b/shared/Shmem/Shmem_implementation.F90 @@ -8,6 +8,13 @@ use MAPL_Constants implicit none + interface + subroutine perror(s) bind(c,name="perror") + use, intrinsic :: ISO_C_BINDING + character(c_char), intent(in) :: s(*) + end subroutine perror + end interface + contains module procedure MAPL_GetNodeInfo diff --git a/shared/hinterp.F b/shared/hinterp.F90 similarity index 58% rename from shared/hinterp.F rename to shared/hinterp.F90 index 0ec8eadb1fea..cb04672b3eba 100644 --- a/shared/hinterp.F +++ b/shared/hinterp.F90 @@ -19,13 +19,13 @@ subroutine hinterp2 ( qin,iin,jin,qout,iout,jout,mlev,undef ) dlout = 2*pi/ iout dpout = pi/(jout-1) -c Compute Input DLAM & DPHI -c ------------------------- +! Compute Input DLAM & DPHI +! ------------------------- dlam_in(:) = dlin dphi_in(:) = dpin -c Compute Output Lons & Lats -c -------------------------- +! Compute Output Lons & Lats +! -------------------------- lons(1) = -pi do i=2,iout lons(i) = lons(i-1) + dlout @@ -52,16 +52,16 @@ subroutine hinterp2 ( qin,iin,jin,qout,iout,jout,mlev,undef ) enddo enddo - call interp_hh ( qin,iin,jin,mlev,dlam_in,dphi_in, - . qout,iout*jout,lons_out,lats_out,undef, -pi ) + call interp_hh ( qin,iin,jin,mlev,dlam_in,dphi_in, & + qout,iout*jout,lons_out,lats_out,undef, -pi ) return end !....................................................................................................... - subroutine hhinterp ( qin,iin,jin,qout,iout,jout,mlev,undef, - . lons_in,lats_in ) + subroutine hhinterp ( qin,iin,jin,qout,iout,jout,mlev,undef, & + lons_in,lats_in ) implicit none integer iin,jin, iout,jout, mlev real qin(iin,jin,mlev), qout(iout,jout,mlev) @@ -114,8 +114,8 @@ subroutine hhinterp ( qin,iin,jin,qout,iout,jout,mlev,undef, return end if -c Compute Output Lons & Lats consistent with DLAM and DPHI -c -------------------------------------------------------- +! Compute Output Lons & Lats consistent with DLAM and DPHI +! -------------------------------------------------------- lons_out(1) = -pi do i=2,iout lons_out(i) = lons_out(i-1) + dlout @@ -142,8 +142,8 @@ subroutine hhinterp ( qin,iin,jin,qout,iout,jout,mlev,undef, enddo enddo - call interp_hh ( qin,iin,jin,mlev,dlam,dphi, - . qout,iout*jout,lons,lats,undef, lon_min ) + call interp_hh ( qin,iin,jin,mlev,dlam,dphi, & + qout,iout*jout,lons,lats,undef, lon_min ) ! Return input to original form ! ----------------------------- @@ -173,40 +173,40 @@ subroutine myhflip2_ ( q,im,jm ) end subroutine myhflip2_ end - subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, - . q_geo,irun,lon_geo,lat_geo, undef, lon_min) -C*********************************************************************** -C -C PURPOSE: -C ======== -C Performs a horizontal interpolation from a field on a computational grid -C to arbitrary locations. -C -C INPUT: -C ====== -C q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid -C im ......... Longitudinal dimension of q_cmp -C jm ......... Latitudinal dimension of q_cmp -C lm ......... Vertical dimension of q_cmp -C dlam ....... Computational Grid Delta Lambda -C dphi ....... Computational Grid Delta Phi -C irun ....... Number of Output Locations -C lon_geo .... Longitude Location of Output -C lat_geo .... Latitude Location of Output -C -C OUTPUT: -C ======= -C q_geo ...... Field q_geo(irun,lm) at arbitrary locations -C -C -C*********************************************************************** -C* GODDARD LABORATORY FOR ATMOSPHERES * -C*********************************************************************** + subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, & + q_geo,irun,lon_geo,lat_geo, undef, lon_min) +!*********************************************************************** +! +! PURPOSE: +! ======== +! Performs a horizontal interpolation from a field on a computational grid +! to arbitrary locations. +! +! INPUT: +! ====== +! q_cmp ...... Field q_cmp(im,jm,lm) on the computational grid +! im ......... Longitudinal dimension of q_cmp +! jm ......... Latitudinal dimension of q_cmp +! lm ......... Vertical dimension of q_cmp +! dlam ....... Computational Grid Delta Lambda +! dphi ....... Computational Grid Delta Phi +! irun ....... Number of Output Locations +! lon_geo .... Longitude Location of Output +! lat_geo .... Latitude Location of Output +! +! OUTPUT: +! ======= +! q_geo ...... Field q_geo(irun,lm) at arbitrary locations +! +! +!*********************************************************************** +!* GODDARD LABORATORY FOR ATMOSPHERES * +!*********************************************************************** implicit none -c Input Variables -c --------------- +! Input Variables +! --------------- integer im,jm,lm,irun real q_geo(irun,lm) @@ -219,21 +219,21 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, real :: lon_min -c Local Variables -c --------------- +! Local Variables +! --------------- integer i,j,l integer, allocatable :: ip1(:), ip0(:), im1(:), im2(:) integer, allocatable :: jp1(:), jp0(:), jm1(:), jm2(:) -c Bi-Linear Weights -c ----------------- +! Bi-Linear Weights +! ----------------- real, allocatable :: wl_ip0jp0 (:) real, allocatable :: wl_im1jp0 (:) real, allocatable :: wl_ip0jm1 (:) real, allocatable :: wl_im1jm1 (:) -c Bi-Cubic Weights -c ---------------- +! Bi-Cubic Weights +! ---------------- real, allocatable :: wc_ip1jp1 (:) real, allocatable :: wc_ip0jp1 (:) real, allocatable :: wc_im1jp1 (:) @@ -267,29 +267,29 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, integer im1_cmp,icmp integer jm1_cmp,jcmp -c Initialization -c -------------- +! Initialization +! -------------- pi = 4.*atan(1.) -c Allocate Memory for Weights and Index Locations -c ----------------------------------------------- +! Allocate Memory for Weights and Index Locations +! ----------------------------------------------- allocate ( wl_ip0jp0(irun) , wl_im1jp0(irun) ) allocate ( wl_ip0jm1(irun) , wl_im1jm1(irun) ) - allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , - . wc_im1jp1(irun) , wc_im2jp1(irun) ) - allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , - . wc_im1jp0(irun) , wc_im2jp0(irun) ) - allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , - . wc_im1jm1(irun) , wc_im2jm1(irun) ) - allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , - . wc_im1jm2(irun) , wc_im2jm2(irun) ) - allocate ( ip1(irun) , ip0(irun) , - . im1(irun) , im2(irun) ) - allocate ( jp1(irun) , jp0(irun) , - . jm1(irun) , jm2(irun) ) - -c Compute Input Computational-Grid Latitude and Longitude Locations -c ----------------------------------------------------------------- + allocate ( wc_ip1jp1(irun) , wc_ip0jp1(irun) , & + wc_im1jp1(irun) , wc_im2jp1(irun) ) + allocate ( wc_ip1jp0(irun) , wc_ip0jp0(irun) , & + wc_im1jp0(irun) , wc_im2jp0(irun) ) + allocate ( wc_ip1jm1(irun) , wc_ip0jm1(irun) , & + wc_im1jm1(irun) , wc_im2jm1(irun) ) + allocate ( wc_ip1jm2(irun) , wc_ip0jm2(irun) , & + wc_im1jm2(irun) , wc_im2jm2(irun) ) + allocate ( ip1(irun) , ip0(irun) , & + im1(irun) , im2(irun) ) + allocate ( jp1(irun) , jp0(irun) , & + jm1(irun) , jm2(irun) ) + +! Compute Input Computational-Grid Latitude and Longitude Locations +! ----------------------------------------------------------------- lon_cmp(1) = lon_min ! user supplied orign do i=2,im lon_cmp(i) = lon_cmp(i-1) + dlam(i-1) @@ -300,14 +300,14 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, enddo lat_cmp(jm) = pi*0.5 -c Compute Weights for Computational to Geophysical Grid Interpolation -c ------------------------------------------------------------------- +! Compute Weights for Computational to Geophysical Grid Interpolation +! ------------------------------------------------------------------- do i=1,irun lam_cmp = lon_geo(i) phi_cmp = lat_geo(i) -c Determine Indexing Based on Computational Grid -c ---------------------------------------------- +! Determine Indexing Based on Computational Grid +! ---------------------------------------------- im1_cmp = 1 do icmp = 2,im if( lon_cmp(icmp).lt.lam_cmp ) im1_cmp = icmp @@ -327,8 +327,8 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, jp1(i) = jp0(i) + 1 jm2(i) = jm1(i) - 1 -c Fix Longitude Index Boundaries -c ------------------------------ +! Fix Longitude Index Boundaries +! ------------------------------ if(im1(i).eq.im) then ip0(i) = 1 ip1(i) = 2 @@ -341,13 +341,13 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, endif -c Compute Immediate Surrounding Coordinates -c ----------------------------------------- +! Compute Immediate Surrounding Coordinates +! ----------------------------------------- lam = lam_cmp phi = phi_cmp -c Compute and Adjust Longitude Weights -c ------------------------------------ +! Compute and Adjust Longitude Weights +! ------------------------------------ lam_im2 = lon_cmp(im2(i)) lam_im1 = lon_cmp(im1(i)) lam_ip0 = lon_cmp(ip0(i)) @@ -359,9 +359,9 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, if( lam_ip0.gt.lam_ip1 ) lam_ip1 = lam_ip1 + 2*pi -c Compute and Adjust Latitude Weights -c Note: Latitude Index Boundaries are Adjusted during Interpolation -c ------------------------------------------------------------------ +! Compute and Adjust Latitude Weights +! Note: Latitude Index Boundaries are Adjusted during Interpolation +! ------------------------------------------------------------------ phi_jm1 = lat_cmp(jm1(i)) if( jm2(i).eq.0 ) then @@ -383,33 +383,33 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, endif -c Bi-Linear Weights -c ----------------- +! Bi-Linear Weights +! ----------------- d = (lam_ip0-lam_im1)*(phi_jp0-phi_jm1) wl_im1jm1(i) = (lam_ip0-lam )*(phi_jp0-phi )/d wl_ip0jm1(i) = (lam -lam_im1)*(phi_jp0-phi )/d wl_im1jp0(i) = (lam_ip0-lam )*(phi -phi_jm1)/d wl_ip0jp0(i) = (lam -lam_im1)*(phi -phi_jm1)/d -c Bi-Cubic Weights -c ---------------- - ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) - ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) - . / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) - am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) - . / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) - am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) - . / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) - - bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) - bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) - bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) - . / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) - bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) - . / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) +! Bi-Cubic Weights +! ---------------- + ap1 = ( (lam -lam_ip0)*(lam -lam_im1)*(lam -lam_im2) ) & + / ( (lam_ip1-lam_ip0)*(lam_ip1-lam_im1)*(lam_ip1-lam_im2) ) + ap0 = ( (lam_ip1-lam )*(lam -lam_im1)*(lam -lam_im2) ) & + / ( (lam_ip1-lam_ip0)*(lam_ip0-lam_im1)*(lam_ip0-lam_im2) ) + am1 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam -lam_im2) ) & + / ( (lam_ip1-lam_im1)*(lam_ip0-lam_im1)*(lam_im1-lam_im2) ) + am2 = ( (lam_ip1-lam )*(lam_ip0-lam )*(lam_im1-lam ) ) & + / ( (lam_ip1-lam_im2)*(lam_ip0-lam_im2)*(lam_im1-lam_im2) ) + + bp1 = ( (phi -phi_jp0)*(phi -phi_jm1)*(phi -phi_jm2) ) & + / ( (phi_jp1-phi_jp0)*(phi_jp1-phi_jm1)*(phi_jp1-phi_jm2) ) + bp0 = ( (phi_jp1-phi )*(phi -phi_jm1)*(phi -phi_jm2) ) & + / ( (phi_jp1-phi_jp0)*(phi_jp0-phi_jm1)*(phi_jp0-phi_jm2) ) + bm1 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi -phi_jm2) ) & + / ( (phi_jp1-phi_jm1)*(phi_jp0-phi_jm1)*(phi_jm1-phi_jm2) ) + bm2 = ( (phi_jp1-phi )*(phi_jp0-phi )*(phi_jm1-phi ) ) & + / ( (phi_jp1-phi_jm2)*(phi_jp0-phi_jm2)*(phi_jm1-phi_jm2) ) wc_ip1jp1(i) = bp1*ap1 wc_ip0jp1(i) = bp1*ap0 @@ -433,25 +433,25 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, enddo -c Interpolate Computational-Grid Quantities to Geophysical Grid -c ------------------------------------------------------------- +! Interpolate Computational-Grid Quantities to Geophysical Grid +! ------------------------------------------------------------- do L=1,lm do i=1,irun - if( lat_geo(i).le.lat_cmp(2) .or. - . lat_geo(i).ge.lat_cmp(jm-1) ) then + if( lat_geo(i).le.lat_cmp(2) .or. & + lat_geo(i).ge.lat_cmp(jm-1) ) then -c 1st Order Interpolation at Poles -c -------------------------------- - if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then +! 1st Order Interpolation at Poles +! -------------------------------- + if( q_cmp( im1(i),jm1(i),L ).ne.undef .and. & + q_cmp( ip0(i),jm1(i),L ).ne.undef .and. & + q_cmp( im1(i),jp0(i),L ).ne.undef .and. & + q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) + q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) & + + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) & + + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) & + + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) else q_tmp(i) = undef @@ -459,57 +459,57 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, else -c Cubic Interpolation away from Poles -c ----------------------------------- - if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( im2(i),jp0(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( im2(i),jm1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jp1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp1(i),L ).ne.undef .and. - . q_cmp( im2(i),jp1(i),L ).ne.undef .and. - - . q_cmp( ip1(i),jm2(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm2(i),L ).ne.undef .and. - . q_cmp( im1(i),jm2(i),L ).ne.undef .and. - . q_cmp( im2(i),jm2(i),L ).ne.undef ) then - - q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) - . + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) - . + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) - . + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) - - . + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) - . + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) - . + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) - - . + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) - . + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) - - . + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) - . + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) - . + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) - . + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) - - elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. - . q_cmp( ip0(i),jm1(i),L ).ne.undef .and. - . q_cmp( im1(i),jp0(i),L ).ne.undef .and. - . q_cmp( ip0(i),jp0(i),L ).ne.undef ) then - - q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) - . + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) - . + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) - . + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) +! Cubic Interpolation away from Poles +! ----------------------------------- + if( q_cmp( ip1(i),jp0(i),L ).ne.undef .and. & + q_cmp( ip0(i),jp0(i),L ).ne.undef .and. & + q_cmp( im1(i),jp0(i),L ).ne.undef .and. & + q_cmp( im2(i),jp0(i),L ).ne.undef .and. & + + q_cmp( ip1(i),jm1(i),L ).ne.undef .and. & + q_cmp( ip0(i),jm1(i),L ).ne.undef .and. & + q_cmp( im1(i),jm1(i),L ).ne.undef .and. & + q_cmp( im2(i),jm1(i),L ).ne.undef .and. & + + q_cmp( ip1(i),jp1(i),L ).ne.undef .and. & + q_cmp( ip0(i),jp1(i),L ).ne.undef .and. & + q_cmp( im1(i),jp1(i),L ).ne.undef .and. & + q_cmp( im2(i),jp1(i),L ).ne.undef .and. & + + q_cmp( ip1(i),jm2(i),L ).ne.undef .and. & + q_cmp( ip0(i),jm2(i),L ).ne.undef .and. & + q_cmp( im1(i),jm2(i),L ).ne.undef .and. & + q_cmp( im2(i),jm2(i),L ).ne.undef ) then + + q_tmp(i) = wc_ip1jp1(i) * q_cmp( ip1(i),jp1(i),L ) & + + wc_ip0jp1(i) * q_cmp( ip0(i),jp1(i),L ) & + + wc_im1jp1(i) * q_cmp( im1(i),jp1(i),L ) & + + wc_im2jp1(i) * q_cmp( im2(i),jp1(i),L ) & + + + wc_ip1jp0(i) * q_cmp( ip1(i),jp0(i),L ) & + + wc_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) & + + wc_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) & + + wc_im2jp0(i) * q_cmp( im2(i),jp0(i),L ) & + + + wc_ip1jm1(i) * q_cmp( ip1(i),jm1(i),L ) & + + wc_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) & + + wc_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) & + + wc_im2jm1(i) * q_cmp( im2(i),jm1(i),L ) & + + + wc_ip1jm2(i) * q_cmp( ip1(i),jm2(i),L ) & + + wc_ip0jm2(i) * q_cmp( ip0(i),jm2(i),L ) & + + wc_im1jm2(i) * q_cmp( im1(i),jm2(i),L ) & + + wc_im2jm2(i) * q_cmp( im2(i),jm2(i),L ) + + elseif( q_cmp( im1(i),jm1(i),L ).ne.undef .and. & + q_cmp( ip0(i),jm1(i),L ).ne.undef .and. & + q_cmp( im1(i),jp0(i),L ).ne.undef .and. & + q_cmp( ip0(i),jp0(i),L ).ne.undef ) then + + q_tmp(i) = wl_im1jm1(i) * q_cmp( im1(i),jm1(i),L ) & + + wl_ip0jm1(i) * q_cmp( ip0(i),jm1(i),L ) & + + wl_im1jp0(i) * q_cmp( im1(i),jp0(i),L ) & + + wl_ip0jp0(i) * q_cmp( ip0(i),jp0(i),L ) else q_tmp(i) = undef @@ -518,8 +518,8 @@ subroutine interp_hh ( q_cmp,im,jm,lm,dlam,dphi, endif enddo -c Load Temp array into Output array -c --------------------------------- +! Load Temp array into Output array +! --------------------------------- do i=1,irun q_geo(i,L) = q_tmp(i) enddo From ff71309e87837fc073f81c0ffe096ca33d80222d Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 1 Sep 2023 15:47:17 -0400 Subject: [PATCH 07/13] Further cleaning to sidestep warning messages. --- pfio/AbstractDataReference.F90 | 1 - pfio/AbstractServer.F90 | 7 ------ pfio/ArrayReference.F90 | 4 ---- pfio/BaseServer.F90 | 6 ++--- pfio/BaseThread.F90 | 1 - pfio/CMakeLists.txt | 7 ------ pfio/ClientManager.F90 | 9 +++++-- pfio/ClientThread.F90 | 3 --- pfio/FileMetadata.F90 | 13 ++++------ pfio/MpiMutex.F90 | 1 - pfio/MpiSocket.F90 | 3 --- pfio/MultiCommServer.F90 | 10 +++----- pfio/MultiGroupServer.F90 | 43 +++++++++++++--------------------- pfio/MultiLayerServer.F90 | 10 +------- pfio/NetCDF4_FileFormatter.F90 | 4 ---- pfio/RDMAReference.F90 | 2 +- pfio/ServerThread.F90 | 11 ++------- pfio/ShmemReference.F90 | 1 - pfio/SimpleSocket.F90 | 4 ---- pfio/Variable.F90 | 7 ++---- pfio/pFIO_Utilities.F90 | 4 ---- pfio/pfio_collective_demo.F90 | 11 +++++---- pfio/pfio_open_close.F90 | 1 - pfio/pfio_server_demo.F90 | 9 ++++--- 24 files changed, 48 insertions(+), 124 deletions(-) diff --git a/pfio/AbstractDataReference.F90 b/pfio/AbstractDataReference.F90 index 3af1bdf4afe1..8c4a06d89597 100644 --- a/pfio/AbstractDataReference.F90 +++ b/pfio/AbstractDataReference.F90 @@ -4,7 +4,6 @@ module pFIO_AbstractDataReferenceMod use, intrinsic :: iso_c_binding, only: c_ptr use, intrinsic :: iso_c_binding, only: C_NULL_PTR - use, intrinsic :: iso_c_binding, only: c_loc use, intrinsic :: iso_c_binding, only: c_f_pointer use, intrinsic :: iso_c_binding, only: c_associated use, intrinsic :: iso_fortran_env, only: INT32 diff --git a/pfio/AbstractServer.F90 b/pfio/AbstractServer.F90 index ae19fe902d3d..17957539ed61 100644 --- a/pfio/AbstractServer.F90 +++ b/pfio/AbstractServer.F90 @@ -2,16 +2,9 @@ #include "unused_dummy.H" module pFIO_AbstractServerMod - use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: C_NULL_PTR - use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 - use, intrinsic :: iso_c_binding, only: c_f_pointer - use, intrinsic :: iso_fortran_env, only: OUTPUT_UNIT use MAPL_Profiler use MAPL_ExceptionHandling use pFIO_ConstantsMod - use pFIO_UtilitiesMod, only: word_size, i_to_string use pFIO_AbstractDataReferenceMod use pFIO_AbstractDataReferenceVectorMod use pFIO_ShmemReferenceMod diff --git a/pfio/ArrayReference.F90 b/pfio/ArrayReference.F90 index 6d986220c048..67a9635ea132 100644 --- a/pfio/ArrayReference.F90 +++ b/pfio/ArrayReference.F90 @@ -2,16 +2,12 @@ #include "unused_dummy.H" module pFIO_ArrayReferenceMod - use, intrinsic :: iso_c_binding, only: c_ptr use, intrinsic :: iso_c_binding, only: C_NULL_PTR use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_c_binding, only: c_f_pointer - use, intrinsic :: iso_c_binding, only: c_associated use, intrinsic :: iso_fortran_env, only: INT32 use, intrinsic :: iso_fortran_env, only: INT64 use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 - use pFIO_UtilitiesMod, only: word_size use MAPL_ExceptionHandling use pFIO_ConstantsMod use pFIO_AbstractDataReferenceMod diff --git a/pfio/BaseServer.F90 b/pfio/BaseServer.F90 index defd69d5ac4c..ced75e6517e5 100644 --- a/pfio/BaseServer.F90 +++ b/pfio/BaseServer.F90 @@ -3,9 +3,8 @@ module pFIO_BaseServerMod use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: C_NULL_PTR use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_fortran_env, only: REAL32, INT32, INT64, REAL64 + use, intrinsic :: iso_fortran_env, only: INT64 use, intrinsic :: iso_c_binding, only: c_f_pointer use MAPL_ExceptionHandling use pFIO_UtilitiesMod, only: word_size, i_to_string @@ -262,7 +261,7 @@ subroutine create_remote_win(this, rc) integer, optional, intent(out) :: rc class (AbstractDataReference), pointer :: remotePtr integer :: rank - integer(KIND=INT64) :: offset, msize_word + integer(KIND=INT64) :: msize_word integer(KIND=INT64),allocatable :: offsets(:), msize_words(:) type (MessageVectorIterator) :: iter type (StringInteger64MapIterator) :: request_iter @@ -299,7 +298,6 @@ subroutine create_remote_win(this, rc) !(2) loop to get the total size and offset of each collection and request allocate(offsets(collection_total), msize_words(collection_total)) offsets = 0 - offset = 0 iter = thread_ptr%request_backlog%begin() do while (iter /= thread_ptr%request_backlog%end()) msg => iter%get() diff --git a/pfio/BaseThread.F90 b/pfio/BaseThread.F90 index 472b266b1f08..d5eb16e9c987 100644 --- a/pfio/BaseThread.F90 +++ b/pfio/BaseThread.F90 @@ -8,7 +8,6 @@ module pFIO_BaseThreadMod use pFIO_IntegerRequestMapMod use pFIO_MessageVisitorMod use pfio_base - use, intrinsic :: iso_fortran_env, only: REAL32 use mpi implicit none diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index 313f8433c1bd..710718284280 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -119,13 +119,6 @@ endif () esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.profiler NetCDF::NetCDF_Fortran NetCDF::NetCDF_C TYPE ${MAPL_LIBRARY_TYPE}) -# We don't want to disable good NAG debugging flags everywhere, but we still need to do it for -# interfaces (e.g. MPI) that allow multiple types for the same argument (eg buffer). -if (DUSTY) - set_property( SOURCE DirectoryService.F90 MultiCommServer.F90 MultiGroupServer.F90 MultiLayerServer.F90 pfio_writer.F90 - PROPERTY COMPILE_FLAGS ${DUSTY}) -endif () - target_link_libraries (${this} PUBLIC GFTL::gftl-v2 GFTL_SHARED::gftl-shared-v2 PFLOGGER::pflogger PRIVATE MPI::MPI_Fortran) # CMake has an OpenMP issue with NAG Fortran: https://gitlab.kitware.com/cmake/cmake/-/issues/21280 if (NOT CMAKE_Fortran_COMPILER_ID MATCHES "NAG") diff --git a/pfio/ClientManager.F90 b/pfio/ClientManager.F90 index 48da5ebf706c..337e1de710f4 100644 --- a/pfio/ClientManager.F90 +++ b/pfio/ClientManager.F90 @@ -166,10 +166,11 @@ subroutine prefetch_data(this, collection_id, file_name, var_name, data_referenc integer :: request_id, status clientPtr => this%current() - request_id = clientPtr%prefetch_data(collection_id, file_name, var_name, data_reference, start=start, rc=status) - _VERIFY(status) + request_id = clientPtr%prefetch_data(collection_id, file_name, var_name, data_reference, start=start, _RC) + _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(request_id) end subroutine prefetch_data subroutine modify_metadata(this, collection_id, unusable,var_map, rc) @@ -266,6 +267,7 @@ subroutine collective_prefetch_data(this, collection_id, file_name, var_name, da _VERIFY(status) _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(request_id) end subroutine collective_prefetch_data subroutine stage_data(this, collection_id, file_name, var_name, data_reference, & @@ -287,6 +289,7 @@ subroutine stage_data(this, collection_id, file_name, var_name, data_reference, _VERIFY(status) _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(request_id) end subroutine stage_data subroutine collective_stage_data(this, collection_id, file_name, var_name, data_reference, & @@ -311,6 +314,7 @@ subroutine collective_stage_data(this, collection_id, file_name, var_name, data_ _VERIFY(status) _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(request_id) end subroutine collective_stage_data subroutine stage_nondistributed_data(this, collection_id, file_name, var_name, data_reference, unusable, rc) @@ -330,6 +334,7 @@ subroutine stage_nondistributed_data(this, collection_id, file_name, var_name, d _RETURN(_SUCCESS) _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(request_id) end subroutine stage_nondistributed_data subroutine shake_hand(this, unusable, rc) diff --git a/pfio/ClientThread.F90 b/pfio/ClientThread.F90 index b70a6c5b9e89..2f18bb407c07 100644 --- a/pfio/ClientThread.F90 +++ b/pfio/ClientThread.F90 @@ -33,7 +33,6 @@ module pFIO_ClientThreadMod use pFIO_ReplaceMetadataMessageMod use pFIO_StringVariableMapMod - use, intrinsic :: iso_fortran_env, only: REAL32 implicit none private @@ -139,7 +138,6 @@ function add_hist_collection(this, fmd, unusable, mode, rc) result(hist_collect class (AbstractMessage), pointer :: message class(AbstractSocket), pointer :: connection - integer :: status connection=>this%get_connection() call connection%send(AddHistCollectionMessage(fmd, mode=mode)) @@ -356,7 +354,6 @@ function stage_nondistributed_data(this, collection_id, file_name, var_name, dat class (AbstractMessage), pointer :: handshake_msg class(AbstractSocket),pointer :: connection - integer :: status request_id = this%get_unique_collective_request_id() connection => this%get_connection() diff --git a/pfio/FileMetadata.F90 b/pfio/FileMetadata.F90 index 066090840d5e..b973ad17d84a 100644 --- a/pfio/FileMetadata.F90 +++ b/pfio/FileMetadata.F90 @@ -86,8 +86,8 @@ function new_FileMetadata(unusable, dimensions, global, variables, order) result type (StringVariableMap), optional, intent(in) :: variables type (StringVector), optional, intent(in) :: order - _UNUSED_DUMMY(unusable) + fmd%dimensions = StringIntegerMap() if (present(dimensions)) fmd%dimensions = dimensions @@ -100,7 +100,8 @@ function new_FileMetadata(unusable, dimensions, global, variables, order) result fmd%order = StringVector() if (present(order)) fmd%order = order - end function + _UNUSED_DUMMY(unusable) + end function function get_dimensions(this) result(dimensions) type (StringIntegerMap), pointer :: dimensions @@ -170,6 +171,7 @@ integer function get_dimension(this, dim_name, unusable, rc) result(extent) type (StringIntegerMapIterator) :: iter + iter = this%dimensions%find(dim_name) if (iter /= this%dimensions%end()) then @@ -178,7 +180,6 @@ integer function get_dimension(this, dim_name, unusable, rc) result(extent) else extent = 0 if (present(rc)) rc=pFIO_DIMENSION_NOT_FOUND - !_FAIL( 'FileMetadata::get_dimension() - no such dimension <'//dim_name//'>.') end if _UNUSED_DUMMY(unusable) @@ -596,10 +597,6 @@ logical function same_attributes(a, b) result(equal) class (FileMetadata), target, intent(in) :: a class (FileMetadata), target, intent(in) :: b - type (StringAttributeMapIterator) :: iter - type (Attribute), pointer :: attr_a, attr_b - character(len=:), pointer :: attr_name - equal = (a%global_var == b%global_var) end function same_attributes @@ -737,7 +734,6 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) integer, intent(out) :: iostat character(*), intent(inout) :: iomsg - call write_dims(this%dimensions, unit, iotype, v_list, iostat, iomsg) if (iostat /= 0) return call write_variables(this%variables, unit, iotype, v_list, iostat, iomsg) @@ -815,5 +811,4 @@ subroutine write_variables(variables, unit, iotype, v_list, iostat, iomsg) end subroutine write_variables - end module pFIO_FileMetadataMod diff --git a/pfio/MpiMutex.F90 b/pfio/MpiMutex.F90 index 7a8b192ef976..cd3cce16780e 100644 --- a/pfio/MpiMutex.F90 +++ b/pfio/MpiMutex.F90 @@ -3,7 +3,6 @@ module pFIO_MpiMutexMod use mpi - use iso_fortran_env, only: INT64 use iso_c_binding, only: c_ptr, c_f_pointer implicit none private diff --git a/pfio/MpiSocket.F90 b/pfio/MpiSocket.F90 index 58b3b84065f5..b7b6d7a60c49 100644 --- a/pfio/MpiSocket.F90 +++ b/pfio/MpiSocket.F90 @@ -3,7 +3,6 @@ module pFIO_MpiSocketMod use iso_c_binding - use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: INT64 use MAPL_ExceptionHandling use pFIO_AbstractSocketMod @@ -202,9 +201,7 @@ subroutine wait(this, rc) integer :: ierror integer :: status(MPI_STATUS_SIZE) - integer :: save_request - save_request = this%mpi_request call MPI_Wait(this%mpi_request, status, ierror) _VERIFY(ierror) _RETURN(_SUCCESS) diff --git a/pfio/MultiCommServer.F90 b/pfio/MultiCommServer.F90 index 48b55de61553..3b0afb0f13e2 100644 --- a/pfio/MultiCommServer.F90 +++ b/pfio/MultiCommServer.F90 @@ -3,9 +3,8 @@ module pFIO_MultiCommServerMod use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: C_NULL_PTR use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 + use, intrinsic :: iso_fortran_env, only: INT64 use, intrinsic :: iso_c_binding, only: c_f_pointer use mapl_KeywordEnforcerMod use MAPL_ErrorHandlingMod @@ -171,10 +170,8 @@ subroutine start(this, rc) subroutine start_back(rc) integer, optional, intent(out) :: rc - integer :: collection_counter, collection_total - integer :: ierr, rank + integer :: ierr integer :: my_rank, cmd, status - integer(kind=INT64) :: msize_word call MPI_Comm_rank(this%server_comm, my_rank, ierr) allocate(this%serverthread_done_msgs(1)) @@ -252,7 +249,7 @@ subroutine create_remote_win(this, rc) integer, optional, intent(out) :: rc class (AbstractDataReference), pointer :: remotePtr integer :: rank - integer(KIND=INT64) :: offset, msize_word + integer(KIND=INT64) :: msize_word integer(KIND=INT64),allocatable :: offsets(:), msize_words(:) type (MessageVectorIterator) :: iter type (StringInteger64MapIterator) :: request_iter @@ -339,7 +336,6 @@ subroutine create_remote_win(this, rc) !(2) loop to get the total size and offset of each collection and request allocate(offsets(collection_total), msize_words(collection_total)) offsets = 0 - offset = 0 iter = thread_ptr%request_backlog%begin() do while (iter /= thread_ptr%request_backlog%end()) msg => iter%get() diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index 77812368dfa3..f61f9585f141 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -3,9 +3,8 @@ module pFIO_MultiGroupServerMod use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: C_NULL_PTR use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 + use, intrinsic :: iso_fortran_env, only: REAL64, INT32, INT64 use, intrinsic :: iso_c_binding, only: c_f_pointer use mapl_KeywordEnforcerMod use MAPL_Profiler @@ -215,7 +214,6 @@ subroutine start_front(rc) class (ServerThread), pointer :: thread_ptr => null() integer :: i,client_size, status logical, allocatable :: mask(:) - integer :: terminate = -1 client_size = this%threads%size() @@ -274,7 +272,6 @@ end subroutine put_DataToFile subroutine clean_up(this, rc) class(MultiGroupServer), target, intent(inout) :: this integer, optional, intent(out) :: rc - type(StringInteger64MapIterator) :: iter integer :: num_clients, n class (ServerThread),pointer :: thread_ptr @@ -296,17 +293,8 @@ subroutine clean_up(this, rc) call this%set_AllBacklogIsEmpty(.true.) this%serverthread_done_msgs(:) = .false. - iter = this%prefetch_offset%begin() - do while (iter /= this%prefetch_offset%end()) - call this%prefetch_offset%erase(iter) - iter = this%prefetch_offset%begin() - enddo - - iter = this%stage_offset%begin() - do while (iter /= this%stage_offset%end()) - call this%stage_offset%erase(iter) - iter = this%stage_offset%begin() - enddo + call this%prefetch_offset%clear() + call this%stage_offset%clear() if (associated(ioserver_profiler)) call ioserver_profiler%stop("clean up") _RETURN(_SUCCESS) @@ -468,13 +456,12 @@ subroutine start_back(this, rc) subroutine start_back_captain(rc) integer, optional, intent(out) :: rc - logical :: flag integer :: collection_id integer :: nwriter_per_node integer, allocatable :: idleRank(:,:) ! idle processors integer, allocatable :: num_idlePEs(:) ! how many idle processors in each node of backend server - integer :: i, no_job, local_rank, node_rank, nth_writer - integer :: terminate, idle_writer, ierr + integer :: local_rank, node_rank, nth_writer + integer :: terminate, ierr integer :: MPI_STAT(MPI_STATUS_SIZE) character(len=FNAME_LEN) :: FileName @@ -530,11 +517,13 @@ subroutine dispatch_work(collection_id, idleRank, num_idlePEs, FileName, rc) logical :: flag character(len=FNAME_LEN) :: FileDone type (StringSetIterator) :: iter + logical :: found ! 2.1) try to retrieve idle writers ! keep looping (waiting) until there are idle processors nwriter_per_node = size(idleRank,2) - do while (.true.) + found = .false. + do while (.not. found) ! non block probe writers do local_rank = 1, this%nwriter-1 flag = .false. @@ -567,15 +556,16 @@ subroutine dispatch_work(collection_id, idleRank, num_idlePEs, FileName, rc) ! get the node with the most idle processors node_rank = maxloc(num_idlePEs, dim=1) - 1 do i = 0, nwriter_per_node -1 - if (idleRank(node_rank,i) == -1) cycle - idle_writer = idleRank(node_rank,i) - idleRank(node_rank,i) = -1 ! set to -1 when it becomes busy - num_idlePEs(node_rank) = num_idlePEs(node_rank)-1 - exit + if (idleRank(node_rank,i) /= -1) then + idleRank(node_rank,i) = -1 ! set to -1 when it becomes busy + num_idlePEs(node_rank) = num_idlePEs(node_rank)-1 + idle_writer = idleRank(node_rank,i) + exit + end if enddo _ASSERT(1<= idle_writer .and. idle_writer <= this%nwriter-1, "wrong local rank of writer") call FilesBeingWritten%insert(FileName) - exit ! exit the loop after get one idle processor and the file is done + found = .true. ! exit the loop after get one idle processor and the file is done enddo ! while, get one idle writer ! 2.2) tell front comm which idel_worker is ready @@ -626,7 +616,6 @@ subroutine start_back_writers(rc) integer :: msg_size, back_local_rank, status integer :: MPI_STAT(MPI_STATUS_SIZE), ierr - type (MessageVectorIterator) :: iter class (AbstractMessage), pointer :: msg class(ServerThread), pointer :: thread_ptr integer, allocatable :: buffer_fmd(:) @@ -704,7 +693,7 @@ subroutine start_back_writers(rc) deallocate(this%buffers(i)%buffer) if (size(f_d_m%idata) ==0) cycle file_size = file_size + size(f_d_m%idata) - iter = f_d_m%msg_vec%begin() + do j = 1, f_d_m%msg_vec%size() msg => f_d_m%msg_vec%at(j) select type (q=>msg) diff --git a/pfio/MultiLayerServer.F90 b/pfio/MultiLayerServer.F90 index 48a96b8be76f..4e8e45c8da72 100644 --- a/pfio/MultiLayerServer.F90 +++ b/pfio/MultiLayerServer.F90 @@ -2,10 +2,6 @@ #include "unused_dummy.H" module pFIO_MultiLayerServerMod - use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: C_NULL_PTR - use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 use, intrinsic :: iso_c_binding, only: c_f_pointer use mapl_KeywordEnforcerMod use MAPL_ErrorHandlingMod @@ -145,7 +141,6 @@ subroutine put_DataToFile(this, rc) type (MessageVectorIterator) :: iter type (StringInteger64MapIterator) :: request_iter integer,pointer :: i_ptr(:) - type(c_ptr) :: offset_address integer :: collection_counter class (AbstractDataReference), pointer :: dataRefPtr class (RDMAReference), pointer :: remotePtr @@ -187,7 +182,6 @@ subroutine put_DataToFile(this, rc) if (request_iter == this%stage_offset%end() .and. this%rank == remotePtr%mem_rank ) then ! not read yet ! (1) get address where data should put offset = this%stage_offset%at(i_to_string(q%request_id)) - offset_address = c_loc(i_ptr(offset+1)) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !2) forward data to writer forMSG = ForwardDataMessage(q%request_id, q%collection_id, q%file_name, q%var_name, & @@ -240,11 +234,9 @@ subroutine forward_DataToWriter(forwardVec, forwardData, rc) type (StringAttributeMap), intent(in) :: forwardData integer, optional, intent(out) :: rc - integer :: writer_rank, bsize, ksize, k, rank + integer :: writer_rank, bsize integer :: command, ierr, MPI_STAT(MPI_STATUS_SIZE) integer, allocatable :: buffer(:) - integer :: status - type (MessageVectorIterator) :: iter command = 1 diff --git a/pfio/NetCDF4_FileFormatter.F90 b/pfio/NetCDF4_FileFormatter.F90 index 93004e7604eb..7a16331ada8e 100644 --- a/pfio/NetCDF4_FileFormatter.F90 +++ b/pfio/NetCDF4_FileFormatter.F90 @@ -718,11 +718,7 @@ subroutine def_variables(this, cf, unusable, varname, rc) class (Variable), pointer :: var integer :: varid - type (StringIntegerMap), pointer :: all_dims - - vars => cf%get_variables() - all_dims => cf%get_dimensions() order = cf%get_order() var_iter = order%begin() diff --git a/pfio/RDMAReference.F90 b/pfio/RDMAReference.F90 index 5fa0aedc7b94..f692b4230a56 100644 --- a/pfio/RDMAReference.F90 +++ b/pfio/RDMAReference.F90 @@ -2,7 +2,7 @@ #include "unused_dummy.H" module pFIO_RDMAReferenceMod - use, intrinsic :: iso_c_binding, only: c_ptr, c_sizeof + use, intrinsic :: iso_c_binding, only: c_sizeof use, intrinsic :: iso_fortran_env, only: INT64 use MAPL_ExceptionHandling use pFIO_UtilitiesMod diff --git a/pfio/ServerThread.F90 b/pfio/ServerThread.F90 index 9c1c6b857157..d7c9b31299b2 100644 --- a/pfio/ServerThread.F90 +++ b/pfio/ServerThread.F90 @@ -3,7 +3,6 @@ module pFIO_ServerThreadMod use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: C_NULL_PTR use, intrinsic :: iso_c_binding, only: c_loc use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT32, INT64 use, intrinsic :: iso_c_binding, only: c_f_pointer @@ -226,7 +225,6 @@ recursive subroutine handle_Done(this, message, rc) class(AbstractMessage),pointer :: dMessage type (MessageVectorIterator) :: iter class (AbstractMessage), pointer :: msg - class(AbstractSocket),pointer :: connection integer :: status ! first time handling the "Done" message, simple return @@ -249,8 +247,6 @@ recursive subroutine handle_Done(this, message, rc) iter = this%request_backlog%begin() msg => iter%get() - connection=>this%get_connection(status) - _VERIFY(status) select type (q=>msg) type is (PrefetchDataMessage) @@ -869,7 +865,7 @@ subroutine receive_output_data(this, rc) class (AbstractDataReference), pointer :: dataRefPtr type (RDMAReference), pointer :: remotePtr - integer(kind=MPI_ADDRESS_KIND) :: msize_word, offset + integer(kind=MPI_ADDRESS_KIND) :: offset integer :: local_size integer, pointer :: k_ptr(:) type (MessageVectorIterator) :: iter @@ -895,7 +891,6 @@ subroutine receive_output_data(this, rc) if (local_size > 0) then call c_f_pointer(handle%data_reference%base_address, k_ptr, shape=[local_size]) collection_counter = this%containing_server%stage_offset%at(i_to_string(msg%collection_id)) - msize_word = this%containing_server%stage_offset%of(i_to_string(MSIZE_ID+collection_counter)) ndims = size(msg%start) offset = this%containing_server%stage_offset%at(i_to_string(msg%request_id)) @@ -1004,7 +999,6 @@ recursive subroutine handle_Done_stage(this, message, rc) type (MessageVectorIterator) :: iter class (AbstractMessage), pointer :: msg - class(AbstractSocket),pointer :: connection class (AbstractRequestHandle), pointer :: handle integer :: status @@ -1017,8 +1011,6 @@ recursive subroutine handle_Done_stage(this, message, rc) iter = this%request_backlog%begin() do while ( iter /= this%request_backlog%end()) msg => iter%get() - connection=>this%get_connection(status) - _VERIFY(status) select type (q=>msg) type is (StageDataMessage) @@ -1082,6 +1074,7 @@ recursive subroutine handle_Done_prefetch(this, message, rc) _UNUSED_DUMMY(message) end subroutine handle_Done_prefetch + recursive subroutine handle_Done_collective_prefetch(this, message, rc) class (ServerThread), target, intent(inout) :: this type (CollectivePrefetchDoneMessage), intent(in) :: message diff --git a/pfio/ShmemReference.F90 b/pfio/ShmemReference.F90 index 97c6e1c11410..e7e9e228d1d5 100644 --- a/pfio/ShmemReference.F90 +++ b/pfio/ShmemReference.F90 @@ -2,7 +2,6 @@ #include "unused_dummy.H" module pFIO_ShmemReferenceMod - use, intrinsic :: iso_c_binding, only: c_ptr use, intrinsic :: iso_fortran_env, only: INT64 use MAPL_ExceptionHandling use pFIO_UtilitiesMod diff --git a/pfio/SimpleSocket.F90 b/pfio/SimpleSocket.F90 index b00b409a43a7..7f25be4bf9b6 100644 --- a/pfio/SimpleSocket.F90 +++ b/pfio/SimpleSocket.F90 @@ -15,10 +15,6 @@ module pFIO_SimpleSocketMod use pFIO_AbstractRequestHandleMod use pFIO_AbstractDataReferenceMod - use, intrinsic :: iso_fortran_env, only: REAL32 - use, intrinsic :: iso_c_binding, only: c_ptr - use, intrinsic :: iso_c_binding, only: c_loc - use, intrinsic :: iso_c_binding, only: c_f_pointer implicit none private diff --git a/pfio/Variable.F90 b/pfio/Variable.F90 index 170ec8088da0..326fbfbd27bd 100644 --- a/pfio/Variable.F90 +++ b/pfio/Variable.F90 @@ -12,8 +12,6 @@ module pFIO_VariableMod use pFIO_AttributeMod use pFIO_StringAttributeMapMod use pFIO_StringAttributeMapUtilMod - use, intrinsic :: iso_fortran_env, only: INT32, INT64 - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 implicit none private @@ -398,7 +396,6 @@ subroutine deserialize(this, buffer, rc) integer,intent(in) :: buffer(:) integer, optional, intent(out) :: rc integer :: n,length, v_type - type (UnlimitedEntity) :: const integer :: status n = 1 @@ -422,11 +419,11 @@ subroutine deserialize(this, buffer, rc) _VERIFY(status) n = n + length - !allocate(const) + call deserialize_intrinsic(buffer(n:),length) call UnlimitedEntity_deserialize(buffer(n:(n+length-1)), this%const_value, status) _VERIFY(status) - !this%const_value = const + n = n + length call deserialize_intrinsic(buffer(n:),this%deflation) length = serialize_buffer_length(this%deflation) diff --git a/pfio/pFIO_Utilities.F90 b/pfio/pFIO_Utilities.F90 index ac3e58157771..fdc59be1b194 100644 --- a/pfio/pFIO_Utilities.F90 +++ b/pfio/pFIO_Utilities.F90 @@ -3,7 +3,6 @@ module pFIO_UtilitiesMod use, intrinsic :: iso_c_binding, only: c_sizeof - use, intrinsic :: iso_c_binding, only: c_bool use, intrinsic :: iso_fortran_env, only: INT32,REAL32,INT64,REAL64 use pFIO_ConstantsMod use MAPL_ExceptionHandling @@ -193,9 +192,6 @@ function serialize_int32_0d(scalar, rc) result(buffer) integer(kind=INT32), intent(in) :: scalar integer, optional, intent(out) :: rc - integer(kind=INT32) :: n - - n = 1 buffer = [scalar] _RETURN(_SUCCESS) diff --git a/pfio/pfio_collective_demo.F90 b/pfio/pfio_collective_demo.F90 index dfebbac6f8d3..528739fa94df 100644 --- a/pfio/pfio_collective_demo.F90 +++ b/pfio/pfio_collective_demo.F90 @@ -115,6 +115,7 @@ end subroutine process_command_line end module collective_demo_CLI module FakeExtDataMod_collective + use, intrinsic :: iso_fortran_env, only: INT64 use MAPL_ExceptionHandling use collective_demo_CLI use pFIO @@ -203,15 +204,15 @@ subroutine run(this, step) type (ArrayReference) :: ref integer :: i_var,i - integer :: lat0, lat1, nlats + integer :: lat0, lat1 integer :: collection_id character(len=5) :: tmp - integer :: c1,c2,num_request + integer(kind=INT64) :: c1,c2 + integer :: num_request integer,allocatable :: request_ids(:,:) lat0 = 1 + (this%rank*this%nlat)/this%npes lat1 = (this%rank+1)*this%nlat/this%npes - nlats = (lat1 - lat0 + 1) ! Establish the collection ! In a real use case the collection name would be the ExtData template. @@ -293,7 +294,6 @@ end subroutine finalize end module FakeExtDataMod_collective program main - use, intrinsic :: iso_fortran_env, only: REAL32 use mpi use pFIO use MAPL_ExceptionHandling @@ -312,7 +312,8 @@ program main integer, parameter :: CLIENT_COLOR = 2 integer, parameter :: BOTH_COLOR = 3 - integer :: comm,num_threads + integer :: comm +!# integer :: num_threads type (FakeExtData), target :: extData required = MPI_THREAD_MULTIPLE diff --git a/pfio/pfio_open_close.F90 b/pfio/pfio_open_close.F90 index 0f13bd591c43..d1116b9600fd 100644 --- a/pfio/pfio_open_close.F90 +++ b/pfio/pfio_open_close.F90 @@ -9,7 +9,6 @@ program main type (FileMetadata) :: file_metadata type (NetCDF4_FileFormatter) :: formatter - type (FileMetadata) :: test_metadata integer :: status call formatter%open('test_in.nc4', pFIO_READ, rc=status) diff --git a/pfio/pfio_server_demo.F90 b/pfio/pfio_server_demo.F90 index c95695b014ba..a03a54c234f9 100644 --- a/pfio/pfio_server_demo.F90 +++ b/pfio/pfio_server_demo.F90 @@ -201,13 +201,12 @@ subroutine run(this, step) integer :: i_var !integer :: i - integer :: lat0, lat1, nlats + integer :: lat0, lat1 integer :: collection_id !character(len=4) :: tmp lat0 = 1 + (this%rank*this%nlat)/this%npes lat1 = (this%rank+1)*this%nlat/this%npes - nlats = (lat1 - lat0 + 1) ! Establish the collection ! In a real use case the collection name would be the ExtData template. @@ -264,7 +263,6 @@ end subroutine finalize end module FakeExtDataMod_server program main - use, intrinsic :: iso_fortran_env, only: REAL32 use mpi use pFIO use server_demo_CLI @@ -281,7 +279,8 @@ program main integer, parameter :: SERVER_COLOR = 1 integer, parameter :: CLIENT_COLOR = 2 - integer :: comm,num_threads + integer :: comm +!C$ integer :: num_threads type (FakeExtData), target :: extData class(AbstractDirectoryService), pointer :: d_s=>null() @@ -301,7 +300,7 @@ program main call MPI_Comm_split(MPI_COMM_WORLD, color, key, comm, ierror) - num_threads = 20 +!C$ num_threads = 20 allocate(d_s, source = DirectoryService(MPI_COMM_WORLD)) if (color == SERVER_COLOR) then From 9c56255ecdb01808f3b5570cdd266a626103041f Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 1 Sep 2023 15:59:35 -0400 Subject: [PATCH 08/13] Missed some stragglers. --- pfio/AbstractServer.F90 | 4 ++++ pfio/ClientThread.F90 | 1 + pfio/DirectoryService.F90 | 1 + pfio/FastClientThread.F90 | 1 + pfio/FileMetadata.F90 | 8 +++++++- pfio/MultiGroupServer.F90 | 1 + 6 files changed, 15 insertions(+), 1 deletion(-) diff --git a/pfio/AbstractServer.F90 b/pfio/AbstractServer.F90 index 17957539ed61..968c47904a89 100644 --- a/pfio/AbstractServer.F90 +++ b/pfio/AbstractServer.F90 @@ -309,12 +309,14 @@ subroutine receive_output_data(this, rc) integer, optional, intent(out) :: rc _FAIL(" no action of receive_output_data") + _UNUSED_DUMMY(this) end subroutine receive_output_data subroutine put_DataToFile(this, rc) class (AbstractServer),target, intent(inout) :: this integer, optional, intent(out) :: rc _FAIL(" no action of server_put_DataToFile") + _UNUSED_DUMMY(this) end subroutine put_DataToFile subroutine get_DataFromMem(this,multi, rc) @@ -322,6 +324,7 @@ subroutine get_DataFromMem(this,multi, rc) logical, intent(in) :: multi integer, optional, intent(out) :: rc _FAIL(" no action of server_get_DataFromMem") + _UNUSED_DUMMY(this) _UNUSED_DUMMY(multi) end subroutine get_DataFromMem @@ -347,6 +350,7 @@ subroutine distribute_task(this,id, node_rank, innode_rank) rank = mod(id, this%npes) node_rank = this%Node_Ranks(rank) + _UNUSED_DUMMY(this) end subroutine distribute_task function get_writing_PE(this,id) result (rank) diff --git a/pfio/ClientThread.F90 b/pfio/ClientThread.F90 index 2f18bb407c07..40b778c633d7 100644 --- a/pfio/ClientThread.F90 +++ b/pfio/ClientThread.F90 @@ -151,6 +151,7 @@ function add_hist_collection(this, fmd, unusable, mode, rc) result(hist_collect end select _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) end function add_hist_collection function prefetch_data(this, collection_id, file_name, var_name, data_reference, & diff --git a/pfio/DirectoryService.F90 b/pfio/DirectoryService.F90 index 47af5fe1c61d..6f4471ae0c19 100644 --- a/pfio/DirectoryService.F90 +++ b/pfio/DirectoryService.F90 @@ -272,6 +272,7 @@ subroutine connect_to_server(this, port_name, client, client_comm, unusable, ser allocate(sckt, source=MpiSocket(this%comm, server_rank, this%parser)) call client%set_connection(sckt) _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) end subroutine connect_to_server subroutine connect_to_client(this, port_name, server, rc) diff --git a/pfio/FastClientThread.F90 b/pfio/FastClientThread.F90 index e149c2df15c3..08a3af2d9b41 100644 --- a/pfio/FastClientThread.F90 +++ b/pfio/FastClientThread.F90 @@ -186,6 +186,7 @@ subroutine post_wait_all(this) use pFIO_AbstractRequestHandleMod class (FastClientThread), target, intent(inout) :: this ! do nothing on purpose + _UNUSED_DUMMY(this) end subroutine post_wait_all end module pFIO_FastClientThreadMod diff --git a/pfio/FileMetadata.F90 b/pfio/FileMetadata.F90 index b973ad17d84a..b453fcbb30af 100644 --- a/pfio/FileMetadata.F90 +++ b/pfio/FileMetadata.F90 @@ -739,6 +739,7 @@ subroutine write_formatted(this, unit, iotype, v_list, iostat, iomsg) call write_variables(this%variables, unit, iotype, v_list, iostat, iomsg) if (iostat /= 0) return + _UNUSED_DUMMY(v_list) end subroutine write_formatted subroutine write_dims(dimensions, unit, iotype, v_list, iostat, iomsg) @@ -756,11 +757,14 @@ subroutine write_dims(dimensions, unit, iotype, v_list, iostat, iomsg) associate (e => dimensions%end()) iter = dimensions%begin() do while (iter /= e) - write(unit, '(T8,a,1x,a,1x,i0,/)') iter%key(), "=" , iter%value() + write(unit, '(T8,a,1x,a,1x,i0,/)', iostat=iostat, iomsg=iomsg) iter%key(), "=" , iter%value() + if (iostat /= 0) return call iter%next() end do end associate + _UNUSED_DUMMY(iotype) + _UNUSED_DUMMY(v_list) end subroutine write_dims subroutine write_variables(variables, unit, iotype, v_list, iostat, iomsg) @@ -809,6 +813,8 @@ subroutine write_variables(variables, unit, iotype, v_list, iostat, iomsg) end do end associate + _UNUSED_DUMMY(iotype) + _UNUSED_DUMMY(v_list) end subroutine write_variables end module pFIO_FileMetadataMod diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index f61f9585f141..d9b188adeb11 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -257,6 +257,7 @@ subroutine create_remote_win(this, rc) class (MultiGroupServer), target, intent(inout) :: this integer, optional, intent(out) :: rc _RETURN(_SUCCESS) + _UNUSED_DUMMY(this) end subroutine create_remote_win subroutine put_DataToFile(this, rc) From e7c8b04d78398614222cbe41e4ff9957a59944b6 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Fri, 1 Sep 2023 19:09:38 -0400 Subject: [PATCH 09/13] Missed a few items - Was only compiling pfio and shared. A few things were broken. --- base/Base.F90 | 1 - pfio/pfio_collective_demo.F90 | 2 +- shared/Shmem/Shmem.F90 | 4 ++-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/base/Base.F90 b/base/Base.F90 index 32929296150d..e307bbd325b7 100644 --- a/base/Base.F90 +++ b/base/Base.F90 @@ -20,7 +20,6 @@ module MAPLBase_Mod use MAPL_SunMod use MAPL_LocStreamMod use MAPL_InterpMod - use MAPL_HeapMod use MAPL_SatVaporMod use MAPL_MemUtilsMod use MAPL_HashMod diff --git a/pfio/pfio_collective_demo.F90 b/pfio/pfio_collective_demo.F90 index 528739fa94df..82c8a34955bb 100644 --- a/pfio/pfio_collective_demo.F90 +++ b/pfio/pfio_collective_demo.F90 @@ -313,7 +313,7 @@ program main integer, parameter :: BOTH_COLOR = 3 integer :: comm -!# integer :: num_threads +!$ integer :: num_threads type (FakeExtData), target :: extData required = MPI_THREAD_MULTIPLE diff --git a/shared/Shmem/Shmem.F90 b/shared/Shmem/Shmem.F90 index dbb851dc9afe..8ef1644ce301 100644 --- a/shared/Shmem/Shmem.F90 +++ b/shared/Shmem/Shmem.F90 @@ -254,7 +254,7 @@ module subroutine MAPL_DeAllocNodeArray_6DR8(Ptr,rc) end subroutine MAPL_DeAllocNodeArray_6DR8 module subroutine MAPL_AllocNodeArray_1DL4(Ptr, Shp, lbd, rc) - logical(kind=C_Bool), pointer, intent(INOUT) :: Ptr(:) + logical, pointer, intent(INOUT) :: Ptr(:) integer, intent(IN ) :: Shp(1) integer, optional, intent(IN ) :: lbd(1) integer, optional, intent( OUT) :: rc @@ -363,7 +363,7 @@ module subroutine MAPL_AllocNodeArray_6DR8(Ptr, Shp, lbd, rc) end subroutine MAPL_AllocNodeArray_6DR8 module subroutine MAPL_AllocateShared_1DL4(Ptr, Shp, lbd, TransRoot, rc) - logical(kind=C_BOOL), pointer, intent(INOUT) :: Ptr(:) + logical, pointer, intent(INOUT) :: Ptr(:) integer, intent(IN ) :: Shp(1) integer, optional, intent(IN ) :: lbd(1) logical, intent(IN ) :: TransRoot From 2ab7fecbf0a8d66c7a37e86324bee12cd85f0644 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Sun, 3 Sep 2023 17:29:49 -0400 Subject: [PATCH 10/13] Fixes for profiler layer. --- profiler/AbstractMeterNode.F90 | 1 - profiler/reporting/ExclusiveColumn.F90 | 1 - profiler/reporting/InclusiveColumn.F90 | 1 - profiler/reporting/MaxCycleColumn.F90 | 1 - profiler/reporting/MeanCycleColumn.F90 | 1 - profiler/reporting/MinCycleColumn.F90 | 1 - profiler/reporting/PercentageColumn.F90 | 5 +++-- profiler/reporting/SimpleColumn.F90 | 2 -- profiler/reporting/StdDevColumn.F90 | 1 - 9 files changed, 3 insertions(+), 11 deletions(-) diff --git a/profiler/AbstractMeterNode.F90 b/profiler/AbstractMeterNode.F90 index ea96fdfe1683..2d18cded3dfb 100644 --- a/profiler/AbstractMeterNode.F90 +++ b/profiler/AbstractMeterNode.F90 @@ -78,7 +78,6 @@ end function i_get_child logical function i_has_child(this, name) import AbstractMeterNode - class(AbstractMeterNode), pointer :: children class(AbstractMeterNode), target, intent(in) :: this character(*), intent(in) :: name end function i_has_child diff --git a/profiler/reporting/ExclusiveColumn.F90 b/profiler/reporting/ExclusiveColumn.F90 index 967066af7b25..09118c362542 100644 --- a/profiler/reporting/ExclusiveColumn.F90 +++ b/profiler/reporting/ExclusiveColumn.F90 @@ -1,5 +1,4 @@ module MAPL_ExclusiveColumn - use, intrinsic :: iso_fortran_env, only: REAL64 use MAPL_AbstractColumn use MAPL_SimpleColumn use MAPL_AbstractMeterNode diff --git a/profiler/reporting/InclusiveColumn.F90 b/profiler/reporting/InclusiveColumn.F90 index b792b258ff98..7f4ecf974273 100644 --- a/profiler/reporting/InclusiveColumn.F90 +++ b/profiler/reporting/InclusiveColumn.F90 @@ -1,5 +1,4 @@ module MAPL_InclusiveColumn - use, intrinsic :: iso_fortran_env, only: REAL64 use MAPL_AbstractColumn use MAPL_SimpleColumn use MAPL_AbstractMeterNode diff --git a/profiler/reporting/MaxCycleColumn.F90 b/profiler/reporting/MaxCycleColumn.F90 index af3ea6838e0c..fbd0c7f6d4a3 100644 --- a/profiler/reporting/MaxCycleColumn.F90 +++ b/profiler/reporting/MaxCycleColumn.F90 @@ -1,5 +1,4 @@ module MAPL_MaxCycleColumn - use, intrinsic :: iso_fortran_env, only: REAL64 use MAPL_SimpleColumn use MAPL_AbstractMeterNode use MAPL_AbstractMeter diff --git a/profiler/reporting/MeanCycleColumn.F90 b/profiler/reporting/MeanCycleColumn.F90 index 4082d9b6204b..c108818b9c74 100644 --- a/profiler/reporting/MeanCycleColumn.F90 +++ b/profiler/reporting/MeanCycleColumn.F90 @@ -1,5 +1,4 @@ module MAPL_MeanCycleColumn - use, intrinsic :: iso_fortran_env, only: REAL64 use MAPL_SimpleColumn use MAPL_AbstractMeterNode use MAPL_AbstractMeter diff --git a/profiler/reporting/MinCycleColumn.F90 b/profiler/reporting/MinCycleColumn.F90 index c66ba580aeeb..1443c962b15f 100644 --- a/profiler/reporting/MinCycleColumn.F90 +++ b/profiler/reporting/MinCycleColumn.F90 @@ -1,5 +1,4 @@ module MAPL_MinCycleColumn - use, intrinsic :: iso_fortran_env, only: REAL64 use MAPL_SimpleColumn use MAPL_AbstractMeterNode use MAPL_AbstractMeter diff --git a/profiler/reporting/PercentageColumn.F90 b/profiler/reporting/PercentageColumn.F90 index b1b4f0053ea8..f198749c4707 100644 --- a/profiler/reporting/PercentageColumn.F90 +++ b/profiler/reporting/PercentageColumn.F90 @@ -89,10 +89,11 @@ function get_row(this, node) result(row) class (PercentageColumn), intent(in) :: this class (AbstractMeterNode), target, intent(in) :: node - _UNUSED_DUMMY(this) - _UNUSED_DUMMY(row) + row = 0 allocate(row,source=0) ! to eliminate compiler warning. + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(node) end function get_row end module MAPL_PercentageColumn diff --git a/profiler/reporting/SimpleColumn.F90 b/profiler/reporting/SimpleColumn.F90 index ec1c4966a3b4..ce4ed6add6ca 100644 --- a/profiler/reporting/SimpleColumn.F90 +++ b/profiler/reporting/SimpleColumn.F90 @@ -39,12 +39,10 @@ function get_rows(this, node) result(rows) class (SimpleColumn), intent(in) :: this class (AbstractMeterNode), target, intent(in) :: node - integer :: n_meters integer :: i class (AbstractMeterNodeIterator), allocatable :: iter class (AbstractMeterNode), pointer :: subnode - n_meters = node%get_num_nodes() iter = node%begin() i = 0 diff --git a/profiler/reporting/StdDevColumn.F90 b/profiler/reporting/StdDevColumn.F90 index 8954cb13a247..6af428ce83d9 100644 --- a/profiler/reporting/StdDevColumn.F90 +++ b/profiler/reporting/StdDevColumn.F90 @@ -1,5 +1,4 @@ module MAPL_StdDevColumn - use, intrinsic :: iso_fortran_env, only: REAL64 use MAPL_AbstractColumn use MAPL_SimpleColumn use MAPL_AbstractMeterNode From 7f0319e0df2ffdad1a305371ee44e07161e6a136 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Sun, 3 Sep 2023 17:37:53 -0400 Subject: [PATCH 11/13] Cleanup pfunit subdir --- pfunit/ESMF_TestCase.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/pfunit/ESMF_TestCase.F90 b/pfunit/ESMF_TestCase.F90 index e44058255510..22ea62fa4a8d 100644 --- a/pfunit/ESMF_TestCase.F90 +++ b/pfunit/ESMF_TestCase.F90 @@ -79,6 +79,7 @@ recursive subroutine runBare(this) ! only report context failure on root PE if (.not. this%parentContext%isRootProcess()) then discard = catch() + if (.false.) print*,shape(discard) end if end if From e1c174a769680ccb9d83863aabb9af3f7f7bb445 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Sun, 3 Sep 2023 18:16:41 -0400 Subject: [PATCH 12/13] Some fixes for procedures in base. --- base/ApplicationSupport.F90 | 1 + base/BinIO.F90 | 2 +- base/CFIOCollection.F90 | 1 - base/MAPL_AbstractGridFactory.F90 | 1 - base/MAPL_Comms.F90 | 11 ++-- base/MAPL_CubedSphereGridFactory.F90 | 23 +++----- base/MAPL_EsmfRegridder.F90 | 11 +--- base/MAPL_ExternalGridFactory.F90 | 79 +++++++++++----------------- base/MAPL_GridManager.F90 | 11 ++-- base/MAPL_LatLonGridFactory.F90 | 12 ++--- base/MAPL_RegridderManager.F90 | 6 +-- base/MaplGrid.F90 | 3 -- base/NCIO.F90 | 41 --------------- base/arraygather.H | 6 +-- base/cub2latlon_regridder.F90 | 9 ++-- 15 files changed, 64 insertions(+), 153 deletions(-) diff --git a/base/ApplicationSupport.F90 b/base/ApplicationSupport.F90 index e88cf42a29a5..bc895330e0c2 100644 --- a/base/ApplicationSupport.F90 +++ b/base/ApplicationSupport.F90 @@ -198,6 +198,7 @@ subroutine report_global_profiler(unusable,comm,rc) end if call MPI_Barrier(world_comm, ierror) + _RETURN(_SUCCESS) end subroutine report_global_profiler end module MAPL_ApplicationSupport diff --git a/base/BinIO.F90 b/base/BinIO.F90 index 2de6de654267..55335c89fce1 100644 --- a/base/BinIO.F90 +++ b/base/BinIO.F90 @@ -18,7 +18,7 @@ module BinIOMod use FileIOSharedMod, only: ArrDescr, MAPL_TileMaskGet, WRITE_PARALLEL, alloc_, dealloc_ use FileIOSharedMod, only: STD_OUT_UNIT_NUMBER, LAST_UNIT, TAKEN, MTAKEN, mname - use FileIOSharedMod, only: not_allocated, r4_2, r4_1, r8_2, r8_1, i4_2, i4_1 + use FileIOSharedMod, only: r4_2, r4_1, r8_2, r8_1, i4_1 use FileIOSharedMod, only: MEM_UNITS, munit, REC use ESMF use MAPL_BaseMod diff --git a/base/CFIOCollection.F90 b/base/CFIOCollection.F90 index 581734b7515d..4c57cf952619 100644 --- a/base/CFIOCollection.F90 +++ b/base/CFIOCollection.F90 @@ -3,7 +3,6 @@ module ESMF_CFIOCollectionMod use ESMF use ESMF_CFIOMod - use MAPL_BaseMod, only : MAPL_GridGet use ESMF_CFIOUtilMod use ESMF_CFIOFileMod use ESMF_CFIOPtrVectorMod diff --git a/base/MAPL_AbstractGridFactory.F90 b/base/MAPL_AbstractGridFactory.F90 index e224d011693d..2a422d617991 100644 --- a/base/MAPL_AbstractGridFactory.F90 +++ b/base/MAPL_AbstractGridFactory.F90 @@ -769,7 +769,6 @@ end subroutine cartesian_to_spherical_3d_real64 function get_basis(this,basis,unusable,rc) result(basis_vectors) use esmf use MAPL_KeywordEnforcerMod - use MAPL_Constants, only : PI => MAPL_PI_R8 real(REAL64), pointer :: basis_vectors(:,:,:,:) character(len=*), intent(in) :: basis class (AbstractGridFactory), target, intent(inout) :: this diff --git a/base/MAPL_Comms.F90 b/base/MAPL_Comms.F90 index dd02d6693390..078a0a8a2c1c 100644 --- a/base/MAPL_Comms.F90 +++ b/base/MAPL_Comms.F90 @@ -745,7 +745,7 @@ subroutine MAPL_CollectiveGather3D(Grid, LocArray, GlobArray, & type (MAPL_CommRequest) :: reqs(size(LocArray,3)) integer :: root(size(LocArray,3)) - integer :: NumCores, Nnodes + integer :: Nnodes integer :: nn integer :: LM, L, nc, npes, mype, dims(5) type(ESMF_VM) :: VM @@ -761,12 +761,6 @@ subroutine MAPL_CollectiveGather3D(Grid, LocArray, GlobArray, & call ESMF_VMGet(VM, petcount=npes, localpet=MYPE, mpiCommunicator=comm, RC=STATUS) _VERIFY(STATUS) - if(present(CoresPerNode)) then - NumCores = CoresPerNode - else - NumCores = MAPL_CoresPerNodeGet(comm,rc=status) - _VERIFY(STATUS) - end if LM = size(LocArray,3) @@ -815,7 +809,8 @@ subroutine MAPL_CollectiveGather3D(Grid, LocArray, GlobArray, & end do _RETURN(ESMF_SUCCESS) - end subroutine MAPL_CollectiveGather3D + _UNUSED_DUMMY(corespernode) + end subroutine MAPL_CollectiveGather3D subroutine MAPL_CollectiveScatter3D(Grid, GlobArray, LocArray, hw, rc) diff --git a/base/MAPL_CubedSphereGridFactory.F90 b/base/MAPL_CubedSphereGridFactory.F90 index 02fe18c64b6d..3f34d728ebdc 100644 --- a/base/MAPL_CubedSphereGridFactory.F90 +++ b/base/MAPL_CubedSphereGridFactory.F90 @@ -383,7 +383,7 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi _VERIFY(status) _UNUSED_DUMMY(unusable) - + _UNUSED_DUMMY(force_file_coordinates) end subroutine initialize_from_file_metadata @@ -553,8 +553,6 @@ subroutine get_bounds(bounds, label, rc) character(len=*) :: label integer, optional, intent(out) :: rc - integer :: i - integer :: n integer :: status logical :: isPresent @@ -1276,11 +1274,9 @@ subroutine generate_file_bounds(this,grid,local_start,global_start,global_count, integer :: global_dim(3),i1,j1,in,jn,tile character(len=*), parameter :: Iam = MOD_NAME // 'generate_file_bounds' logical :: face_format - integer :: nf - _UNUSED_DUMMY(this) + if (present(metadata)) then - nf = metadata%get_dimension('nf',rc=status) if (status == _SUCCESS) then face_format = .true. else @@ -1304,6 +1300,7 @@ subroutine generate_file_bounds(this,grid,local_start,global_start,global_count, end if _RETURN(_SUCCESS) + _UNUSED_DUMMY(this) end subroutine generate_file_bounds @@ -1318,7 +1315,7 @@ subroutine generate_file_corner_bounds(this,grid,local_start,global_start,global integer :: status integer :: global_dim(3),i1,j1,in,jn,tile - integer :: face_i1, face_j1, is, js + integer :: face_j1, is, js character(len=*), parameter :: Iam = MOD_NAME // 'generate_file_bounds' _UNUSED_DUMMY(this) @@ -1326,7 +1323,6 @@ subroutine generate_file_corner_bounds(this,grid,local_start,global_start,global _VERIFY(status) call MAPL_GridGetInterior(grid,i1,in,j1,jn) tile = 1 + (j1-1)/global_dim(1) - face_i1 = i1 face_j1 = j1-(tile-1)*global_dim(1) is = i1 js = face_j1 @@ -1357,16 +1353,9 @@ function generate_file_reference3D(this,fpointer,metadata) result(ref) type(c_ptr) :: cptr real, pointer :: ptr_ref(:,:,:,:,:) logical :: face_format - integer :: nf,status - _UNUSED_DUMMY(this) if (present(metadata)) then - nf = metadata%get_dimension('nf',rc=status) - if (status == _SUCCESS) then - face_format = .true. - else - face_format = .false. - end if + face_format = metadata%has_dimension('nf') else face_format = .true. end if @@ -1378,6 +1367,8 @@ function generate_file_reference3D(this,fpointer,metadata) result(ref) else ref = ArrayReference(fpointer) end if + + _UNUSED_DUMMY(this) end function generate_file_reference3D end module MAPL_CubedSphereGridFactoryMod diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index db8335fc87e9..382ec9cc2c4f 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -10,7 +10,7 @@ module MAPL_EsmfRegridderMod use MAPL_AbstractGridFactoryMod use MAPL_AbstractRegridderMod use MAPL_GridManagerMod - use MAPL_BaseMod, only: MAPL_undef, MAPL_GridGet, MAPL_GridHasDE + use MAPL_BaseMod, only: MAPL_undef, MAPL_GridHasDE use MAPL_RegridderSpecRouteHandleMap implicit none private @@ -441,8 +441,6 @@ subroutine transpose_regrid_scalar_3d_real32(this, q_in, q_out, rc) type (ESMF_Field) :: src_field, dst_field integer :: km,kin,kout - integer :: im_src, jm_src - integer :: im_dst, jm_dst logical :: hasDE type(ESMF_VM) :: vm @@ -453,12 +451,6 @@ subroutine transpose_regrid_scalar_3d_real32(this, q_in, q_out, rc) km = size(q_in,3) _ASSERT(km == size(q_out,3),'inconsistent array shape') - im_src = size(q_in,1) - jm_src = size(q_in,2) - - im_dst = size(q_out,1) - jm_dst = size(q_out,2) - HasDE = MAPL_GridHasDE(spec%grid_out,rc=status) _VERIFY(status) if (hasDE) then @@ -1367,7 +1359,6 @@ end subroutine do_regrid subroutine initialize_subclass(this, unusable, rc) use MAPL_KeywordEnforcerMod use MAPL_RegridderSpec - use MAPL_BaseMod, only: MAPL_grid_interior class (EsmfRegridder), intent(inout) :: this class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc diff --git a/base/MAPL_ExternalGridFactory.F90 b/base/MAPL_ExternalGridFactory.F90 index fda105845f72..2c03e8ba4956 100644 --- a/base/MAPL_ExternalGridFactory.F90 +++ b/base/MAPL_ExternalGridFactory.F90 @@ -9,8 +9,7 @@ module MAPL_ExternalGridFactoryMod use pFIO use MAPL_CommsMod use MAPL_Constants - use MAPL_IOMod, only : GETFILE, FREE_FILE - use, intrinsic :: iso_fortran_env, only: REAL64,REAL32 + use, intrinsic :: iso_fortran_env, only: REAL32 implicit none private @@ -51,7 +50,9 @@ module MAPL_ExternalGridFactoryMod interface ExternalGridFactory module procedure ExternalGridFactory_from_parameters end interface ExternalGridFactory + contains + function ExternalGridFactory_from_parameters(unusable, grid_name, grid, lm, rc) result(factory) type(ExternalGridFactory) :: factory class(KeywordEnforcer), optional, intent(in ) :: unusable @@ -60,15 +61,13 @@ function ExternalGridFactory_from_parameters(unusable, grid_name, grid, lm, rc) integer, optional, intent(in ) :: lm integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'ExternalGridFactory_from_parameters' - - _UNUSED_DUMMY(unusable) - if (present(grid_name)) factory%grid_name = grid_name if (present(grid)) factory%external_grid = grid if (present(grid)) factory%lm = lm _RETURN(_SUCCESS) + + _UNUSED_DUMMY(unusable) end function ExternalGridFactory_from_parameters function make_new_grid(this, unusable, rc) result(grid) @@ -77,12 +76,9 @@ function make_new_grid(this, unusable, rc) result(grid) class(KeywordEnforcer), optional, intent(in ) :: unusable integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'make_grid' logical :: is_present integer :: status, lm - _UNUSED_DUMMY(unusable) - if (allocated(this%external_grid)) then grid = this%external_grid else @@ -105,6 +101,8 @@ function make_new_grid(this, unusable, rc) result(grid) end if _RETURN(_SUCCESS) + + _UNUSED_DUMMY(unusable) end function make_new_grid function decomps_are_equal(this,a) result(equal) @@ -112,7 +110,6 @@ function decomps_are_equal(this,a) result(equal) class(AbstractGridFactory), intent(in) :: a logical :: equal - _UNUSED_DUMMY(this) select type(a) class default equal = .false. @@ -120,6 +117,8 @@ function decomps_are_equal(this,a) result(equal) class is (ExternalGridFactory) equal = .true. end select + + _UNUSED_DUMMY(this) end function decomps_are_equal function physical_params_are_equal(this,a) result(equal) @@ -127,7 +126,6 @@ function physical_params_are_equal(this,a) result(equal) class(AbstractGridFactory), intent(in) :: a logical :: equal - _UNUSED_DUMMY(this) select type(a) class default equal = .false. @@ -135,13 +133,14 @@ function physical_params_are_equal(this,a) result(equal) class is (ExternalGridFactory) equal = .true. end select + + _UNUSED_DUMMY(this) end function physical_params_are_equal logical function equals(a, b) class(ExternalGridFactory), intent(in) :: a class(AbstractGridFactory), intent(in) :: b - _UNUSED_DUMMY(a) select type(b) class default equals = .false. @@ -149,6 +148,8 @@ logical function equals(a, b) class is (ExternalGridFactory) equals = .true. end select + + _UNUSED_DUMMY(a) end function equals subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_file_coordinates, rc) @@ -158,15 +159,12 @@ subroutine initialize_from_file_metadata(this, file_metadata, unusable, force_fi logical, optional, intent(in) :: force_file_coordinates integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'initialize_from_file_metadata' + _RETURN(_FAILURE) _UNUSED_DUMMY(this) _UNUSED_DUMMY(unusable) _UNUSED_DUMMY(file_metadata) - - _FAIL('unimplemented') - - _RETURN(_SUCCESS) + _UNUSED_DUMMY(force_file_coordinates) end subroutine initialize_from_file_metadata subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc) @@ -176,16 +174,12 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc class(KeywordEnforcer), optional, intent(in ) :: unusable integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'initialize_from_config_with_prefix' + _RETURN(_FAILURE) _UNUSED_DUMMY(this) _UNUSED_DUMMY(unusable) _UNUSED_DUMMY(config) _UNUSED_DUMMY(prefix) - - _FAIL('unimplemented') - - _RETURN(_SUCCESS) end subroutine initialize_from_config_with_prefix subroutine initialize_from_esmf_distGrid(this, dist_grid, lon_array, lat_array, unusable, rc) @@ -196,17 +190,13 @@ subroutine initialize_from_esmf_distGrid(this, dist_grid, lon_array, lat_array, class(KeywordEnforcer), optional, intent(in ) :: unusable integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'initialize_from_esmf_distGrid' + _RETURN(_FAILURE) _UNUSED_DUMMY(this) _UNUSED_DUMMY(unusable) _UNUSED_DUMMY(dist_grid) _UNUSED_DUMMY(lon_array) _UNUSED_DUMMY(lat_array) - - _FAIL('unimplemented') - - _RETURN(_SUCCESS) end subroutine initialize_from_esmf_distGrid subroutine halo(this, array, unusable, halo_width, rc) @@ -216,58 +206,56 @@ subroutine halo(this, array, unusable, halo_width, rc) integer, optional, intent(in ) :: halo_width integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'halo' + _RETURN(_FAILURE) _UNUSED_DUMMY(this) _UNUSED_DUMMY(unusable) _UNUSED_DUMMY(array) _UNUSED_DUMMY(halo_width) - - _FAIL('unimplemented') - - _RETURN(_SUCCESS) end subroutine halo function generate_grid_name(this) result(name) character(:), allocatable :: name class(ExternalGridFactory), intent(in) :: this - _UNUSED_DUMMY(this) name = 'EXTERNAL' + + _UNUSED_DUMMY(this) end function generate_grid_name subroutine append_metadata(this, metadata) class(ExternalGridFactory), intent(inout) :: this type(FileMetadata), intent(inout) :: metadata + ! Unimplemented + _UNUSED_DUMMY(this) _UNUSED_DUMMY(metadata) - ! TODO: fill in the rest end subroutine append_metadata function get_grid_vars(this) result(vars) character(:), allocatable :: vars class(ExternalGridFactory), intent(inout) :: this - _UNUSED_DUMMY(this) vars = '' + _UNUSED_DUMMY(this) end function get_grid_vars function get_file_format_vars(this) result(vars) character(:), allocatable :: vars class(ExternalGridFactory), intent(inout) :: this - _UNUSED_DUMMY(this) vars = '' + _UNUSED_DUMMY(this) end function get_file_format_vars subroutine append_variable_metadata(this, var) class(ExternalGridFactory), intent(inout) :: this type(Variable), intent(inout) :: var + ! TODO: fill in the rest _UNUSED_DUMMY(this) _UNUSED_DUMMY(var) - ! TODO: fill in the rest end subroutine append_variable_metadata subroutine generate_file_bounds(this, grid, local_start, global_start, global_count, metadata, rc) @@ -279,17 +267,14 @@ subroutine generate_file_bounds(this, grid, local_start, global_start, global_co type(FileMetaData), intent(in), optional :: metaData integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'generate_file_bounds' + _RETURN(_FAILURE) _UNUSED_DUMMY(this) _UNUSED_DUMMY(grid) _UNUSED_DUMMY(local_start) _UNUSED_DUMMY(global_start) _UNUSED_DUMMY(global_count) - - _FAIL('unimplemented') - - _RETURN(_SUCCESS) + _UNUSED_DUMMY(metaData) end subroutine generate_file_bounds subroutine generate_file_corner_bounds(this, grid, local_start, global_start, global_count, rc) @@ -300,15 +285,13 @@ subroutine generate_file_corner_bounds(this, grid, local_start, global_start, gl integer, allocatable, intent( out) :: global_count(:) integer, optional, intent( out) :: rc - character(len=*), parameter :: Iam = MOD_NAME // 'generate_file_bounds' + _RETURN(_FAILURE) _UNUSED_DUMMY(this) _UNUSED_DUMMY(grid) _UNUSED_DUMMY(local_start) _UNUSED_DUMMY(global_start) _UNUSED_DUMMY(global_count) - - _RETURN(_SUCCESS) end subroutine generate_file_corner_bounds function generate_file_reference2D(this, fpointer) result(ref) @@ -316,8 +299,8 @@ function generate_file_reference2D(this, fpointer) result(ref) class(ExternalGridFactory), intent(inout) :: this real, pointer, intent(in ) :: fpointer(:,:) - _UNUSED_DUMMY(this) ref = ArrayReference(fpointer) + _UNUSED_DUMMY(this) end function generate_file_reference2D function generate_file_reference3D(this, fpointer, metadata) result(ref) @@ -326,8 +309,10 @@ function generate_file_reference3D(this, fpointer, metadata) result(ref) real, pointer, intent(in ) :: fpointer(:,:,:) type(FileMetaData), intent(in), optional :: metaData - _UNUSED_DUMMY(this) ref = ArrayReference(fpointer) + + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(metaData) end function generate_file_reference3D end module MAPL_ExternalGridFactoryMod diff --git a/base/MAPL_GridManager.F90 b/base/MAPL_GridManager.F90 index 5808d12ac5bb..eb2bd07b782b 100644 --- a/base/MAPL_GridManager.F90 +++ b/base/MAPL_GridManager.F90 @@ -17,7 +17,6 @@ module MAPL_GridManager_private use MAPL_KeywordEnforcerMod use mapl_ErrorHandlingMod use ESMF - use MAPL_ExceptionHandling, only: MAPL_throw_exception implicit none private @@ -126,7 +125,6 @@ subroutine initialize_prototypes(this, unusable, rc) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc - integer :: status type (LatLonGridFactory) :: latlon_factory type (CubedSphereGridFactory) :: cubed_factory type (TripolarGridFactory) :: tripolar_factory @@ -141,8 +139,6 @@ subroutine initialize_prototypes(this, unusable, rc) ! with a shared state variable with avoiding a shared state vartiable. logical, save :: initialized = .false. - _UNUSED_DUMMY(unusable) - ! intialized check prevents adding same items twice if (.not. initialized) then call this%prototypes%insert('LatLon', latlon_factory) @@ -156,6 +152,7 @@ subroutine initialize_prototypes(this, unusable, rc) _RETURN(_SUCCESS) + _UNUSED_DUMMY(unusable) end subroutine initialize_prototypes function make_clone(this, grid_type, unusable, rc) result(factory) @@ -464,7 +461,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, type (FileMetadata) :: file_metadata type (NetCDF4_FileFormatter) :: file_formatter - integer :: im, jm, nf + integer :: im, jm character(len=*), parameter :: Iam= MOD_NAME // 'make_factory_from_file()' integer :: status @@ -534,8 +531,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, if (jm == 6*im .or. splitByface) then allocate(factory, source=this%make_clone('Cubed-Sphere')) else - nf = file_metadata%get_dimension('nf',rc=status) - if (status == _SUCCESS) then + if (file_metadata%has_dimension('nf')) then allocate(factory, source=this%make_clone('Cubed-Sphere')) end if end if @@ -578,7 +574,6 @@ module MAPL_GridManagerMod use MAPL_GridManager_private use MAPL_KeywordEnforcerMod use mapl_ErrorHandlingMod - use MAPL_ExceptionHandling, only: MAPL_throw_exception use ESMF implicit none private diff --git a/base/MAPL_LatLonGridFactory.F90 b/base/MAPL_LatLonGridFactory.F90 index 8cbba70dccce..fbbbfe3a41e7 100644 --- a/base/MAPL_LatLonGridFactory.F90 +++ b/base/MAPL_LatLonGridFactory.F90 @@ -1081,8 +1081,6 @@ subroutine get_range(range, label, rc) character(len=*) :: label integer, optional, intent(out) :: rc - integer :: i - integer :: n integer :: status logical :: isPresent @@ -1877,8 +1875,6 @@ subroutine generate_file_bounds(this,grid,local_start,global_start,global_count, integer :: status integer :: global_dim(3), i1,j1,in,jn - _UNUSED_DUMMY(this) - call MAPL_GridGet(grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) call MAPL_GridGetInterior(grid,i1,in,j1,jn) @@ -1888,6 +1884,8 @@ subroutine generate_file_bounds(this,grid,local_start,global_start,global_count, _RETURN(_SUCCESS) + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(metadata) end subroutine generate_file_bounds subroutine generate_file_corner_bounds(this,grid,local_start,global_start,global_count,rc) @@ -1914,8 +1912,8 @@ function generate_file_reference2D(this,fpointer) result(ref) type(ArrayReference) :: ref class(LatLonGridFactory), intent(inout) :: this real, pointer, intent(in) :: fpointer(:,:) - _UNUSED_DUMMY(this) ref = ArrayReference(fpointer) + _UNUSED_DUMMY(this) end function generate_file_reference2D function generate_file_reference3D(this,fpointer,metaData) result(ref) @@ -1924,8 +1922,10 @@ function generate_file_reference3D(this,fpointer,metaData) result(ref) class(LatLonGridFactory), intent(inout) :: this real, pointer, intent(in) :: fpointer(:,:,:) type(FileMetaData), intent(in), optional :: metaData - _UNUSED_DUMMY(this) ref = ArrayReference(fpointer) + + _UNUSED_DUMMY(this) + _UNUSED_DUMMY(metaData) end function generate_file_reference3D diff --git a/base/MAPL_RegridderManager.F90 b/base/MAPL_RegridderManager.F90 index 6a43e68ceea0..06a7c47dedf6 100644 --- a/base/MAPL_RegridderManager.F90 +++ b/base/MAPL_RegridderManager.F90 @@ -171,8 +171,8 @@ function find(vector, spec) result(match) type (RegridderVectorIterator) :: iter - iter = this%regridders%begin() - do while (iter /= this%regridders%end()) + iter = vector%begin() + do while (iter /= vector%end()) match => iter%get() if (match%get_spec() == spec) return call iter%next() @@ -198,7 +198,7 @@ function get_grid_type(grid, unusable, rc) result(grid_type) grid_type = trim(buffer) _RETURN(_SUCCESS) - + _UNUSED_DUMMY(unusable) end function get_grid_type end function make_regridder_from_grids diff --git a/base/MaplGrid.F90 b/base/MaplGrid.F90 index 40b428c5dd0b..0552df9ca01c 100644 --- a/base/MaplGrid.F90 +++ b/base/MaplGrid.F90 @@ -337,7 +337,6 @@ subroutine MAPL_DistGridGet(distGrid,minIndex,maxIndex,rc) integer, optional, intent(out ) :: rc integer :: status - character(len=ESMF_MAXSTR) :: Iam integer :: i,tileSize,tileCount,tile,deCount logical :: ESMFCubeSphere @@ -345,8 +344,6 @@ subroutine MAPL_DistGridGet(distGrid,minIndex,maxIndex,rc) integer, allocatable :: deToTileMap(:) integer, allocatable :: oldMinIndex(:,:),oldMaxIndex(:,:) - Iam = "MAPL_DistGridGet" - ESMFCubeSphere = .false. call ESMF_DistGridGet(distGrid,tileCount=tileCount,_RC) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 63b4df68aec8..49af6923d5c1 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -852,7 +852,6 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC integer :: jsize, jprev, num_io_rows integer, allocatable :: recvcounts(:), displs(:) - logical :: AM_WRITER type (ArrayReference) :: ref integer :: i1, j1, in, jn, global_dim(3) @@ -875,14 +874,6 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC end if endif - AM_WRITER = .false. - if (present(arrdes)) then - if (arrdes%writers_comm/=MPI_COMM_NULL) then - AM_WRITER = .true. - end if - else - AM_WRITER = .true. - end if if (present(arrdes)) then @@ -1200,17 +1191,6 @@ subroutine MAPL_VarWriteNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, of integer, allocatable :: activerecvcounts(:) integer :: start(4), cnt(4) - logical :: AM_WRITER - - AM_WRITER = .false. - if (present(arrdes)) then - if (arrdes%writers_comm/=MPI_COMM_NULL) then - AM_WRITER = .true. - end if - else - AM_WRITER = .true. - end if - if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world @@ -1516,16 +1496,6 @@ subroutine MAPL_VarWriteNCpar_R8_1d(formatter, name, A, layout, ARRDES, MASK, of integer, allocatable :: activerecvcounts(:) integer :: start(4), cnt(4) - logical :: AM_WRITER - - AM_WRITER = .false. - if (present(arrdes)) then - if (arrdes%writers_comm/=MPI_COMM_NULL) then - AM_WRITER = .true. - end if - else - AM_WRITER = .true. - end if if(present(mask) .and. present(layout) .and. present(arrdes) ) then @@ -2406,7 +2376,6 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, oC integer :: jsize, jprev, num_io_rows integer, allocatable :: recvcounts(:), displs(:) - logical :: AM_WRITER type (ArrayReference) :: ref integer :: i1, j1, in, jn, global_dim(3) @@ -2428,16 +2397,6 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, oC endif endif - - AM_WRITER = .false. - if (present(arrdes)) then - if (arrdes%writers_comm/=MPI_COMM_NULL) then - AM_WRITER = .true. - end if - else - AM_WRITER = .true. - end if - if (present(arrdes)) then IM_WORLD = arrdes%im_world diff --git a/base/arraygather.H b/base/arraygather.H index 26a94ee48064..7149871831c1 100644 --- a/base/arraygather.H +++ b/base/arraygather.H @@ -44,8 +44,10 @@ #if (RANK_ > 1) integer :: J1, JN integer :: jbeg,jend + integer :: jsz #endif - integer :: ISZ, JSZ + + integer :: ISZ integer :: destPE, myhw TYPE_(kind=EKIND_), allocatable :: var(:) type(ESMF_VM) :: vm @@ -148,8 +150,6 @@ #if (RANK_ == 2) JSZ = size(GLOBAL_ARRAY,2) -#else - JSZ = 1 #endif allocate(KK (0:nDEs-1 ), stat=status) diff --git a/base/cub2latlon_regridder.F90 b/base/cub2latlon_regridder.F90 index db789f275cf5..2edf278d9b28 100644 --- a/base/cub2latlon_regridder.F90 +++ b/base/cub2latlon_regridder.F90 @@ -19,7 +19,7 @@ module SupportMod use MAPL_StringRouteHandleMapMod use gFTL_StringVector use gFTL_StringIntegerMap - use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64, INT64 use mpi implicit none public @@ -460,8 +460,6 @@ logical function keep_var(var_name, requested_vars) character(len=*), intent(in) :: var_name type (StringVector), intent(in) :: requested_vars - integer :: idx - if (requested_vars%size() == 0) then keep_var = .true. else @@ -705,7 +703,7 @@ subroutine write_data(this, rc) logical :: is_east_vector_component integer :: idx character(len=:), allocatable :: north_component - integer :: c0, c1,crate + integer(kind=INT64) :: c0, c1,crate associate (cs_fmtr => this%formatter_cubed_sphere, ll_fmtr => this%formatter_lat_lon) call cs_fmtr%open(this%in_file, mode=pFIO_READ, rc=status) @@ -1106,6 +1104,7 @@ subroutine create_lat_lon_grid(this, rc) integer, allocatable :: jms(:) integer, allocatable :: ims(:) integer :: np + integer :: npx np = floor(sqrt(real(pet_count))) do npx = np, 1, -1 @@ -1192,7 +1191,7 @@ program main use pFIO implicit none - integer :: c00, c0, c1, crate + integer(kind=INT64) :: c00, c0, c1, crate integer :: status type (RegridSupport) :: regridder From 8149c559ffac66126a134fd6502a519b6fc7384a Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 4 Sep 2023 09:16:43 -0400 Subject: [PATCH 13/13] Fix typo in previous commit. --- base/MAPL_CubedSphereGridFactory.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/base/MAPL_CubedSphereGridFactory.F90 b/base/MAPL_CubedSphereGridFactory.F90 index 3f34d728ebdc..b237d93bcb0b 100644 --- a/base/MAPL_CubedSphereGridFactory.F90 +++ b/base/MAPL_CubedSphereGridFactory.F90 @@ -1277,11 +1277,7 @@ subroutine generate_file_bounds(this,grid,local_start,global_start,global_count, if (present(metadata)) then - if (status == _SUCCESS) then - face_format = .true. - else - face_format = .false. - end if + face_format = metadata%has_dimension('nf') else face_format = .true. end if @@ -1353,6 +1349,7 @@ function generate_file_reference3D(this,fpointer,metadata) result(ref) type(c_ptr) :: cptr real, pointer :: ptr_ref(:,:,:,:,:) logical :: face_format + integer :: status if (present(metadata)) then face_format = metadata%has_dimension('nf')