diff --git a/ccpp_framework b/ccpp_framework
index 5f338ddf..0f823272 160000
--- a/ccpp_framework
+++ b/ccpp_framework
@@ -1 +1 @@
-Subproject commit 5f338ddf02638c06548e54e0a218d154b34faff9
+Subproject commit 0f8232724975c13289cad390c9a71fa2c6a9bff4
diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90
index fff0f506..d8b4155c 100644
--- a/src/control/cam_comp.F90
+++ b/src/control/cam_comp.F90
@@ -429,7 +429,7 @@ end subroutine cam_run4
!
!-----------------------------------------------------------------------
!
- subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check)
+ subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check, do_history_write)
!-----------------------------------------------------------------------
!
! Purpose: Timestep final runs at the end of each timestep
@@ -444,12 +444,23 @@ subroutine cam_timestep_final(rstwr, nlend, do_ncdata_check)
!Flag for whether a snapshot (ncdata) check should be run or not
! - flag is true if this is not the first or last step
logical, intent(in) :: do_ncdata_check
+ !Flag for whether to perform the history write
+ logical, optional, intent(in) :: do_history_write
- if (do_ncdata_check .or. get_nstep() == 0) then
+ logical :: history_write_loc
+
+ if (present(do_history_write)) then
+ history_write_loc = do_history_write
+ else
+ history_write_loc = .true.
+ end if
+
+ if (history_write_loc) then
call history_write_files()
- ! peverwhee - todo: handle restarts
- call history_wrap_up(rstwr, nlend)
end if
+ ! peverwhee - todo: handle restarts
+ call history_wrap_up(rstwr, nlend)
+
!
!----------------------------------------------------------
! PHYS_TIMESTEP_FINAL Call the Physics package
diff --git a/src/control/cam_physics_control.F90 b/src/control/cam_physics_control.F90
index c4bc2c5b..36c1068f 100644
--- a/src/control/cam_physics_control.F90
+++ b/src/control/cam_physics_control.F90
@@ -1,8 +1,8 @@
module cam_physics_control
!------------------------------------------------------------------------------
!
-! High level control variables. Information received from the driver/coupler is
-! stored here.
+! High level physics control variables. Information received from the
+! driver/coupler is stored here.
!
!------------------------------------------------------------------------------
@@ -19,15 +19,8 @@ module cam_physics_control
!
! cam_ctrl_set_physics_type
- logical, protected :: adiabatic ! true => no physics
- logical, protected :: ideal_phys ! true => run Held-Suarez (1994) physics
- logical, protected :: kessler_phys ! true => run Kessler physics
- logical, protected :: tj2016_phys ! true => run tj2016 physics
- logical, protected :: grayrad_phys ! true => run gray radiation (frierson) physics
logical, protected :: simple_phys ! true => adiabatic or ideal_phys or kessler_phys
! or tj2016 or grayrad
- logical, protected :: moist_physics ! true => moist physics enabled, i.e.,
- ! (.not. ideal_phys) .and. (.not. adiabatic)
!==============================================================================
@@ -45,6 +38,12 @@ subroutine cam_ctrl_set_physics_type()
character(len=SHR_KIND_CS), allocatable :: suite_names(:)
! suite_name: CCPP suite we are running
character(len=SHR_KIND_CS) :: suite_name
+ logical :: adiabatic
+ logical :: ideal_phys
+ logical :: kessler_phys
+ logical :: tj2016_phys
+ logical :: grayrad_phys
+ logical :: moist_physics
character(len=*), parameter :: subname = 'cam_ctrl_set_physics_type'
@@ -69,7 +68,7 @@ subroutine cam_ctrl_set_physics_type()
if (masterproc) then
if (adiabatic) then
write(iulog,*) 'Run model ADIABATICALLY (i.e. no physics)'
- write(iulog,*) ' Global energy fixer is on for non-Eulerian dycores.'
+ write(iulog,*) ' Global energy fixer is on for dycores.'
else if (ideal_phys) then
write(iulog,*) 'Run model with Held-Suarez physics forcing'
else if (kessler_phys) then
diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90
index 918c8ea8..45fb6ac8 100644
--- a/src/cpl/nuopc/atm_comp_nuopc.F90
+++ b/src/cpl/nuopc/atm_comp_nuopc.F90
@@ -1435,6 +1435,7 @@ subroutine ModelFinalize(gcomp, rc)
call ESMF_AlarmRingerOff( alarm, rc=rc )
if (ChkErr(rc,__LINE__,u_FILE_u)) return
else
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
rstwr = .false.
endif
@@ -1444,12 +1445,14 @@ subroutine ModelFinalize(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (ESMF_AlarmIsRinging(alarm, rc=rc)) then
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
nlend = .true.
else
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
nlend = .false.
endif
- call cam_timestep_final(rstwr, nlend, do_ncdata_check=.false.)
+ call cam_timestep_final(rstwr, nlend, do_ncdata_check=.false., do_history_write=.false.)
call cam_final(cam_out, cam_in)
if (masterproc) then
diff --git a/src/data/registry_v1_0.xsd b/src/data/registry_v1_0.xsd
index 38a7b336..81f756dc 100644
--- a/src/data/registry_v1_0.xsd
+++ b/src/data/registry_v1_0.xsd
@@ -92,18 +92,6 @@
-
-
-
-
-
-
-
-
-
-
-
-
@@ -137,10 +125,6 @@
-
-
-
-
@@ -151,21 +135,11 @@
-
-
-
-
-
-
-
-
-
-
@@ -185,7 +159,6 @@
-
diff --git a/src/dynamics/utils/hycoef.F90 b/src/dynamics/utils/hycoef.F90
index 134d8eb6..08280470 100644
--- a/src/dynamics/utils/hycoef.F90
+++ b/src/dynamics/utils/hycoef.F90
@@ -258,6 +258,7 @@ subroutine hycoef_init(file, psdry)
if (dry_coord) then
call add_vert_coord('lev', pver, &
'hybrid level at midpoints (1000*(A+B))', 'hPa', alev, &
+ standard_name='atmosphere_hybrid_sigma_pressure_coordinate', &
positive='down')
call add_hist_coord('hyam', pver, &
'hybrid A coefficient at layer midpoints', '1', hyam, dimname='lev')
diff --git a/src/history/cam_hist_file.F90 b/src/history/cam_hist_file.F90
index ad5e1787..835b42c2 100644
--- a/src/history/cam_hist_file.F90
+++ b/src/history/cam_hist_file.F90
@@ -454,9 +454,9 @@ subroutine config_configure(this, volume, out_prec, max_frames, &
inst_fields, avg_fields, min_fields, max_fields, var_fields, &
write_nstep0, interp_out, interp_nlat, interp_nlon, interp_grid, &
interp_type)
- use shr_string_mod, only: to_lower => shr_string_toLower
- use string_utils, only: parse_multiplier
- use cam_abortutils, only: endrun, check_allocate
+ use shr_string_mod, only: to_lower => shr_string_toLower
+ use cam_history_support, only: parse_multiplier
+ use cam_abortutils, only: endrun, check_allocate
! Dummy arguments
class(hist_file_t), intent(inout) :: this
character(len=*), intent(in) :: volume
diff --git a/src/history/cam_history_support.F90 b/src/history/cam_history_support.F90
index 42659d59..8c4f92e3 100644
--- a/src/history/cam_history_support.F90
+++ b/src/history/cam_history_support.F90
@@ -8,13 +8,7 @@ module cam_history_support
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
use shr_kind_mod, only: r8=>shr_kind_r8, shr_kind_cl, shr_kind_cxx
- use pio, only: var_desc_t, file_desc_t, PIO_MAX_NAME
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
- use spmd_utils, only: masterproc
- use cam_grid_support, only: cam_grid_patch_t, cam_grid_header_info_t
use cam_grid_support, only: max_hcoordname_len
- use cam_pio_utils, only: cam_pio_handle_error
implicit none
private
@@ -32,8 +26,11 @@ module cam_history_support
real(r8), parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields
! A special symbol for declaring a field which has no vertical or
! non-grid dimensions. It is here (rather than cam_history) so that it
- ! be checked by add_hist_coord
- character(len=10), parameter, public :: horiz_only = 'horiz_only'
+ ! can be checked by add_hist_coord
+ character(len=10), parameter, public :: horiz_only = 'horiz_only'
+ real(r8), parameter :: error_tolerance = 1.e-12_r8
+ integer, parameter :: error_msglen = 120
+ integer, parameter :: error_msglen_long = 256
!---------------------------------------------------------------------------
!
@@ -71,11 +68,11 @@ module cam_history_support
character(len=max_chars) :: bounds_name = '' ! 'bounds' attribute (& name of bounds variable)
character(len=max_chars) :: standard_name = ''! 'standard_name' attribute
character(len=4) :: positive = '' ! 'positive' attribute ('up' or 'down')
- integer, pointer :: integer_values(:) => null() ! dim values if integral
+ integer, pointer :: integer_values(:) => null() ! dim values if integer
real(r8), pointer :: real_values(:) => null() ! dim values if real
real(r8), pointer :: bounds(:,:) => null() ! dim bounds
type(formula_terms_t) :: formula_terms ! vars for formula terms
- logical :: integer_dim ! .true. iff dim has integral values
+ logical :: integer_dim ! .true. iff dim has integer values
logical :: vertical_coord ! .true. iff dim is vertical
end type hist_coord_t
@@ -121,6 +118,7 @@ module cam_history_support
public :: lookup_hist_coord_indices
public :: hist_coord_find_levels
public :: get_hist_coord_index
+ public :: parse_multiplier ! Parse a repeat count and a token from input
interface add_hist_coord
module procedure add_hist_coord_regonly
@@ -129,17 +127,17 @@ module cam_history_support
end interface
interface check_hist_coord
- ! NB: This is supposed to be a private interface
+ ! NB: This is a private interface
! check_hist_coord: returns 0 if is not registered as an mdim
! returns i if is registered with compatible values
! calls endrun if is registered with incompatible values
! Versions without the argument return .true. or .false.
module procedure check_hist_coord_char
module procedure check_hist_coord_int
- module procedure check_hist_coord_int1
+ module procedure check_hist_coord_int_1d
module procedure check_hist_coord_r8
- module procedure check_hist_coord_r81
- module procedure check_hist_coord_r82
+ module procedure check_hist_coord_r8_1d
+ module procedure check_hist_coord_r8_2d
module procedure check_hist_coord_ft
module procedure check_hist_coord_all
end interface
@@ -148,7 +146,7 @@ module cam_history_support
CONTAINS
- integer function get_hist_coord_index(mdimname)
+ pure integer function get_hist_coord_index(mdimname)
! Input variables
character(len=*), intent(in) :: mdimname
! Local variable
@@ -166,164 +164,146 @@ end function get_hist_coord_index
! Functions to check consistent term definition for hist coords
- logical function check_hist_coord_char(defined, input)
+ pure logical function check_hist_coord_char(defined, input)
! Input variables
character(len=*), intent(in) :: defined
- character(len=*), intent(in), optional :: input
+ character(len=*), intent(in) :: input
if (len_trim(defined) == 0) then
! In this case, we assume the current value is undefined so any input OK
check_hist_coord_char = .true.
- else if (present(input)) then
+ else
! We have to match definitions
check_hist_coord_char = (trim(input) == trim(defined))
- else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_char = .false.
end if
end function check_hist_coord_char
- logical function check_hist_coord_int(defined, input)
+ pure logical function check_hist_coord_int(defined, input)
! Input variables
integer, intent(in) :: defined
- integer, intent(in), optional :: input
+ integer, intent(in) :: input
if (defined == 0) then
! In this case, we assume the current value is undefined so any input OK
check_hist_coord_int = .true.
- else if (present(input)) then
+ else
! We have to match definitions
check_hist_coord_int = (input == defined)
- else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_int = .false.
end if
end function check_hist_coord_int
- logical function check_hist_coord_int1(defined, input)
+ pure logical function check_hist_coord_int_1d(defined, input)
! Input variables
integer, pointer :: defined(:)
- integer, intent(in), optional :: input(:)
+ integer, pointer :: input(:)
! Local variables
integer :: i
if (.not. associated(defined)) then
! In this case, we assume the current value is undefined so any input OK
- check_hist_coord_int1 = .true.
- else if (present(input)) then
- ! We have to match definitions
- check_hist_coord_int1 = (size(input) == size(defined))
+ check_hist_coord_int_1d = .true.
else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_int1 = .false.
+ ! We have to match definitions
+ check_hist_coord_int_1d = (size(input) == size(defined))
end if
- if (check_hist_coord_int1 .and. associated(defined)) then
+ if (check_hist_coord_int_1d .and. associated(defined)) then
! Need to check the values
do i = 1, size(defined)
if (defined(i) /= input(i)) then
- check_hist_coord_int1 = .false.
+ check_hist_coord_int_1d = .false.
exit
end if
end do
end if
- end function check_hist_coord_int1
+ end function check_hist_coord_int_1d
- logical function check_hist_coord_r8(defined, input)
+ pure logical function check_hist_coord_r8(defined, input)
! Input variables
real(r8), intent(in) :: defined
- real(r8), intent(in), optional :: input
+ real(r8), intent(in) :: input
if (defined == fillvalue) then
! In this case, we assume the current value is undefined so any input OK
check_hist_coord_r8 = .true.
- else if (present(input)) then
- ! We have to match definitions
- check_hist_coord_r8 = (input == defined)
else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_r8 = .false.
+ ! We have to match definitions (within a tolerance)
+ check_hist_coord_r8 = (abs(input - defined) <= error_tolerance)
end if
end function check_hist_coord_r8
- logical function check_hist_coord_r81(defined, input)
+ pure logical function check_hist_coord_r8_1d(defined, input)
! Input variables
real(r8), pointer :: defined(:)
- real(r8), intent(in), optional :: input(:)
+ real(r8), pointer :: input(:)
! Local variables
integer :: i
if (.not. associated(defined)) then
! In this case, we assume the current value is undefined so any input OK
- check_hist_coord_r81 = .true.
- else if (present(input)) then
- ! We have to match definitions
- check_hist_coord_r81 = (size(input) == size(defined))
+ check_hist_coord_r8_1d = .true.
else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_r81 = .false.
+ ! We have to match definitions
+ check_hist_coord_r8_1d = (size(input) == size(defined))
end if
- if (check_hist_coord_r81 .and. associated(defined)) then
- ! Need to check the values
+ if (check_hist_coord_r8_1d .and. associated(defined)) then
+ ! Need to check the values (within a tolerance)
do i = 1, size(defined)
- if (defined(i) /= input(i)) then
- check_hist_coord_r81 = .false.
+ if (abs(defined(i) - input(i)) > error_tolerance) then
+ check_hist_coord_r8_1d = .false.
exit
end if
end do
end if
- end function check_hist_coord_r81
+ end function check_hist_coord_r8_1d
- logical function check_hist_coord_r82(defined, input)
+ pure logical function check_hist_coord_r8_2d(defined, input)
! Input variables
real(r8), pointer :: defined(:,:)
- real(r8), intent(in), optional :: input(:,:)
+ real(r8), pointer :: input(:,:)
! Local variables
integer :: i, j
if (.not. associated(defined)) then
! In this case, we assume the current value is undefined so any input OK
- check_hist_coord_r82 = .true.
- else if (present(input)) then
- ! We have to match definitions
- check_hist_coord_r82 = ((size(input, 1) == size(defined, 1)) .and. &
- (size(input, 2) == size(defined, 2)))
+ check_hist_coord_r8_2d = .true.
else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_r82 = .false.
+ ! We have to match definitions
+ check_hist_coord_r8_2d = ((size(input, 1) == size(defined, 1)) .and. &
+ (size(input, 2) == size(defined, 2)))
end if
- if (check_hist_coord_r82 .and. associated(defined)) then
- ! Need to check the values
+ if (check_hist_coord_r8_2d .and. associated(defined)) then
+ ! Need to check the values (within a tolerance)
do j = 1, size(defined, 2)
do i = 1, size(defined, 1)
- if (defined(i, j) /= input(i, j)) then
- check_hist_coord_r82 = .false.
+ if (abs(defined(i, j) - input(i, j)) > error_tolerance) then
+ check_hist_coord_r8_2d = .false.
exit
end if
end do
end do
end if
- end function check_hist_coord_r82
+ end function check_hist_coord_r8_2d
logical function check_hist_coord_ft(defined, input)
! Input variables
type(formula_terms_t), intent(in) :: defined
- type(formula_terms_t), intent(in), optional :: input
+ type(formula_terms_t), intent(in) :: input
! We will assume that if formula_terms has been defined, a_name has a value
if (len_trim(defined%a_name) == 0) then
! In this case, we assume the current value is undefined so any input OK
check_hist_coord_ft = .true.
- else if (present(input)) then
+ else
! We have to match definitions
! Need to check the values
check_hist_coord_ft = &
@@ -338,9 +318,6 @@ logical function check_hist_coord_ft(defined, input)
check_hist_coord(defined%p0_units, input%p0_units) .and. &
check_hist_coord(defined%p0_value, input%p0_value) .and. &
check_hist_coord(defined%ps_name, input%ps_name)
- else
- ! Not sure here. We have a value and are redefining without one?
- check_hist_coord_ft = .false.
end if
end function check_hist_coord_ft
@@ -350,22 +327,24 @@ end function check_hist_coord_ft
! values
integer function check_hist_coord_all(name, vlen, long_name, units, bounds, &
i_values, r_values, bounds_name, positive, standard_name, formula_terms)
+ use cam_abortutils, only: endrun
+ use string_utils, only: stringify
! Input variables
character(len=*), intent(in) :: name
integer, intent(in) :: vlen
- character(len=*), intent(in), optional :: long_name
- character(len=*), intent(in), optional :: units
- character(len=*), intent(in), optional :: bounds_name
- integer, intent(in), optional :: i_values(:)
- real(r8), intent(in), optional :: r_values(:)
- real(r8), intent(in), optional :: bounds(:,:)
- character(len=*), intent(in), optional :: positive
- character(len=*), intent(in), optional :: standard_name
- type(formula_terms_t), intent(in), optional :: formula_terms
+ character(len=*), intent(in) :: long_name
+ character(len=*), intent(in) :: units
+ character(len=*), intent(in) :: bounds_name
+ integer, pointer, intent(in) :: i_values(:)
+ real(r8), pointer, intent(in) :: r_values(:)
+ real(r8), pointer, intent(in) :: bounds(:,:)
+ character(len=*), intent(in) :: positive
+ character(len=*), intent(in) :: standard_name
+ type(formula_terms_t), intent(in) :: formula_terms
! Local variables
- character(len=120) :: errormsg
+ character(len=256) :: errormsg
integer :: i
i = get_hist_coord_index(trim(name))
@@ -373,55 +352,65 @@ integer function check_hist_coord_all(name, vlen, long_name, units, bounds, &
if (i > 0) then
check_hist_coord_all = i
if (.not. check_hist_coord(hist_coords(i)%dimsize, vlen)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, '//trim(name)//' with incompatible size'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, '//trim(name)//', with incompatible size ( ', &
+ stringify((/hist_coords(i)%dimsize/)), ' vs vlen= '//stringify((/vlen/))//' )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
if (.not. check_hist_coord(hist_coords(i)%long_name, long_name)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different long_name'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with a different long_name ( "', &
+ trim(hist_coords(i)%long_name)//'" vs long_name= "'//trim(long_name)//'" )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
if (.not. check_hist_coord(hist_coords(i)%units, units)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different units'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with different units ( "', &
+ trim(hist_coords(i)%units)//'" vs units= "'//trim(units)//'" )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
if (.not. check_hist_coord(hist_coords(i)%bounds_name, bounds_name)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different bounds_name'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with a different bounds_name ( "', &
+ trim(hist_coords(i)%bounds_name)//'" vs bounds_name= "'//trim(bounds_name)//'" )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
if (.not. check_hist_coord(hist_coords(i)%standard_name, standard_name)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different standard_name'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with a different standard_name ( "', &
+ trim(hist_coords(i)%standard_name)//'" vs standard_name= "'//trim(standard_name)//'" )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
if (.not. check_hist_coord(hist_coords(i)%positive, positive)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with a different value of positive'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with a different value of positive ( "', &
+ trim(hist_coords(i)%positive)//'" vs positive= "'//trim(positive)//'" )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
! Since the integer_dim defaults to .true., double check which to check
if ((.not. hist_coords(i)%integer_dim) .or. &
associated(hist_coords(i)%real_values)) then
if (.not. check_hist_coord(hist_coords(i)%real_values, r_values)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different values'
- call endrun(errormsg)
- else if (present(i_values)) then
- write(errormsg, *) 'ERROR: Attempt to register integer values for real dimension'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with different values (( ', &
+ stringify(hist_coords(i)%real_values),') vs r_values=( '//stringify(r_values)//' ))'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
+ else if (associated(i_values)) then
+ write(errormsg, *) 'ERROR: Attempt to register integer values for real dimension ',trim(name), ' ( ', &
+ 'i_values=(', stringify(i_values), '))'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
else
if (.not. check_hist_coord(hist_coords(i)%integer_values, i_values)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different values'
- call endrun(errormsg)
- else if (present(i_values) .and. present(r_values)) then
- write(errormsg, *) 'ERROR: Attempt to register real values for integer dimension'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with different values, (( ', &
+ stringify(hist_coords(i)%integer_values)//') vs i_values= ('//stringify(i_values)//') )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
+ else if (associated(r_values)) then
+ write(errormsg, *) 'ERROR: Attempt to register real values for integer dimension ', trim(name), ' ( ', &
+ 'r_values=(', stringify(r_values), ') )'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
end if
if (.not. check_hist_coord(hist_coords(i)%bounds, bounds)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different bounds'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with different bounds'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
if (.not. check_hist_coord(hist_coords(i)%formula_terms, formula_terms)) then
- write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),' with different formula_terms'
- call endrun(errormsg)
+ write(errormsg, *) 'ERROR: Attempt to register dimension, ',trim(name),', with different formula_terms'
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
else
check_hist_coord_all = 0
@@ -429,13 +418,14 @@ integer function check_hist_coord_all(name, vlen, long_name, units, bounds, &
end function check_hist_coord_all
subroutine add_hist_coord_regonly(name, index)
+ use cam_abortutils, only: endrun
! Input variable
character(len=*), intent(in) :: name
integer, optional, intent(out) :: index
! Local variables
- character(len=120) :: errormsg
+ character(len=error_msglen) :: errormsg
integer :: i
if ((trim(name) == trim(horiz_only)) .or. (len_trim(name) == 0)) then
@@ -460,6 +450,8 @@ subroutine add_hist_coord_regonly(name, index)
hist_coords(registeredmdims)%integer_dim = .true.
hist_coords(registeredmdims)%positive = ''
hist_coords(registeredmdims)%standard_name = ''
+ hist_coords(registeredmdims)%dimname = ''
+ hist_coords(registeredmdims)%vertical_coord = .false.
if (present(index)) then
index = registeredmdims
end if
@@ -473,6 +465,8 @@ end subroutine add_hist_coord_regonly
subroutine add_hist_coord_int(name, vlen, long_name, units, values, &
positive, standard_name, dimname)
+ use cam_logfile, only: iulog
+ use spmd_utils, only: masterproc
! Input variables
character(len=*), intent(in) :: name
@@ -486,10 +480,54 @@ subroutine add_hist_coord_int(name, vlen, long_name, units, values, &
! Local variables
integer :: i
+ character(len=max_chars) :: local_units
+ character(len=max_chars) :: local_positive
+ character(len=max_chars) :: local_standard_name
+ character(len=max_chars) :: local_bounds_name
+ character(len=max_hcoordname_len) :: local_dimname
+ integer, pointer :: local_int_values(:)
+ real(r8), pointer :: local_real_values(:)
+ real(r8), pointer :: local_bounds(:,:)
+ type(formula_terms_t) :: local_formula_terms
+
+ nullify(local_int_values)
+ nullify(local_real_values)
+ nullify(local_bounds)
+ local_bounds_name = ''
+
+ if (present(units)) then
+ local_units = units
+ else
+ local_units = ''
+ end if
+
+ if (present(positive)) then
+ local_positive = positive
+ else
+ local_positive = ''
+ end if
+
+ if (present(standard_name)) then
+ local_standard_name = standard_name
+ else
+ local_standard_name = ''
+ end if
+
+ if (present(dimname)) then
+ local_dimname = dimname
+ else
+ local_dimname = ''
+ end if
+
+ if (present(values)) then
+ local_int_values => values
+ end if
! First, check to see if it is OK to add this coord
- i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, &
- i_values=values, positive=positive, standard_name=standard_name)
+ i = check_hist_coord(name, vlen, long_name, local_units, local_bounds, &
+ local_int_values, local_real_values, local_bounds_name, local_positive, &
+ local_standard_name, local_formula_terms)
+
! Register the name if necessary
if (i == 0) then
call add_hist_coord(trim(name), i)
@@ -503,36 +541,26 @@ subroutine add_hist_coord_int(name, vlen, long_name, units, values, &
hist_coords(i)%dimsize = vlen
if (len_trim(long_name) > max_chars) then
if(masterproc) then
- write(iulog,*) 'WARNING: long_name for ',trim(name),' too long'
+ write(iulog,*) 'WARNING: long_name for ',trim(name),' too long', &
+ ' and will be truncated on history files'
end if
end if
hist_coords(i)%long_name = trim(long_name)
- if (present(units)) then
- hist_coords(i)%units = trim(units)
- else
- hist_coords(i)%units = ''
- end if
+ hist_coords(i)%units = trim(local_units)
hist_coords(i)%integer_dim = .true.
- if (present(values)) then
- hist_coords(i)%integer_values => values
- endif
- if (present(positive)) then
- hist_coords(i)%positive = trim(positive)
- end if
- if (present(standard_name)) then
- hist_coords(i)%standard_name = trim(standard_name)
- end if
+ hist_coords(i)%integer_values => local_int_values
+ hist_coords(i)%positive = trim(local_positive)
+ hist_coords(i)%standard_name = trim(local_standard_name)
hist_coords(i)%vertical_coord = .false.
- if (present(dimname)) then
- hist_coords(i)%dimname = trim(dimname)
- else
- hist_coords(i)%dimname = ''
- end if
+ hist_coords(i)%dimname = trim(local_dimname)
end subroutine add_hist_coord_int
subroutine add_hist_coord_r8(name, vlen, long_name, units, values, &
bounds_name, bounds, positive, standard_name, vertical_coord, dimname)
+ use cam_abortutils, only: endrun
+ use cam_logfile, only: iulog
+ use spmd_utils, only: masterproc
! Input variables
character(len=*), intent(in) :: name
@@ -548,13 +576,60 @@ subroutine add_hist_coord_r8(name, vlen, long_name, units, values, &
character(len=*), intent(in), optional :: dimname
! Local variables
- character(len=120) :: errormsg
- integer :: i
+ character(len=error_msglen) :: errormsg
+ integer :: i
+ character(len=max_chars) :: local_positive
+ character(len=max_chars) :: local_standard_name
+ character(len=max_chars) :: local_bounds_name
+ character(len=max_hcoordname_len) :: local_dimname
+ integer, pointer :: local_int_values(:)
+ real(r8), pointer :: local_bounds(:,:)
+ type(formula_terms_t) :: local_formula_terms
+
+ nullify(local_int_values)
+ nullify(local_bounds)
+
+ if (present(positive)) then
+ local_positive = positive
+ else
+ local_positive = ''
+ end if
+
+ if (present(standard_name)) then
+ local_standard_name = standard_name
+ else
+ local_standard_name = ''
+ end if
+
+ if (present(dimname)) then
+ local_dimname = dimname
+ else
+ local_dimname = ''
+ end if
+
+ if (present(bounds)) then
+ local_bounds => bounds
+ if (.not. present(bounds_name)) then
+ write(errormsg,*) 'bounds_name must be present for bounds values'
+ call endrun(errormsg)
+ end if
+ end if
+
+ if (present(bounds_name)) then
+ if (.not. present(bounds)) then
+ write(errormsg,*) 'bounds must be present for ',trim(bounds_name)
+ call endrun(errormsg)
+ end if
+ local_bounds_name = bounds_name
+ else
+ local_bounds_name = ''
+ end if
! First, check to see if it is OK to add this coord
- i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, &
- r_values=values, positive=positive, standard_name=standard_name, &
- bounds_name=bounds_name, bounds=bounds)
+ i = check_hist_coord(name, vlen, long_name, units, local_bounds, &
+ local_int_values, values, local_bounds_name, local_positive, &
+ local_standard_name, local_formula_terms)
+
! Register the name if necessary
if (i == 0) then
call add_hist_coord(trim(name), i)
@@ -568,7 +643,8 @@ subroutine add_hist_coord_r8(name, vlen, long_name, units, values, &
hist_coords(i)%dimsize = vlen
if (len_trim(long_name) > max_chars) then
if(masterproc) then
- write(iulog,*) 'WARNING: long_name for ',trim(name),' too long'
+ write(iulog,*) 'WARNING: long_name for ',trim(name),' too long', &
+ ' and will be truncated on history files'
end if
end if
hist_coords(i)%long_name = trim(long_name)
@@ -579,40 +655,21 @@ subroutine add_hist_coord_r8(name, vlen, long_name, units, values, &
end if
hist_coords(i)%integer_dim = .false.
hist_coords(i)%real_values => values
- if (present(positive)) then
- hist_coords(i)%positive = trim(positive)
- end if
- if (present(standard_name)) then
- hist_coords(i)%standard_name = trim(standard_name)
- end if
- if (present(bounds_name)) then
- hist_coords(i)%bounds_name = trim(bounds_name)
- if (.not. present(bounds)) then
- write(errormsg,*) 'bounds must be present for ',trim(bounds_name)
- call endrun(errormsg)
- end if
- hist_coords(i)%bounds => bounds
- else if (present(bounds)) then
- write(errormsg,*) 'bounds_name must be present for bounds values'
- call endrun(errormsg)
- else
- hist_coords(i)%bounds_name = ''
- end if
+ hist_coords(i)%positive = trim(local_positive)
+ hist_coords(i)%standard_name = trim(local_standard_name)
+ hist_coords(i)%bounds_name = trim(local_bounds_name)
+ hist_coords(i)%bounds => local_bounds
if (present(vertical_coord)) then
hist_coords(i)%vertical_coord = vertical_coord
- else
- hist_coords(i)%vertical_coord = .false.
- end if
- if (present(dimname)) then
- hist_coords(i)%dimname = trim(dimname)
- else
- hist_coords(i)%dimname = ''
end if
+ hist_coords(i)%dimname = trim(local_dimname)
end subroutine add_hist_coord_r8
subroutine add_vert_coord(name, vlen, long_name, units, values, &
positive, standard_name, formula_terms)
+ use cam_logfile, only: iulog
+ use spmd_utils, only: masterproc
! Input variables
character(len=*), intent(in) :: name
@@ -626,26 +683,52 @@ subroutine add_vert_coord(name, vlen, long_name, units, values, &
! Local variable
integer :: i
+ character(len=max_chars) :: local_units
+ character(len=max_chars) :: local_positive
+ character(len=max_chars) :: local_standard_name
+ character(len=max_chars) :: local_bounds_name
+ character(len=max_hcoordname_len) :: local_dimname
+ integer, pointer :: local_int_values(:)
+ real(r8), pointer :: local_real_values(:)
+ real(r8), pointer :: local_bounds(:,:)
+ type(formula_terms_t) :: local_formula_terms
+
+ nullify(local_int_values)
+ nullify(local_real_values)
+ nullify(local_bounds)
+ local_bounds_name = ''
+ local_dimname = ''
+
+ if (present(positive)) then
+ local_positive = positive
+ else
+ local_positive = ''
+ end if
+
+ if (present(standard_name)) then
+ local_standard_name = standard_name
+ else
+ local_standard_name = ''
+ end if
+
+ if (present(formula_terms)) then
+ local_formula_terms = formula_terms
+ end if
! First, check to see if it is OK to add this coord
- i = check_hist_coord(name, vlen=vlen, long_name=long_name, units=units, &
- r_values=values, positive=positive, standard_name=standard_name, &
- formula_terms=formula_terms)
+ i = check_hist_coord(name, vlen, long_name, local_units, local_bounds, &
+ local_int_values, local_real_values, local_bounds_name, local_positive, &
+ local_standard_name, local_formula_terms)
+
! Register the name and hist_coord values if necessary
if (i == 0) then
call add_hist_coord(trim(name), vlen, long_name, units, values, &
positive=positive, standard_name=standard_name, &
vertical_coord=.true.)
i = get_hist_coord_index(trim(name))
- if(masterproc) then
- write(iulog, '(3a,i0,a,i0)') 'Registering hist coord', trim(name), &
- '(', i, ') with length: ', vlen
- end if
end if
- if (present(formula_terms)) then
- hist_coords(i)%formula_terms = formula_terms
- end if
+ hist_coords(i)%formula_terms = local_formula_terms
end subroutine add_vert_coord
@@ -653,6 +736,8 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
use pio, only: file_desc_t, var_desc_t, pio_put_att, pio_noerr, &
pio_int, pio_double, pio_inq_varid, pio_def_var
use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var
+ use cam_abortutils, only: endrun
+ use cam_pio_utils, only: cam_pio_handle_error
! Input variables
type(file_desc_t), intent(inout) :: File ! PIO file Handle
@@ -664,11 +749,12 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
! Local variables
integer :: dimid ! PIO dimension ID
type(var_desc_t) :: vardesc ! PIO variable descriptor
- character(len=120) :: errormsg
+ character(len=error_msglen_long) :: errormsg
character(len=max_chars) :: formula_terms ! Constructed string
integer :: ierr
integer :: dtype
logical :: defvar ! True if var exists
+ character(len=*), parameter :: subname = 'write_hist_coord_attr'
! Create or check dimension for this coordinate
if (len_trim(hist_coords(mdimind)%dimname) > 0) then
@@ -699,25 +785,40 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
call cam_pio_def_var(File, trim(hist_coords(mdimind)%name), dtype, &
(/dimid/), vardesc, existOK=.false.)
! long_name
- ierr=pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%long_name))
- call cam_pio_handle_error(ierr, 'Error writing "long_name" attr in write_hist_coord_attr')
+ if(len_trim(hist_coords(mdimind)%long_name) > 0) then
+ ierr=pio_put_att(File, vardesc, 'long_name', &
+ trim(hist_coords(mdimind)%long_name))
+ write(errormsg,*) subname, ': Error writing "long_name" attr for variable "', &
+ trim(hist_coords(mdimind)%name), '" (long_name="', &
+ trim(hist_coords(mdimind)%long_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
+ end if
! units
if(len_trim(hist_coords(mdimind)%units) > 0) then
ierr=pio_put_att(File, vardesc, 'units', &
trim(hist_coords(mdimind)%units))
- call cam_pio_handle_error(ierr, 'Error writing "units" attr in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "units" attr for variable "', &
+ trim(hist_coords(mdimind)%name), '" (units="', &
+ trim(hist_coords(mdimind)%units), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! positive
if(len_trim(hist_coords(mdimind)%positive) > 0) then
ierr=pio_put_att(File, vardesc, 'positive', &
trim(hist_coords(mdimind)%positive))
- call cam_pio_handle_error(ierr, 'Error writing "positive" attr in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "positive" attr for variable "', &
+ trim(hist_coords(mdimind)%name), '" (positive="', &
+ trim(hist_coords(mdimind)%positive), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! standard_name
if(len_trim(hist_coords(mdimind)%standard_name) > 0) then
ierr=pio_put_att(File, vardesc, 'standard_name', &
trim(hist_coords(mdimind)%standard_name))
- call cam_pio_handle_error(ierr, 'Error writing "standard_name" attr in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "standard_name" attr for variable "', &
+ trim(hist_coords(mdimind)%name), '" (standard_name="', &
+ trim(hist_coords(mdimind)%standard_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! formula_terms
if(len_trim(hist_coords(mdimind)%formula_terms%a_name) > 0) then
@@ -727,13 +828,19 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
trim(hist_coords(mdimind)%formula_terms%p0_name),&
trim(hist_coords(mdimind)%formula_terms%ps_name)
ierr=pio_put_att(File, vardesc, 'formula_terms', trim(formula_terms))
- call cam_pio_handle_error(ierr, 'Error writing "formula_terms" attr in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "formula_terms" attr for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms="', &
+ trim(formula_terms), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! bounds
if (associated(hist_coords(mdimind)%bounds)) then
! Write name of the bounds variable
ierr=pio_put_att(File, vardesc, 'bounds', trim(hist_coords(mdimind)%bounds_name))
- call cam_pio_handle_error(ierr, 'Error writing "bounds" attr in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "bounds" attr for variable "', &
+ trim(hist_coords(mdimind)%name), '" (bounds_name="', &
+ trim(hist_coords(mdimind)%bounds_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
end if
@@ -741,7 +848,6 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
! NB: Reusing vardesc, no longer assocated with main variable
if (associated(hist_coords(mdimind)%bounds)) then
if (size(hist_coords(mdimind)%bounds,2) /= hist_coords(mdimind)%dimsize) then
- ! If anyone hits this check, add a new dimension for this case
write(errormsg, *) 'The bounds variable, ', &
trim(hist_coords(mdimind)%bounds_name), &
', needs to have dimension (2,', hist_coords(mdimind)%dimsize
@@ -764,7 +870,10 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
call cam_pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%a_name), &
pio_double, (/dimid/), vardesc, existOK=.false.)
ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%a_long_name))
- call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "a" formula_term in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "long_name" attr for "a" formula_term for variable "', &
+ trim(hist_coords(mdimind)%name), '" (a_long_name="', &
+ trim(hist_coords(mdimind)%formula_terms%a_long_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! Define the "b" variable name
! NB: Reusing vardesc, no longer assocated with previous variables
@@ -778,7 +887,10 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
call cam_pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%b_name), &
pio_double, (/dimid/), vardesc, existOK=.false.)
ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%b_long_name))
- call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "b" formula_term in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "long_name" attr for "b" formula_term for variable "', &
+ trim(hist_coords(mdimind)%name), '" (b_long_name="', &
+ trim(hist_coords(mdimind)%formula_terms%b_long_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! Maybe define the p0 variable (this may be defined already which is OK)
! NB: Reusing vardesc, no longer assocated with previous variables
@@ -787,11 +899,20 @@ subroutine write_hist_coord_attr(File, mdimind, boundsdim, dimonly, mdimid)
if (ierr /= PIO_NOERR) then
ierr = pio_def_var(File, trim(hist_coords(mdimind)%formula_terms%p0_name), &
pio_double, vardesc)
- call cam_pio_handle_error(ierr, 'Unable to define "p0" formula_terms variable in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Unable to define "p0" formula_terms variable for "', &
+ trim(hist_coords(mdimind)%name), '" (p0_name="', &
+ trim(hist_coords(mdimind)%formula_terms%p0_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
ierr = pio_put_att(File, vardesc, 'long_name', trim(hist_coords(mdimind)%formula_terms%p0_long_name))
- call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for "p0" formula_term in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "long_name" attr for "p0" formula_term for "', &
+ trim(hist_coords(mdimind)%name), '" (p0_long_name="', &
+ trim(hist_coords(mdimind)%formula_terms%p0_long_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
ierr = pio_put_att(File, vardesc, 'units', trim(hist_coords(mdimind)%formula_terms%p0_units))
- call cam_pio_handle_error(ierr, 'Error writing "units" attr for "p0" formula_term in write_hist_coord_attr')
+ write(errormsg,*) subname, ': Error writing "units" attr for "p0" formula_term for "', &
+ trim(hist_coords(mdimind)%name), '" (p0_units="', &
+ trim(hist_coords(mdimind)%formula_terms%p0_units), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
end if
! PS is not our responsibility
@@ -814,12 +935,14 @@ subroutine write_hist_coord_attrs(File, boundsdim, mdimids, writemdims_in)
pio_bcast_error, pio_internal_error, pio_seterrorhandling, &
pio_char
use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var
+ use cam_pio_utils, only: cam_pio_handle_error
+ use cam_abortutils,only: check_allocate
! Input variables
type(file_desc_t), intent(inout) :: File ! PIO file Handle
integer, intent(in) :: boundsdim ! Bounds dimension ID
- integer, optional, allocatable, intent(out) :: mdimids(:) ! NetCDF dim IDs
logical, optional, intent(in) :: writemdims_in ! Write mdim variable
+ integer, optional, allocatable, intent(out) :: mdimids(:) ! NetCDF dim IDs
! Local variables
integer :: i
@@ -827,9 +950,12 @@ subroutine write_hist_coord_attrs(File, boundsdim, mdimids, writemdims_in)
integer :: dimids(2) ! PIO dimension IDs
logical :: writemdims ! Define an mdim variable
type(var_desc_t) :: vardesc ! PIO variable descriptor
+ character(len=error_msglen) :: errormsg
+ character(len=*), parameter :: subname = 'write_hist_coord_attrs'
if (present(mdimids)) then
- allocate(mdimids(registeredmdims))
+ allocate(mdimids(registeredmdims), stat=ierr)
+ call check_allocate(ierr, subname, 'mdimids', file=__FILE__, line=__LINE__-1)
end if
! We will handle errors for this routine
@@ -861,7 +987,8 @@ subroutine write_hist_coord_attrs(File, boundsdim, mdimids, writemdims_in)
call cam_pio_def_var(File, mdim_var_name, pio_char, dimids, vardesc, &
existOK=.false.)
ierr = pio_put_att(File, vardesc, 'long_name', 'mdim dimension names')
- call cam_pio_handle_error(ierr, 'Error writing "long_name" attr for mdimnames in write_hist_coord_attrs')
+ write(errormsg, *) subname, ': Error writing "long_name" attr for mdimnames"'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! Back to I/O or die trying
@@ -873,6 +1000,8 @@ end subroutine write_hist_coord_attrs
subroutine write_hist_coord_var(File, mdimind)
use pio, only: file_desc_t, var_desc_t, pio_put_var, pio_inq_varid
+ use cam_pio_utils, only: cam_pio_handle_error
+ use string_utils, only: stringify
! Input variables
type(file_desc_t), intent(inout) :: File ! PIO file Handle
@@ -881,6 +1010,8 @@ subroutine write_hist_coord_var(File, mdimind)
! Local variables
type(var_desc_t) :: vardesc ! PIO variable descriptor
integer :: ierr
+ character(len=error_msglen_long) :: errormsg
+ character(len=*), parameter :: subname = 'write_hist_coord_var'
if ((hist_coords(mdimind)%integer_dim .and. &
associated(hist_coords(mdimind)%integer_values)) .or. &
@@ -888,14 +1019,18 @@ subroutine write_hist_coord_var(File, mdimind)
associated(hist_coords(mdimind)%real_values))) then
! Check to make sure the variable already exists in the file
ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%name), vardesc)
- call cam_pio_handle_error(ierr, 'Error writing values for nonexistent dimension variable write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing values for nonexistent dimension variable "', &
+ trim(hist_coords(mdimind)%name), '"'
+ call cam_pio_handle_error(ierr, errormsg)
! Write out the values for this dimension variable
if (hist_coords(mdimind)%integer_dim) then
ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%integer_values)
else
ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%real_values)
end if
- call cam_pio_handle_error(ierr, 'Error writing variable values in write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing variable values for "', &
+ trim(hist_coords(mdimind)%name), '"'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! Now, we need to possibly write values for the associated bounds variable
@@ -903,10 +1038,14 @@ subroutine write_hist_coord_var(File, mdimind)
! Check to make sure the variable already exists in the file
! NB: Reusing vardesc, no longer assocated with previous variables
ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%bounds_name), vardesc)
- call cam_pio_handle_error(ierr, 'Error writing values for nonexistent bounds variable write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing values for nonexistent bounds for variable "', &
+ trim(hist_coords(mdimind)%name), '"'
+ call cam_pio_handle_error(ierr, errormsg)
! Write out the values for this bounds variable
ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%bounds)
- call cam_pio_handle_error(ierr, 'Error writing bounds values in write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing bounds values for "', &
+ trim(hist_coords(mdimind)%name), '"'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! Write values for the "a" variable name
@@ -914,30 +1053,48 @@ subroutine write_hist_coord_var(File, mdimind)
! Check to make sure the variable already exists in the file
! NB: Reusing vardesc, no longer assocated with previous variables
ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%a_name), vardesc)
- call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "a" formula_terms variable write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing values for nonexistent "a" formula_terms for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms%a_name="', &
+ trim(hist_coords(mdimind)%formula_terms%a_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
! Write out the values for this "a" formula_terms variable
ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%a_values)
- call cam_pio_handle_error(ierr, 'Error writing "a" formula_terms values in write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing "a" formula_terms values for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms%a_values="', &
+ stringify(hist_coords(mdimind)%formula_terms%a_values), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
! Write values for the "b" variable name
if (associated(hist_coords(mdimind)%formula_terms%b_values)) then
! Check to make sure the variable already exists in the file
! NB: Reusing vardesc, no longer assocated with previous variables
ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%b_name), vardesc)
- call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "b" formula_terms variable write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing values for nonexistent "b" formula_terms for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms%b_name="', &
+ trim(hist_coords(mdimind)%formula_terms%b_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
! Write out the values for this "b" formula_terms variable
ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%b_values)
- call cam_pio_handle_error(ierr, 'Error writing "b" formula_terms values in write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing "b" formula_terms values for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms%b_values="', &
+ stringify(hist_coords(mdimind)%formula_terms%b_values), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
- ! Write values for the "p0" variable name (this may be an overwrite, too bad
+ ! Write values for the "p0" variable name (this may be an overwrite, too bad)
if (hist_coords(mdimind)%formula_terms%p0_value /= fillvalue) then
! Check to make sure the variable already exists in the file
! NB: Reusing vardesc, no longer assocated with previous variables
ierr = pio_inq_varid(File, trim(hist_coords(mdimind)%formula_terms%p0_name), vardesc)
- call cam_pio_handle_error(ierr, 'Error writing values for nonexistent "p0" formula_terms variable write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing values for nonexistent "p0" formula_terms for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms%p0_name="', &
+ trim(hist_coords(mdimind)%formula_terms%p0_name), '")'
+ call cam_pio_handle_error(ierr, errormsg)
! Write out the values for this "p0" formula_terms variable
ierr = pio_put_var(File, vardesc, hist_coords(mdimind)%formula_terms%p0_value)
- call cam_pio_handle_error(ierr, 'Error writing "p0" formula_terms values in write_hist_coord_var')
+ write(errormsg,*) subname, ': Error writing "p0" formula_terms value for variable "', &
+ trim(hist_coords(mdimind)%name), '" (formula_terms%p0_value="', &
+ stringify((/hist_coords(mdimind)%formula_terms%p0_value/)), '")'
+ call cam_pio_handle_error(ierr, errormsg)
end if
end subroutine write_hist_coord_var
@@ -948,6 +1105,8 @@ subroutine write_hist_coord_vars(File, writemdims_in)
use pio, only: file_desc_t, var_desc_t, pio_put_var, &
pio_bcast_error, pio_internal_error, &
pio_seterrorhandling, pio_inq_varid
+ use cam_pio_utils, only: cam_pio_handle_error
+ use cam_abortutils,only: check_allocate
! Input variables
type(file_desc_t), intent(inout) :: File ! PIO file Handle
@@ -959,6 +1118,7 @@ subroutine write_hist_coord_vars(File, writemdims_in)
logical :: writemdims ! Define an mdim variable
type(var_desc_t) :: vardesc ! PIO variable descriptor
character(len=max_hcoordname_len), allocatable :: mdimnames(:)
+ character(len=*), parameter :: subname = 'write_hist_coord_vars'
! We will handle errors for this routine
call pio_seterrorhandling(File, PIO_BCAST_ERROR)
@@ -970,7 +1130,8 @@ subroutine write_hist_coord_vars(File, writemdims_in)
end if
if (writemdims) then
- allocate(mdimnames(registeredmdims))
+ allocate(mdimnames(registeredmdims), stat=ierr)
+ call check_allocate(ierr, subname, 'mdimnames', file=__FILE__, line=__LINE__-1)
end if
! Write out the variable values for each mdim
@@ -1004,6 +1165,8 @@ end subroutine write_hist_coord_vars
!---------------------------------------------------------------------------
subroutine lookup_hist_coord_indices(mdimnames, mdimindicies)
+ use cam_abortutils, only: endrun
+ use cam_logfile, only: iulog
! Dummy arguments
character(len=*), intent(in) :: mdimnames(:)
integer, intent(out) :: mdimindicies(:)
@@ -1011,8 +1174,7 @@ subroutine lookup_hist_coord_indices(mdimnames, mdimindicies)
! Local variables
integer :: i, j
integer :: cnt
- character(len=120) :: errormsg
- character(len=16) :: name
+ character(len=error_msglen) :: errormsg
cnt = size(mdimnames)
@@ -1020,20 +1182,20 @@ subroutine lookup_hist_coord_indices(mdimnames, mdimindicies)
do j=1,cnt
- name = mdimnames(j)
do i = 1, registeredmdims
- if(name .eq. hist_coords(i)%name) then
+ if(mdimnames(j) == hist_coords(i)%name) then
mdimindicies(j)=i
end if
end do
end do
do j = 1, cnt
if(mdimindicies(j) < 0) then
+ write(iulog,*) 'history coordinate indices and names:'
do i = 1, registeredmdims
- print *,__FILE__,__LINE__,i,hist_coords(i)%name
+ write(iulog,*) i,hist_coords(i)%name
end do
write(errormsg,*) 'Name ',mdimnames(j),' is not a registered history coordinate'
- call endrun(errormsg)
+ call endrun(errormsg, file=__FILE__, line=__LINE__)
end if
end do
@@ -1044,6 +1206,7 @@ end subroutine lookup_hist_coord_indices
! (which is the number of levels). Return -1 if not found
! If dimnames is not present, search all of the registered history coords
integer function hist_coord_find_levels(dimnames) result(levels)
+ use cam_abortutils, only: endrun
! Dummy argument
character(len=*), optional, intent(in) :: dimnames(:)
@@ -1062,7 +1225,7 @@ integer function hist_coord_find_levels(dimnames) result(levels)
if (present(dimnames)) then
index = get_hist_coord_index(trim(dimnames(i)))
if (i < 0) then
- call endrun('hist_coord_find_levels: '//trim(dimnames(i))//' is not a registred history coordinate')
+ call endrun('hist_coord_find_levels: '//trim(dimnames(i))//' is not a registered history coordinate')
end if
else
index = i ! Just cycle through all the registered mdims
@@ -1076,5 +1239,102 @@ integer function hist_coord_find_levels(dimnames) result(levels)
end function hist_coord_find_levels
+ subroutine parse_multiplier(input, multiplier, token, allowed_set, errmsg)
+ use shr_string_mod, only: to_lower => shr_string_toLower
+ ! Parse a character string () to find a token , possibly
+ ! multiplied by an integer ().
+ ! Return values for :
+ ! positive integer: Successful return with and .
+ ! zero: is an empty string
+ ! -1: Error condition (malformed input string)
+ ! Return values for
+ ! On a successful return, will contain with the
+ ! optional multiplier and multiplication symbol removed.
+ ! On an error return, will be an empty string
+ !
+ ! If is present, then must equal a value in
+ ! (case insensitive)
+ ! If is present, it is filled with an error message if
+ ! is not an allowed format.
+ ! Allowed formats are:
+ ! * where is the string representation
+ ! a positive integer.
+ ! in which case is assumed to be one.
+ !
+
+ ! Dummy arguments
+ character(len=*), intent(in) :: input
+ integer, intent(out) :: multiplier
+ character(len=*), intent(out) :: token
+ character(len=*), optional, intent(in) :: allowed_set(:)
+ character(len=*), optional, intent(out) :: errmsg
+ ! Local variables
+ integer :: mult_ind ! Index of multiplication symbol
+ integer :: lind ! Loop index
+ integer :: alen ! Number of entries in
+ integer :: stat ! Read status
+ character(len=error_msglen) :: ioerrmsg ! Read error message
+ logical :: match ! For matching
+ character(len=8) :: fmt_str ! Format string
+
+ ! Initialize output
+ errmsg = ''
+ multiplier = -1
+ token = ''
+ ! Do we have a multipler?
+ mult_ind = index(input, '*')
+ if (len_trim(input) == 0) then
+ multiplier = 0
+ else if (mult_ind <= 0) then
+ multiplier = 1
+ token = trim(input)
+ else
+ write(fmt_str, '(a,i0,a)') "(i", mult_ind - 1, ")"
+ read(input, fmt_str, iostat=stat, iomsg=ioerrmsg) multiplier
+ if (stat == 0) then
+ token = trim(input(mult_ind+1:))
+ else
+ if (present(errmsg)) then
+ write(errmsg, *) "Invalid multiplier, '", &
+ input(1:mult_ind-1), "' in '", trim(input), "'. ", &
+ "Error message from read(): '", trim(ioerrmsg), "'"
+ end if
+ multiplier = -1
+ token = ''
+ end if
+ end if
+
+ if ((multiplier >= 0) .and. present(allowed_set)) then
+ alen = size(allowed_set)
+ match = .false.
+ do lind = 1, alen
+ if (trim(to_lower(token)) == trim(to_lower(allowed_set(lind)))) then
+ match = .true.
+ exit
+ end if
+ end do
+ if (.not. match) then
+ if (present(errmsg)) then
+ write(errmsg, *) "Error, token, '", trim(token), "' not in (/"
+ lind = len_trim(errmsg) + 1
+ do mult_ind = 1, alen
+ if (mult_ind == alen) then
+ fmt_str = "' "
+ else
+ fmt_str = "', "
+ end if
+ write(errmsg(lind:), *) "'", trim(allowed_set(mult_ind)), &
+ trim(fmt_str)
+ lind = lind + len_trim(allowed_set(mult_ind)) + &
+ len_trim(fmt_str) + 2
+ end do
+ write(errmsg(lind:), *) "/)"
+ end if
+ multiplier = -1
+ token = ''
+ end if
+ end if
+
+ end subroutine parse_multiplier
end module cam_history_support
diff --git a/src/physics/ncar_ccpp b/src/physics/ncar_ccpp
index 61bd9d3d..cc42526c 160000
--- a/src/physics/ncar_ccpp
+++ b/src/physics/ncar_ccpp
@@ -1 +1 @@
-Subproject commit 61bd9d3dac2abb11bb1e44a2ca34b401da0f44b1
+Subproject commit cc42526c18763b467e3ab67a5c98d8ff2b40bd39
diff --git a/src/utils/cam_filenames.F90 b/src/utils/cam_filenames.F90
index bcf19d1c..650df98a 100644
--- a/src/utils/cam_filenames.F90
+++ b/src/utils/cam_filenames.F90
@@ -8,12 +8,6 @@ module cam_filenames
! this module is used to determine the names.
use shr_kind_mod, only: cl=>shr_kind_cl
- use time_manager, only: get_curr_date, get_prev_date
- use string_utils, only: to_str
- use spmd_utils, only: masterproc
- use cam_control_mod, only: caseid
- use cam_abortutils, only: endrun
- use cam_logfile, only: iulog
implicit none
private
@@ -26,7 +20,7 @@ module cam_filenames
CONTAINS
!==============================================================================
- character(len=cl) function get_dir(filepath)
+ pure character(len=cl) function get_dir(filepath)
! Return the directory from a filename with a full path
@@ -51,9 +45,14 @@ end function get_dir
character(len=cl) function interpret_filename_spec(filename_spec, unit, accum_type, &
prev, case, instance, yr_spec, mon_spec, day_spec, sec_spec, incomplete_ok)
+ use time_manager, only: get_curr_date, get_prev_date
+ use spmd_utils, only: masterproc
+ use cam_logfile, only: iulog
+ use cam_abortutils, only: endrun
+ use cam_control_mod, only: caseid
! Create a filename from a filename specifier. The
- ! filename specifyer includes codes for setting things such as the
+ ! filename specifier includes codes for setting things such as the
! year, month, day, seconds in day, caseid, and file unit (e.g., h0, i).
!
! Interpret filename specifier string () with:
@@ -135,7 +134,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, accum_ty
end if
end if ! No else, do not use these quantities below.
!
- ! Go through each character in the filename specifyer and interpret
+ ! Go through each character in the filename specifier and interpret
! if it is a format specifier
!
indx = 1
@@ -240,16 +239,13 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, accum_ty
if (next == 0) then
next = len_trim(filename_spec(indx:)) + 1
end if
- if (next == 0) then
- exit
- end if
string = filename_spec(indx:next+indx-2)
indx = next + indx - 2
end if
if (len_trim(interpret_filename_spec) == 0) then
interpret_filename_spec = trim(string)
else
- if ((len_trim(interpret_filename_spec)+len_trim(string)) >= cl) then
+ if ((len_trim(interpret_filename_spec)+len_trim(string)) > cl) then
call endrun(subname// &
"Resultant filename too long, trying to add: '"// &
trim(string)//"' to '"//trim(interpret_filename_spec)//"'")
@@ -259,7 +255,7 @@ character(len=cl) function interpret_filename_spec(filename_spec, unit, accum_ty
indx = indx + 1
end do
if (len_trim(interpret_filename_spec) == 0) then
- call endrun(subname//"Resulting filename is empty")
+ call endrun(subname//"Resulting filename is empty. Filename spec: "//trim(filename_spec))
end if
end function interpret_filename_spec
diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90
index 38423a67..1e4fc966 100644
--- a/src/utils/cam_grid_support.F90
+++ b/src/utils/cam_grid_support.F90
@@ -2,6 +2,7 @@ module cam_grid_support
use shr_kind_mod, only: r8=>shr_kind_r8, r4=>shr_kind_r4
use shr_kind_mod, only: i8=>shr_kind_i8, i4=>shr_kind_i4
use shr_kind_mod, only: max_chars=>shr_kind_cl
+ use shr_kind_mod, only: shr_kind_cm
use shr_sys_mod, only: shr_sys_flush
use cam_map_utils, only: iMap
use pio, only: var_desc_t
@@ -164,7 +165,7 @@ module cam_grid_support
type(horiz_coord_t), pointer :: lon_coord => NULL() ! Longitude
logical :: unstructured ! Is this needed?
logical :: block_indexed ! .false. for lon/lat
- logical :: attrs_defined(2) = .false.
+ logical :: attrs_defined(max_split_files) = .false.
logical :: zonal_grid = .false.
type(cam_filemap_t), pointer :: map => null() ! global dim map (dof)
type(cam_grid_attr_ptr_t), pointer :: attributes => NULL()
@@ -273,8 +274,6 @@ module cam_grid_support
!---------------------------------------------------------------------------
! Abstract interface for write_attr procedure of cam_grid_attribute_t class
- ! NB: This will not compile on some pre-13 Intel compilers
- ! (fails on 12.1.0.233 on Frankfurt, passes on 13.0.1.117 on Yellowstone)
abstract interface
subroutine write_cam_grid_attr(attr, File, file_index)
use pio, only: file_desc_t
@@ -477,6 +476,7 @@ end subroutine horiz_coord_units
function horiz_coord_create(name, dimname, dimsize, long_name, units, &
lbound, ubound, values, map, bnds) result(newcoord)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
character(len=*), intent(in) :: name
@@ -491,8 +491,12 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, &
integer(iMap), intent(in), optional :: map(ubound-lbound+1)
real(r8), intent(in), optional :: bnds(2,lbound:ubound)
type(horiz_coord_t), pointer :: newcoord
+ ! Local variables
+ integer :: ierr
+ character(len=*), parameter :: subname = 'horiz_coord_create'
- allocate(newcoord)
+ allocate(newcoord, stat=ierr)
+ call check_allocate(ierr, subname, 'newcoord', file=__FILE__, line=__LINE__-1)
newcoord%name = trim(name)
newcoord%dimname = trim(dimname)
@@ -519,7 +523,8 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, &
else
call endrun("horiz_coord_create: unsupported units: '"//trim(units)//"'")
end if
- allocate(newcoord%values(lbound:ubound))
+ allocate(newcoord%values(lbound:ubound), stat=ierr)
+ call check_allocate(ierr, subname, 'newcoord%values', file=__FILE__, line=__LINE__-1)
if (ubound >= lbound) then
newcoord%values(:) = values(:)
end if
@@ -528,7 +533,8 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, &
if (ANY(map < 0)) then
call endrun("horiz_coord_create "//trim(name)//": map vals < 0")
end if
- allocate(newcoord%map(ubound - lbound + 1))
+ allocate(newcoord%map(ubound - lbound + 1), stat=ierr)
+ call check_allocate(ierr, subname, 'newcoord%map', file=__FILE__, line=__LINE__-1)
if (ubound >= lbound) then
newcoord%map(:) = map(:)
end if
@@ -537,7 +543,8 @@ function horiz_coord_create(name, dimname, dimsize, long_name, units, &
end if
if (present(bnds)) then
- allocate(newcoord%bnds(2, lbound:ubound))
+ allocate(newcoord%bnds(2, lbound:ubound), stat=ierr)
+ call check_allocate(ierr, subname, 'newcoord%bnds', file=__FILE__, line=__LINE__-1)
if (ubound >= lbound) then
newcoord%bnds = bnds
end if
@@ -560,6 +567,7 @@ subroutine write_horiz_coord_attr(this, File, dimid_out, file_index)
use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_double
use pio, only: pio_bcast_error, pio_seterrorhandling, pio_inq_varid
use cam_pio_utils, only: cam_pio_def_dim, cam_pio_def_var
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(horiz_coord_t), intent(inout) :: this
@@ -575,6 +583,7 @@ subroutine write_horiz_coord_attr(this, File, dimid_out, file_index)
integer :: err_handling
integer :: ierr
integer :: file_index_loc
+ character(len=*), parameter :: subname = 'write_horiz_coord_attr'
! We will handle errors for this routine
call pio_seterrorhandling(File, PIO_BCAST_ERROR, oldmethod=err_handling)
@@ -595,54 +604,59 @@ subroutine write_horiz_coord_attr(this, File, dimid_out, file_index)
! Variable not already defined, we need to define the variable
if (associated(this%vardesc(file_index_loc)%p)) then
! This should not happen (i.e., internal error)
- call endrun('write_horiz_coord_attr: vardesc already allocated for '//trim(dimname))
+ call endrun(subname//' vardesc already allocated for '//trim(dimname))
end if
- allocate(this%vardesc(file_index_loc)%p)
+ allocate(this%vardesc(file_index_loc)%p, stat=ierr)
+ call check_allocate(ierr, subname, 'this%vardesc(file_index_loc)%p', &
+ file=__FILE__, line=__LINE__-1)
call cam_pio_def_var(File, trim(this%name), pio_double, &
(/ dimid /), this%vardesc(file_index_loc)%p, existOK=.false.)
ierr= pio_put_att(File, this%vardesc(file_index_loc)%p, &
'_FillValue', grid_fill_value)
call cam_pio_handle_error(ierr, &
- 'Error writing "_FillValue" attr in write_horiz_coord_attr')
+ 'Error writing "_FillValue" attr in '//subname)
! long_name
ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'long_name', &
trim(this%long_name))
call cam_pio_handle_error(ierr, &
- 'Error writing "long_name" attr in write_horiz_coord_attr')
+ 'Error writing "long_name" attr in '//subname)
! units
ierr=pio_put_att(File, this%vardesc(file_index_loc)%p, 'units', &
trim(this%units))
call cam_pio_handle_error(ierr, &
- 'Error writing "units" attr in write_horiz_coord_attr')
+ 'Error writing "units" attr in '//subname)
! Take care of bounds if they exist
if (associated(this%bnds)) then
- allocate(this%bndsvdesc(file_index_loc)%p)
+ allocate(this%bndsvdesc(file_index_loc)%p, stat=ierr)
+ call check_allocate(ierr, subname, &
+ 'this%bndsvdesc(file_index_loc)%p', file=__FILE__, &
+ line=__LINE__-1)
ierr = pio_put_att(File, this%vardesc(file_index_loc)%p, 'bounds',&
trim(this%name)//'_bnds')
call cam_pio_handle_error(ierr, &
- 'Error writing "'//trim(this%name)//'_bnds" attr in write_horiz_coord_attr')
+ 'Error writing "'//trim(this%name)//'_bnds" attr in '//subname)
call cam_pio_def_dim(File, 'nbnd', 2, bnds_dimid, existOK=.true.)
call cam_pio_def_var(File, &
trim(this%name)//'_bnds', pio_double, &
(/ bnds_dimid, dimid /), this%bndsvdesc(file_index_loc)%p, &
existOK=.false.)
call cam_pio_handle_error(ierr, &
- 'Error defining "'//trim(this%name)//'bnds" in write_horiz_coord_attr')
+ 'Error defining "'//trim(this%name)//'_bnds" in '//subname)
! long_name
ierr = pio_put_att(File, this%bndsvdesc(file_index_loc)%p, &
'long_name', trim(this%name)//' bounds')
call cam_pio_handle_error(ierr, &
- 'Error writing bounds "long_name" attr in write_horiz_coord_attr')
+ 'Error writing bounds "long_name" attr in '//subname)
! fill value
ierr = pio_put_att(File, this%vardesc(file_index_loc)%p, &
'_FillValue', grid_fill_value)
call cam_pio_handle_error(ierr, &
- 'Error writing "_FillValue" attr in write_horiz_coord_attr')
+ 'Error writing "_FillValue" attr in '//subname)
! units
ierr = pio_put_att(File, this%bndsvdesc(file_index_loc)%p, &
'units', trim(this%units))
call cam_pio_handle_error(ierr, &
- 'Error writing bounds "units" attr in write_horiz_coord_attr')
+ 'Error writing bounds "units" attr in '//subname)
end if ! There are bounds for this coordinate
end if ! We define the variable
@@ -679,7 +693,7 @@ subroutine write_horiz_coord_var(this, File, file_index)
integer, optional, intent(in) :: file_index
! Local variables
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: ierr
integer :: ldims(1)
integer :: fdims(1)
@@ -861,6 +875,7 @@ end function num_cam_grid_attrs
subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, &
unstruct, block_indexed, zonal_grid, src_in, dest_in)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
character(len=*), intent(in) :: name
integer, intent(in) :: id
@@ -875,9 +890,10 @@ subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, &
! Local variables
character(len=max_hcoordname_len) :: latdimname, londimname
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: i
integer :: src(2), dest(2)
+ integer :: ierr
character(len=*), parameter :: subname = 'CAM_GRID_REGISTER'
! For a values grid, we do not allow multiple calls
@@ -950,7 +966,9 @@ subroutine cam_grid_register(name, id, lat_coord, lon_coord, map, &
dest(2) = 2
end if
end if
- allocate(cam_grids(registeredhgrids)%map)
+ allocate(cam_grids(registeredhgrids)%map, stat=ierr)
+ call check_allocate(ierr, subname, 'cam_grids(registeredhgrids)%map',&
+ file=__FILE__, line=__LINE__-1)
call cam_grids(registeredhgrids)%map%init(map, &
cam_grids(registeredhgrids)%unstructured, src, dest)
call cam_grids(registeredhgrids)%print_cam_grid()
@@ -1024,7 +1042,7 @@ integer function cam_grid_get_local_size(id, nlev)
! Local variables
integer :: gridid
- character(len=128) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1051,7 +1069,7 @@ subroutine cam_grid_get_file_dimids(id, File, dimids)
! Local variables
integer :: gridid
- character(len=128) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1081,7 +1099,7 @@ subroutine cam_grid_get_decomp(id, field_lens, file_lens, dtype, &
! Local variables
integer :: gridid
- character(len=128) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1115,7 +1133,7 @@ subroutine cam_grid_read_dist_array_2d_int(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1150,7 +1168,7 @@ subroutine cam_grid_read_dist_array_3d_int(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1185,7 +1203,7 @@ subroutine cam_grid_read_dist_array_2d_double(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1220,7 +1238,7 @@ subroutine cam_grid_read_dist_array_3d_double(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1255,7 +1273,7 @@ subroutine cam_grid_read_dist_array_2d_real(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1290,7 +1308,7 @@ subroutine cam_grid_read_dist_array_3d_real(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1325,7 +1343,7 @@ subroutine cam_grid_write_dist_array_2d_int(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1360,7 +1378,7 @@ subroutine cam_grid_write_dist_array_3d_int(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1395,7 +1413,7 @@ subroutine cam_grid_write_dist_array_1d_double(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1430,7 +1448,7 @@ subroutine cam_grid_write_dist_array_2d_double(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1465,7 +1483,7 @@ subroutine cam_grid_write_dist_array_3d_double(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1500,7 +1518,7 @@ subroutine cam_grid_write_dist_array_1d_real(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1535,7 +1553,7 @@ subroutine cam_grid_write_dist_array_2d_real(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1570,7 +1588,7 @@ subroutine cam_grid_write_dist_array_3d_real(File, id, adims, fdims, &
! Local variable
integer :: gridid
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridid = get_cam_grid_index(id)
if (gridid > 0) then
@@ -1701,7 +1719,7 @@ subroutine cam_grid_get_dim_names_name(gridname, name1, name2)
! Local variables
integer :: gridind
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridind = get_cam_grid_index(trim(gridname))
if (gridind < 0) then
@@ -1966,6 +1984,7 @@ end subroutine print_attr_0d_char
subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, &
dimsize, values, map)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_attribute_1d_int_t) :: this
character(len=*), intent(in) :: name
@@ -1974,6 +1993,9 @@ subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, &
integer, intent(in) :: dimsize
integer, target, intent(in) :: values(:)
integer(iMap), optional, target, intent(in) :: map(:)
+ ! Local variables
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_attr_init_1d_int'
! call this%cam_grid_attr_init(trim(name), trim(long_name))
if (len_trim(name) > max_hcoordname_len) then
@@ -1993,7 +2015,8 @@ subroutine cam_grid_attr_init_1d_int(this, name, long_name, dimname, &
this%values => values
! Fill in the optional map
if (present(map)) then
- allocate(this%map(size(map)))
+ allocate(this%map(size(map)), stat=ierr)
+ call check_allocate(ierr, subname, 'this%map', file=__FILE__, line=__LINE__-1)
this%map(:) = map(:)
else
nullify(this%map)
@@ -2002,6 +2025,7 @@ end subroutine cam_grid_attr_init_1d_int
subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, &
dimsize, values, map)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_attribute_1d_r8_t) :: this
character(len=*), intent(in) :: name
@@ -2010,6 +2034,9 @@ subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, &
integer, intent(in) :: dimsize
real(r8), target, intent(in) :: values(:)
integer(iMap), optional, target, intent(in) :: map(:)
+ ! Local variables
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_attr_init_1d_r8'
! call this%cam_grid_attr_init(trim(name), trim(long_name), next)
this%name = trim(name)
@@ -2020,7 +2047,8 @@ subroutine cam_grid_attr_init_1d_r8(this, name, long_name, dimname, &
this%values => values
! Fill in the optional map
if (present(map)) then
- allocate(this%map(size(map)))
+ allocate(this%map(size(map)), stat=ierr)
+ call check_allocate(ierr, subname, 'this%map', file=__FILE__, line=__LINE__-1)
this%map(:) = map(:)
else
nullify(this%map)
@@ -2046,13 +2074,17 @@ subroutine print_attr_1d_r8(this)
end subroutine print_attr_1d_r8
subroutine insert_grid_attribute(gridind, attr)
+ use cam_abortutils, only: check_allocate
integer, intent(in) :: gridind
class(cam_grid_attribute_t), pointer :: attr
! Push a new attribute onto the grid
type(cam_grid_attr_ptr_t), pointer :: attrPtr
+ integer :: ierr
+ character(len=*), parameter :: subname = 'insert_grid_attribute'
- allocate(attrPtr)
+ allocate(attrPtr, stat=ierr)
+ call check_allocate(ierr, subname, 'attrPtr', file=__FILE__, line=__LINE__-1)
call attrPtr%initialize(attr)
call attrPtr%setNext(cam_grids(gridind)%attributes)
cam_grids(gridind)%attributes => attrPtr
@@ -2060,6 +2092,7 @@ subroutine insert_grid_attribute(gridind, attr)
end subroutine insert_grid_attribute
subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
character(len=*), intent(in) :: gridname
character(len=*), intent(in) :: name
@@ -2069,8 +2102,10 @@ subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val)
! Local variables
type(cam_grid_attribute_0d_int_t), pointer :: attr
class(cam_grid_attribute_t), pointer :: attptr
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: gridind
+ integer :: ierr
+ character(len=*), parameter :: subname = 'add_cam_grid_attribute_0d_int'
gridind = get_cam_grid_index(trim(gridname))
if (gridind > 0) then
@@ -2083,7 +2118,9 @@ subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val)
call endrun(errormsg)
else
! Need a new attribute.
- allocate(attr)
+ allocate(attr, stat=ierr)
+ call check_allocate(ierr, subname, 'attr', file=__FILE__, &
+ line=__LINE__-1)
call attr%cam_grid_attr_init_0d_int(trim(name), &
trim(long_name), val)
attptr => attr
@@ -2098,6 +2135,7 @@ subroutine add_cam_grid_attribute_0d_int(gridname, name, long_name, val)
end subroutine add_cam_grid_attribute_0d_int
subroutine add_cam_grid_attribute_0d_char(gridname, name, val)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
character(len=*), intent(in) :: gridname
character(len=*), intent(in) :: name
@@ -2106,8 +2144,10 @@ subroutine add_cam_grid_attribute_0d_char(gridname, name, val)
! Local variables
type(cam_grid_attribute_0d_char_t), pointer :: attr
class(cam_grid_attribute_t), pointer :: attptr
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: gridind
+ integer :: ierr
+ character(len=*), parameter :: subname = 'add_cam_grid_attribute_0d_char'
gridind = get_cam_grid_index(trim(gridname))
if (gridind > 0) then
@@ -2120,7 +2160,9 @@ subroutine add_cam_grid_attribute_0d_char(gridname, name, val)
call endrun(errormsg)
else
! Need a new attribute.
- allocate(attr)
+ allocate(attr, stat=ierr)
+ call check_allocate(ierr, subname, 'attr', file=__FILE__, &
+ line=__LINE__-1)
call attr%cam_grid_attr_init_0d_char(trim(name), '', val)
attptr => attr
call insert_grid_attribute(gridind, attptr)
@@ -2135,6 +2177,7 @@ end subroutine add_cam_grid_attribute_0d_char
subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, &
dimname, values, map)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
character(len=*), intent(in) :: gridname
character(len=*), intent(in) :: name
@@ -2146,9 +2189,11 @@ subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, &
! Local variables
type(cam_grid_attribute_1d_int_t), pointer :: attr
class(cam_grid_attribute_t), pointer :: attptr
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: gridind
integer :: dimsize
+ integer :: ierr
+ character(len=*), parameter :: subname = 'add_cam_grid_attribute_1d_int'
nullify(attr)
nullify(attptr)
@@ -2174,7 +2219,9 @@ subroutine add_cam_grid_attribute_1d_int(gridname, name, long_name, &
', not found'
call endrun(errormsg)
end if
- allocate(attr)
+ allocate(attr, stat=ierr)
+ call check_allocate(ierr, subname, 'attr', file=__FILE__, &
+ line=__LINE__-1)
call attr%cam_grid_attr_init_1d_int(trim(name), &
trim(long_name), trim(dimname), dimsize, values, map)
attptr => attr
@@ -2190,6 +2237,7 @@ end subroutine add_cam_grid_attribute_1d_int
subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, &
dimname, values, map)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
character(len=*), intent(in) :: gridname
character(len=*), intent(in) :: name
@@ -2201,9 +2249,11 @@ subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, &
! Local variables
type(cam_grid_attribute_1d_r8_t), pointer :: attr
class(cam_grid_attribute_t), pointer :: attptr
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: gridind
integer :: dimsize
+ integer :: ierr
+ character(len=*), parameter :: subname = 'add_cam_grid_attribute_1d_r8'
gridind = get_cam_grid_index(trim(gridname))
if (gridind > 0) then
@@ -2227,7 +2277,9 @@ subroutine add_cam_grid_attribute_1d_r8(gridname, name, long_name, &
', not found'
call endrun(errormsg)
end if
- allocate(attr)
+ allocate(attr, stat=ierr)
+ call check_allocate(ierr, subname, 'attr', file=__FILE__, &
+ line=__LINE__-1)
call attr%cam_grid_attr_init_1d_r8(trim(name), &
trim(long_name), trim(dimname), dimsize, values, map)
attptr => attr
@@ -2302,6 +2354,7 @@ subroutine write_cam_grid_attr_0d_int(attr, File, file_index)
use pio, only: file_desc_t, pio_put_att, pio_noerr, pio_int, &
pio_inq_att, PIO_GLOBAL
use cam_pio_utils, only: cam_pio_def_var
+ use cam_abortutils,only: check_allocate
! Dummy arguments
class(cam_grid_attribute_0d_int_t), intent(inout) :: attr
@@ -2328,7 +2381,9 @@ subroutine write_cam_grid_attr_0d_int(attr, File, file_index)
! This 0d attribute is a scalar variable with a
! long_name attribute
! First, define the variable
- allocate(attr%vardesc(file_index_loc)%p)
+ allocate(attr%vardesc(file_index_loc)%p, stat=ierr)
+ call check_allocate(ierr, subname, 'attr%vardesc(file_index_loc)%p', &
+ file=__FILE__, line=__LINE__-1)
call cam_pio_def_var(File, trim(attr%name), pio_int, &
attr%vardesc(file_index_loc)%p, existOK=.false.)
ierr= pio_put_att(File, attr%vardesc(file_index_loc)%p, &
@@ -2414,6 +2469,7 @@ subroutine write_cam_grid_attr_1d_int(attr, File, file_index)
use pio, only: file_desc_t, pio_put_att, pio_noerr
use pio, only: pio_inq_dimid, pio_int
use cam_pio_utils, only: cam_pio_def_var
+ use cam_abortutils,only: check_allocate
! Dummy arguments
class(cam_grid_attribute_1d_int_t), intent(inout) :: attr
@@ -2422,7 +2478,7 @@ subroutine write_cam_grid_attr_1d_int(attr, File, file_index)
! Local variables
integer :: dimid ! PIO dimension ID
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: ierr
integer :: file_index_loc
character(len=*), parameter :: subname = 'write_cam_grid_attr_1d_int'
@@ -2446,7 +2502,9 @@ subroutine write_cam_grid_attr_1d_int(attr, File, file_index)
call endrun(errormsg)
end if
! Time to define the variable
- allocate(attr%vardesc(file_index_loc)%p)
+ allocate(attr%vardesc(file_index_loc)%p, stat=ierr)
+ call check_allocate(ierr, subname, 'attr%vardesc(file_index_loc)%p', &
+ file=__FILE__, line=__LINE__-1)
call cam_pio_def_var(File, trim(attr%name), pio_int, (/dimid/), &
attr%vardesc(file_index_loc)%p, existOK=.false.)
ierr = pio_put_att(File, attr%vardesc(file_index_loc)%p, &
@@ -2473,6 +2531,7 @@ subroutine write_cam_grid_attr_1d_r8(attr, File, file_index)
use pio, only: file_desc_t, pio_put_att, pio_noerr
use pio, only: pio_double, pio_inq_dimid
use cam_pio_utils, only: cam_pio_def_var
+ use cam_abortutils,only: check_allocate
! Dummy arguments
class(cam_grid_attribute_1d_r8_t), intent(inout) :: attr
@@ -2481,7 +2540,7 @@ subroutine write_cam_grid_attr_1d_r8(attr, File, file_index)
! Local variables
integer :: dimid ! PIO dimension ID
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: ierr
integer :: file_index_loc
character(len=*), parameter :: subname = 'write_cam_grid_attr_1d_r8'
@@ -2505,7 +2564,9 @@ subroutine write_cam_grid_attr_1d_r8(attr, File, file_index)
call endrun(errormsg)
end if
! Time to define the variable
- allocate(attr%vardesc(file_index_loc)%p)
+ allocate(attr%vardesc(file_index_loc)%p, stat=ierr)
+ call check_allocate(ierr, subname, 'attr%vardesc(file_index_loc)%p', &
+ file=__FILE__, line=__LINE__-1)
call cam_pio_def_var(File, trim(attr%name), pio_double, &
(/dimid/), attr%vardesc(file_index_loc)%p, existOK=.false.)
! fill value
@@ -2536,7 +2597,7 @@ subroutine cam_grid_attribute_copy(src_grid, dest_grid, attribute_name)
character(len=*), intent(in) :: attribute_name
! Local variables
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: src_ind, dest_ind
class(cam_grid_attribute_t), pointer :: attr
@@ -2576,6 +2637,7 @@ end subroutine cam_grid_attribute_copy
subroutine cam_grid_write_attr(File, grid_id, header_info, file_index)
use pio, only: file_desc_t, PIO_BCAST_ERROR, pio_seterrorhandling
use pio, only: pio_inq_dimid
+ use cam_abortutils, only: check_allocate
! Dummy arguments
type(file_desc_t), intent(inout) :: File ! PIO file Handle
@@ -2590,6 +2652,8 @@ subroutine cam_grid_write_attr(File, grid_id, header_info, file_index)
integer :: dimids(2)
integer :: err_handling
integer :: file_index_loc
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_write_attr'
if (present(file_index)) then
file_index_loc = file_index
@@ -2619,10 +2683,14 @@ subroutine cam_grid_write_attr(File, grid_id, header_info, file_index)
! We need to fill out the hdims info for this grid
call cam_grids(gridind)%find_dimids(File, dimids)
if (dimids(2) < 0) then
- allocate(header_info%hdims(1))
+ allocate(header_info%hdims(1), stat=ierr)
+ call check_allocate(ierr, subname, 'header_info%hdims', &
+ file=__FILE__, line=__LINE__-1)
header_info%hdims(1) = dimids(1)
else
- allocate(header_info%hdims(2))
+ allocate(header_info%hdims(2), stat=ierr)
+ call check_allocate(ierr, subname, 'header_info%hdims', &
+ file=__FILE__, line=__LINE__-1)
header_info%hdims(1:2) = dimids(1:2)
end if
else
@@ -2634,9 +2702,13 @@ subroutine cam_grid_write_attr(File, grid_id, header_info, file_index)
file_index=file_index_loc)
if (dimids(2) == dimids(1)) then
- allocate(header_info%hdims(1))
+ allocate(header_info%hdims(1), stat=ierr)
+ call check_allocate(ierr, subname, 'header_info%hdims', &
+ file=__FILE__, line=__LINE__-1)
else
allocate(header_info%hdims(2))
+ call check_allocate(ierr, subname, 'header_info%hdims', &
+ file=__FILE__, line=__LINE__-1)
header_info%hdims(2) = dimids(2)
end if
header_info%hdims(1) = dimids(1)
@@ -2940,7 +3012,7 @@ subroutine cam_grid_dimensions_id(gridid, dims, rank)
! Local variables
integer :: index
character(len=max_hcoordname_len) :: dname1, dname2
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
index = get_cam_grid_index(gridid)
if (index < 0) then
@@ -2976,7 +3048,7 @@ subroutine cam_grid_dimensions_name(gridname, dims, rank)
! Local variables
integer :: gridind
character(len=max_hcoordname_len) :: dname1, dname2
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
gridind = get_cam_grid_index(trim(gridname))
if (gridind < 0) then
@@ -3005,6 +3077,7 @@ end subroutine cam_grid_dimensions_name
subroutine cam_grid_set_map(this, map, src, dest)
use spmd_utils, only: mpicom
use mpi, only: mpi_sum, mpi_integer
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_t) :: this
integer(iMap), pointer :: map(:,:)
@@ -3015,6 +3088,7 @@ subroutine cam_grid_set_map(this, map, src, dest)
integer :: dims(2)
integer :: dstrt, dend
integer :: gridlen, gridloc, ierr
+ character(len=*), parameter :: subname = 'cam_grid_set_map'
! Check to make sure the map meets our needs
call this%coord_lengths(dims)
@@ -3042,7 +3116,9 @@ subroutine cam_grid_set_map(this, map, src, dest)
call endrun('cam_grid_set_map: Bad map size for '//trim(this%name))
else
if (.not. associated(this%map)) then
- allocate(this%map)
+ allocate(this%map, stat=ierr)
+ call check_allocate(ierr, subname, 'this%map', &
+ file=__FILE__, line=__LINE__-1)
end if
call this%map%init(map, this%unstructured, src, dest)
end if
@@ -3059,7 +3135,7 @@ integer function cam_grid_local_size(this)
class(cam_grid_t) :: this
! Local variable
- character(len=128) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
if (.not. associated(this%map)) then
write(errormsg, *) 'Grid, '//trim(this%name)//', has no map'
@@ -3120,6 +3196,7 @@ end subroutine cam_grid_get_lon_lat
!
!------------------------------------------------------------------------
subroutine cam_grid_find_src_dims(this, field_dnames, src_out)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_t) :: this
character(len=*), intent(in) :: field_dnames(:)
@@ -3129,6 +3206,8 @@ subroutine cam_grid_find_src_dims(this, field_dnames, src_out)
integer :: i, j
integer :: num_coords
character(len=max_hcoordname_len) :: coord_dimnames(2)
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_find_src_dims'
call this%dim_names(coord_dimnames(1), coord_dimnames(2))
if (associated(src_out)) then
@@ -3140,7 +3219,9 @@ subroutine cam_grid_find_src_dims(this, field_dnames, src_out)
else
num_coords = 2
end if
- allocate(src_out(2)) ! Currently, all cases have two source dims
+ allocate(src_out(2), stat=ierr) ! Currently, all cases have two source dims
+ call check_allocate(ierr, subname, 'src_out', file=__FILE__, line=__LINE__-1)
+
do i = 1, num_coords
do j = 1, size(field_dnames)
if (trim(field_dnames(j)) == trim(coord_dimnames(i))) then
@@ -3160,6 +3241,7 @@ end subroutine cam_grid_find_src_dims
!
!------------------------------------------------------------------------
subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_t) :: this
character(len=*), intent(in) :: file_dnames(:)
@@ -3169,6 +3251,8 @@ subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out)
integer :: i, j
integer :: num_coords
character(len=max_hcoordname_len) :: coord_dimnames(2)
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_find_dest_dims'
call this%dim_names(coord_dimnames(1), coord_dimnames(2))
if (associated(dest_out)) then
@@ -3180,7 +3264,8 @@ subroutine cam_grid_find_dest_dims(this, file_dnames, dest_out)
else
num_coords = 2
end if
- allocate(dest_out(num_coords))
+ allocate(dest_out(num_coords), stat=ierr)
+ call check_allocate(ierr, subname, 'dest_out', file=__FILE__, line=__LINE__-1)
dest_out = 0
do i = 1, num_coords
do j = 1, size(file_dnames)
@@ -3201,6 +3286,7 @@ subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, &
iodesc, field_dnames, file_dnames)
use pio, only: io_desc_t
use cam_pio_utils, only: cam_pio_get_decomp, calc_permutation
+ use cam_abortutils,only: check_allocate
! Dummy arguments
class(cam_grid_t) :: this
@@ -3216,7 +3302,9 @@ subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, &
integer, pointer :: dest_in(:)
integer, allocatable :: permutation(:)
logical :: is_perm
- character(len=128) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_get_pio_decomp'
nullify(src_in)
nullify(dest_in)
@@ -3235,6 +3323,8 @@ subroutine cam_grid_get_pio_decomp(this, field_lens, file_lens, dtype, &
! This only works if the arrays are the same size
if (size(file_dnames) == size(field_dnames)) then
allocate(permutation(size(file_dnames)))
+ call check_allocate(ierr, subname, 'permutation', &
+ file=__FILE__, line=__LINE__-1)
call calc_permutation(file_dnames, field_dnames, &
permutation, is_perm)
end if
@@ -3741,6 +3831,7 @@ subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco)
use spmd_utils, only: mpicom
use mpi, only: mpi_min, mpi_max, mpi_real8
use shr_const_mod, only: pi=>shr_const_pi
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_t) :: this
@@ -3808,23 +3899,35 @@ subroutine cam_grid_get_patch_mask(this, lonl, lonu, latl, latu, patch, cco)
if (cco) then
! For collected column output, we need to collect
! coordinates and values
- allocate(patch%latmap(patch%mask%num_elem()))
+ allocate(patch%latmap(patch%mask%num_elem()), stat=ierr)
+ call check_allocate(ierr, subname, 'patch%latmap', file=__FILE__, &
+ line=__LINE__-1)
patch%latmap = 0
- allocate(patch%latvals(patch%mask%num_elem()))
+ allocate(patch%latvals(patch%mask%num_elem()), stat=ierr)
+ call check_allocate(ierr, subname, 'patch%latvals', file=__FILE__, &
+ line=__LINE__-1)
patch%latvals = 91.0_r8
- allocate(patch%lonmap(patch%mask%num_elem()))
+ allocate(patch%lonmap(patch%mask%num_elem()), stat=ierr)
+ call check_allocate(ierr, subname, 'patch%lonmap', file=__FILE__, &
+ line=__LINE__-1)
patch%lonmap = 0
- allocate(patch%lonvals(patch%mask%num_elem()))
+ allocate(patch%lonvals(patch%mask%num_elem()), stat=ierr)
+ call check_allocate(ierr, subname, 'patch%lonvals', file=__FILE__, &
+ line=__LINE__-1)
patch%lonvals = 361.0_r8
else
if (associated(this%lat_coord%values)) then
- allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1)))
+ allocate(patch%latmap(LBOUND(this%lat_coord%values, 1):UBOUND(this%lat_coord%values, 1)), stat=ierr)
+ call check_allocate(ierr, subname, 'patch%latmap', file=__FILE__, &
+ line=__LINE__-1)
patch%latmap = 0
else
nullify(patch%latmap)
end if
if (associated(this%lon_coord%values)) then
- allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1)))
+ allocate(patch%lonmap(LBOUND(this%lon_coord%values, 1):UBOUND(this%lon_coord%values, 1)), stat=ierr)
+ call check_allocate(ierr, subname, 'patch%lonmap', file=__FILE__, &
+ line=__LINE__-1)
patch%lonmap = 0
else
nullify(patch%lonmap)
@@ -4131,7 +4234,7 @@ subroutine cam_grid_patch_get_axis_names(this, lat_name, lon_name, &
! Local variable
integer :: index
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
character(len=max_hcoordname_len) :: grid_name
logical :: unstruct
@@ -4168,7 +4271,7 @@ subroutine cam_grid_patch_get_coord_long_name(this, axis, name)
character(len=*), intent(out) :: name
! Local variable
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: index
if (cam_grid_check(this%grid_id)) then
@@ -4196,7 +4299,7 @@ subroutine cam_grid_patch_get_coord_units(this, axis, units)
character(len=*), intent(out) :: units
! Local variable
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
integer :: index
if (cam_grid_check(this%grid_id)) then
@@ -4218,6 +4321,7 @@ end subroutine cam_grid_patch_get_coord_units
subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, &
id, map)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_patch_t) :: this
@@ -4227,6 +4331,10 @@ subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, &
integer, intent(in) :: id
type(cam_filemap_t), intent(in) :: map
+ ! Local variables
+ integer :: ierr
+ character(len=*), parameter :: subname = 'cam_grid_patch_set_patch'
+
this%grid_id = id
this%lon_range(1) = lonl
this%lon_range(2) = lonu
@@ -4234,7 +4342,9 @@ subroutine cam_grid_patch_set_patch(this, lonl, lonu, latl, latu, cco, &
this%lat_range(2) = latu
this%collected_columns = cco
if (.not. associated(this%mask)) then
- allocate(this%mask)
+ allocate(this%mask, stat=ierr)
+ call check_allocate(ierr, subname, 'this%mask', file=__FILE__, &
+ line=__LINE__-1)
end if
call this%mask%copy(map)
call this%mask%new_index()
@@ -4309,6 +4419,7 @@ subroutine cam_grid_patch_write_vals(this, File, header_info)
use pio, only: pio_write_darray, PIO_DOUBLE
use pio, only: pio_freedecomp
use cam_pio_utils, only: cam_pio_handle_error, cam_pio_newdecomp
+ use cam_abortutils,only: check_allocate
! Dummy arguments
class(cam_grid_patch_t) :: this
@@ -4339,7 +4450,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info)
map => this%lonmap
else
field_lens(1) = 0
- allocate(map(0))
+ allocate(map(0), stat=ierr)
+ call check_allocate(ierr, subname, 'map', file=__FILE__, &
+ line=__LINE__-1)
end if
file_lens(1) = this%global_lon_size
!! XXgoldyXX: Think about caching these decomps
@@ -4351,7 +4464,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info)
if (associated(coord_p)) then
coord => coord_p
else
- allocate(coord(0))
+ allocate(coord(0), stat=ierr)
+ call check_allocate(ierr, subname, 'coord', file=__FILE__, &
+ line=__LINE__-1)
end if
end if
vdesc => header_info%get_lon_varid()
@@ -4371,7 +4486,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info)
map => this%latmap
else
field_lens(1) = 0
- allocate(map(0))
+ allocate(map(0), stat=ierr)
+ call check_allocate(ierr, subname, 'map', file=__FILE__, &
+ line=__LINE__-1)
end if
file_lens(1) = this%global_lat_size
!! XXgoldyXX: Think about caching these decomps
@@ -4384,7 +4501,9 @@ subroutine cam_grid_patch_write_vals(this, File, header_info)
if (associated(coord_p)) then
coord => coord_p
else
- allocate(coord(0))
+ allocate(coord(0), stat=ierr)
+ call check_allocate(ierr, subname, 'coord', file=__FILE__, &
+ line=__LINE__-1)
end if
end if
vdesc => header_info%get_lat_varid()
@@ -4449,6 +4568,7 @@ subroutine cam_grid_header_info_set_gridid(this, id)
end subroutine cam_grid_header_info_set_gridid
subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2)
+ use cam_abortutils, only: check_allocate
! Dummy arguments
class(cam_grid_header_info_t) :: this
integer, intent(in) :: hdim1
@@ -4456,6 +4576,7 @@ subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2)
! Local variables
integer :: hdsize
+ integer :: ierr
character(len=*), parameter :: subname = 'cam_grid_header_info_set_hdims'
if (present(hdim2)) then
@@ -4470,7 +4591,9 @@ subroutine cam_grid_header_info_set_hdims(this, hdim1, hdim2)
call endrun(subname//': hdims is wrong size')
end if
else
- allocate(this%hdims(hdsize))
+ allocate(this%hdims(hdsize), stat=ierr)
+ call check_allocate(ierr, subname, 'this%hdims', file=__FILE__, &
+ line=__LINE__-1)
end if
this%hdims(1) = hdim1
if (present(hdim2)) then
@@ -4497,7 +4620,7 @@ integer function cam_grid_header_info_hdim(this, index) result(id)
integer, intent(in) :: index
! Local variable
- character(len=120) :: errormsg
+ character(len=shr_kind_cm) :: errormsg
if (allocated(this%hdims)) then
if ((index >= 1) .and. (index <= size(this%hdims))) then
diff --git a/src/utils/string_utils.F90 b/src/utils/string_utils.F90
index 812a5f76..223d54da 100644
--- a/src/utils/string_utils.F90
+++ b/src/utils/string_utils.F90
@@ -16,7 +16,6 @@ module string_utils
public :: increment_string ! increments a string
public :: last_sig_char ! Position of last significant character in string
public :: to_str ! convert integer to left justified string
- public :: parse_multiplier ! Parse a repeat count and a token from input
public :: stringify ! Convert one or more values of any intrinsic data types to a character string for pretty printing
! Private module variables
@@ -110,7 +109,7 @@ character(len=8) function sec2hms (seconds)
if (seconds < 0 .or. seconds > 86400) then
write(iulog,*)'SEC2HMS: bad input seconds:', seconds
- call endrun ('SEC2HMS: bad input seconds:')
+ call endrun ('SEC2HMS: bad input seconds: '//stringify((/seconds/)))
end if
hours = seconds / 3600
@@ -288,103 +287,6 @@ end function to_str
!===========================================================================
- subroutine parse_multiplier(input, multiplier, token, allowed_set, errmsg)
- ! Parse a character string () to find a token , possibly
- ! multiplied by an integer ().
- ! Return values for :
- ! positive integer: Successful return with and .
- ! zero: is an empty string
- ! -1: Error condition (malformed input string)
- ! Return values for
- ! On a successful return, will contain with the
- ! optional multiplier and multiplication symbol removed.
- ! On an error return, will be an empty string
- !
- ! If is present, then must equal a value in
- ! (case insensitive)
- ! If is present, it is filled with an error message if
- ! is not an allowed format.
- ! Allowed formats are:
- ! * where is the string representation
- ! a positive integer.
- ! in which case is assumed to be one.
- !
-
- ! Dummy arguments
- character(len=*), intent(in) :: input
- integer, intent(out) :: multiplier
- character(len=*), intent(out) :: token
- character(len=*), optional, intent(in) :: allowed_set(:)
- character(len=*), optional, intent(out) :: errmsg
- ! Local variables
- integer :: mult_ind ! Index of multiplication symbol
- integer :: lind ! Loop index
- integer :: alen ! Number of entries in
- integer :: stat ! Read status
- logical :: match ! For matching
- character(len=8) :: fmt_str ! Format string
-
- ! Initialize output
- errmsg = ''
- multiplier = -1
- token = ''
- ! Do we have a multipler?
- mult_ind = index(input, '*')
- if (len_trim(input) == 0) then
- multiplier = 0
- else if (mult_ind <= 0) then
- multiplier = 1
- token = trim(input)
- else
- write(fmt_str, '(a,i0,a)') "(i", mult_ind - 1, ")"
- read(input, fmt_str, iostat=stat) multiplier
- if (stat == 0) then
- token = trim(input(mult_ind+1:))
- else
- if (present(errmsg)) then
- write(errmsg, *) "Invalid multiplier, '", &
- input(1:mult_ind-1), "' in '", trim(input), "'"
- end if
- multiplier = -1
- token = ''
- end if
- end if
-
- if ((multiplier >= 0) .and. present(allowed_set)) then
- alen = size(allowed_set)
- match = .false.
- do lind = 1, alen
- if (trim(to_lower(token)) == trim(to_lower(allowed_set(lind)))) then
- match = .true.
- exit
- end if
- end do
- if (.not. match) then
- if (present(errmsg)) then
- write(errmsg, *) "Error, token, '", trim(token), "' not in (/"
- lind = len_trim(errmsg) + 1
- do mult_ind = 1, alen
- if (mult_ind == alen) then
- fmt_str = "' "
- else
- fmt_str = "', "
- end if
- write(errmsg(lind:), *) "'", trim(allowed_set(mult_ind)), &
- trim(fmt_str)
- lind = lind + len_trim(allowed_set(mult_ind)) + &
- len_trim(fmt_str) + 2
- end do
- write(errmsg(lind:), *) "/)"
- end if
- multiplier = -1
- token = ''
- end if
- end if
-
- end subroutine parse_multiplier
-
- !===========================================================================
-
!> Convert one or more values of any intrinsic data types to a character string for pretty printing.
!> If `value` contains more than one element, the elements will be stringified, delimited by `separator`, then concatenated.
!> If `value` contains exactly one element, the element will be stringified without using `separator`.